-instantiateDictRhs :: TyVarEnv Type -> IdEnv Id -> CoreExpr -> CoreExpr
- -- Cheapo function for simple RHSs
-instantiateDictRhs ty_env id_env rhs
- = go rhs
- where
- go (App e1 (VarArg a)) = App (go e1) (VarArg (lookupId id_env a))
- go (App e1 (TyArg t)) = App (go e1) (TyArg (instantiateTy ty_env t))
- go (Var v) = Var (lookupId id_env v)
- go (Lit l) = Lit l
-
-dictRhsFVs :: CoreExpr -> IdSet
- -- Cheapo function for simple RHSs
-dictRhsFVs (App e1 (VarArg a)) = dictRhsFVs e1 `addOneToIdSet` a
-dictRhsFVs (App e1 (TyArg t)) = dictRhsFVs e1
-dictRhsFVs (Var v) = unitIdSet v
-dictRhsFVs (Lit l) = emptyIdSet
-
-
-addIdSpecialisations id spec_stuff
- = (if not (null errs) then
- pprTrace "Duplicate specialisations" (vcat (map ppr errs))
- else \x -> x
- )
- setIdSpecialisation id new_spec_env
- where
- (new_spec_env, errs) = foldr add (getIdSpecialisation id, []) spec_stuff
-
- add (tyvars, tys, template) (spec_env, errs)
- = case addToSpecEnv True spec_env tyvars tys template of
- Succeeded spec_env' -> (spec_env', errs)
- Failed err -> (spec_env, err:errs)
-
--- Given an Id, isSpecVars returns all its specialisations.
--- We extract these from its SpecEnv.
--- This is used by the occurrence analyser and free-var finder;
--- we regard an Id's specialisations as free in the Id's definition.
-
-idSpecVars :: Id -> [Id]
-idSpecVars id
- = map get_spec (specEnvValues (getIdSpecialisation id))
- where
- -- get_spec is another cheapo function like dictRhsFVs
- -- It knows what these specialisation temlates look like,
- -- and just goes for the jugular
- get_spec (App f _) = get_spec f
- get_spec (Lam _ b) = get_spec b
- get_spec (Var v) = v
-
--- substSpecEnvRhs applies a substitution to the RHS's of a SpecEnv
--- It's placed here because Specialise.lhs built that RHS, so
--- it knows its structure. (Fully general subst
-
-substSpecEnvRhs te ve rhs
- = go te ve rhs
- where
- go te ve (App f (TyArg ty)) = App (go te ve f) (TyArg (instantiateTy te ty))
- go te ve (App f (VarArg v)) = App (go te ve f) (case lookupIdEnv ve v of
- Just arg' -> arg'
- Nothing -> VarArg v)
- go te ve (Var v) = case lookupIdEnv ve v of
- Just (VarArg v') -> Var v'
- Just (LitArg l) -> Lit l
- Nothing -> Var v
-
- -- These equations are a bit half baked, because
- -- they don't deal properly wih capture.
- -- But I'm sure it'll never matter... sigh.
- go te ve (Lam b@(TyBinder tyvar) e) = Lam b (go te' ve e)
- where
- te' = delFromTyVarEnv te tyvar
-
- go te ve (Lam b@(ValBinder v) e) = Lam b (go te ve' e)
- where
- ve' = delOneFromIdEnv ve v
-