-lookupId:: IdEnv Id -> Id -> Id
-lookupId env id = case lookupIdEnv env id of
- Nothing -> id
- Just id' -> id'
-
-instantiateDictRhs :: TyVarEnv Type -> IdEnv Id -> CoreExpr -> CoreExpr
- -- Cheapo function for simple RHSs
-instantiateDictRhs ty_env id_env rhs
- = go rhs
- where
- go_arg (VarArg a) = VarArg (lookupId id_env a)
- go_arg (TyArg t) = TyArg (instantiateTy ty_env t)
-
- go (App e1 arg) = App (go e1) (go_arg arg)
- go (Var v) = Var (lookupId id_env v)
- go (Lit l) = Lit l
- go (Con con args) = Con con (map go_arg args)
- go (Note n e) = Note (go_note n) (go e)
- go (Case e alts) = Case (go e) alts -- See comment below re alts
- go other = pprPanic "instantiateDictRhs" (ppr rhs)
-
- go_note (Coerce t1 t2) = Coerce (instantiateTy ty_env t1) (instantiateTy ty_env t2)
- go_note note = note
-
-dictRhsFVs :: CoreExpr -> IdSet
- -- Cheapo function for simple RHSs
-dictRhsFVs e
- = go e
- where
- go (App e1 (VarArg a)) = go e1 `addOneToIdSet` a
- go (App e1 (LitArg l)) = go e1
- go (App e1 (TyArg t)) = go e1
- go (Var v) = unitIdSet v
- go (Lit l) = emptyIdSet
- go (Con _ args) = mkIdSet [id | VarArg id <- args]
- go (Note _ e) = go e
-
- go (Case e _) = go e -- Claim: no free dictionaries in the alternatives
- -- These case expressions are of the form
- -- case d of { D a b c -> b }
-
- go other = pprPanic "dictRhsFVs" (ppr e)
-
-
-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
-
-----------------------------------------