module GHC.Iface.UpdateIdInfos
( updateModDetailsIdInfos
) where
import GHC.Prelude
import GHC.Core
import GHC.Core.InstEnv
import GHC.Driver.Session
import GHC.Driver.Types
import GHC.StgToCmm.Types (CgInfos (..))
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Types.Var
import GHC.Utils.Misc
import GHC.Utils.Outputable
#include "HsVersions.h"
updateModDetailsIdInfos
:: DynFlags
-> CgInfos
-> ModDetails
-> ModDetails
updateModDetailsIdInfos dflags _ mod_details
| gopt Opt_OmitInterfacePragmas dflags
= mod_details
updateModDetailsIdInfos _ cg_infos mod_details =
let
ModDetails{ md_types = type_env
, md_insts = insts
, md_rules = rules
} = mod_details
~type_env' = mapNameEnv (updateTyThingIdInfos type_env' cg_infos) type_env
!insts' = strictMap (updateInstIdInfos type_env' cg_infos) insts
!rules' = strictMap (updateRuleIdInfos type_env') rules
in
mod_details{ md_types = type_env'
, md_insts = insts'
, md_rules = rules'
}
updateRuleIdInfos :: TypeEnv -> CoreRule -> CoreRule
updateRuleIdInfos _ rule@BuiltinRule{} = rule
updateRuleIdInfos type_env Rule{ .. } = Rule { ru_rhs = updateGlobalIds type_env ru_rhs, .. }
updateInstIdInfos :: TypeEnv -> CgInfos -> ClsInst -> ClsInst
updateInstIdInfos type_env cg_infos =
updateClsInstDFun (updateIdUnfolding type_env . updateIdInfo cg_infos)
updateTyThingIdInfos :: TypeEnv -> CgInfos -> TyThing -> TyThing
updateTyThingIdInfos type_env cg_infos (AnId id) =
AnId (updateIdUnfolding type_env (updateIdInfo cg_infos id))
updateTyThingIdInfos _ _ other = other
updateIdUnfolding :: TypeEnv -> Id -> Id
updateIdUnfolding type_env id =
case idUnfolding id of
CoreUnfolding{ .. } ->
setIdUnfolding id CoreUnfolding{ uf_tmpl = updateGlobalIds type_env uf_tmpl, .. }
DFunUnfolding{ .. } ->
setIdUnfolding id DFunUnfolding{ df_args = map (updateGlobalIds type_env) df_args, .. }
_ -> id
updateIdInfo :: CgInfos -> Id -> Id
updateIdInfo CgInfos{ cgNonCafs = NonCaffySet non_cafs, cgLFInfos = lf_infos } id =
let
not_caffy = elemNameSet (idName id) non_cafs
mb_lf_info = lookupNameEnv lf_infos (idName id)
id1 = if not_caffy then setIdCafInfo id NoCafRefs else id
id2 = case mb_lf_info of
Nothing -> id1
Just lf_info -> setIdLFInfo id1 lf_info
in
id2
updateGlobalIds :: NameEnv TyThing -> CoreExpr -> CoreExpr
updateGlobalIds env e = go env e
where
go_id :: NameEnv TyThing -> Id -> Id
go_id env var =
case lookupNameEnv env (varName var) of
Nothing -> var
Just (AnId id) -> id
Just other -> pprPanic "UpdateIdInfos.updateGlobalIds" $
text "Found a non-Id for Id Name" <+> ppr (varName var) $$
nest 4 (text "Id:" <+> ppr var $$
text "TyThing:" <+> ppr other)
go :: NameEnv TyThing -> CoreExpr -> CoreExpr
go env (Var v) = Var (go_id env v)
go _ e@Lit{} = e
go env (App e1 e2) = App (go env e1) (go env e2)
go env (Lam b e) = assertNotInNameEnv env [b] (Lam b (go env e))
go env (Let bs e) = Let (go_binds env bs) (go env e)
go env (Case e b ty alts) =
assertNotInNameEnv env [b] (Case (go env e) b ty (map go_alt alts))
where
go_alt (k,bs,e) = assertNotInNameEnv env bs (k, bs, go env e)
go env (Cast e c) = Cast (go env e) c
go env (Tick t e) = Tick t (go env e)
go _ e@Type{} = e
go _ e@Coercion{} = e
go_binds :: NameEnv TyThing -> CoreBind -> CoreBind
go_binds env (NonRec b e) =
assertNotInNameEnv env [b] (NonRec b (go env e))
go_binds env (Rec prs) =
assertNotInNameEnv env (map fst prs) (Rec (mapSnd (go env) prs))
assertNotInNameEnv :: NameEnv a -> [Id] -> b -> b
assertNotInNameEnv env ids x = ASSERT(not (any (\id -> elemNameEnv (idName id) env) ids)) x