1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
{-# LANGUAGE CPP, BangPatterns, Strict, RecordWildCards #-}
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
import GHC.Utils.Panic
#include "HsVersions.h"
-- | Update CafInfos and LFInfos of all occurences (in rules, unfoldings, class
-- instances).
--
-- See Note [Conveying CAF-info and LFInfo between modules] in
-- GHC.StgToCmm.Types.
updateModDetailsIdInfos
:: DynFlags
-> CgInfos
-> ModDetails -- ^ ModDetails to update
-> ModDetails
updateModDetailsIdInfos dflags _ mod_details
| gopt Opt_OmitInterfacePragmas dflags
= mod_details
updateModDetailsIdInfos _ cg_infos mod_details =
let
ModDetails{ md_types = type_env -- for unfoldings
, md_insts = insts
, md_rules = rules
} = mod_details
-- type TypeEnv = NameEnv TyThing
~type_env' = mapNameEnv (updateTyThingIdInfos type_env' cg_infos) type_env
-- Not strict!
!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'
}
--------------------------------------------------------------------------------
-- Rules
--------------------------------------------------------------------------------
updateRuleIdInfos :: TypeEnv -> CoreRule -> CoreRule
updateRuleIdInfos _ rule@BuiltinRule{} = rule
updateRuleIdInfos type_env Rule{ .. } = Rule { ru_rhs = updateGlobalIds type_env ru_rhs, .. }
--------------------------------------------------------------------------------
-- Instances
--------------------------------------------------------------------------------
updateInstIdInfos :: TypeEnv -> CgInfos -> ClsInst -> ClsInst
updateInstIdInfos type_env cg_infos =
updateClsInstDFun (updateIdUnfolding type_env . updateIdInfo cg_infos)
--------------------------------------------------------------------------------
-- TyThings
--------------------------------------------------------------------------------
updateTyThingIdInfos :: TypeEnv -> CgInfos -> TyThing -> TyThing
updateTyThingIdInfos type_env cg_infos (AnId id) =
AnId (updateIdUnfolding type_env (updateIdInfo cg_infos id))
updateTyThingIdInfos _ _ other = other -- AConLike, ATyCon, ACoAxiom
--------------------------------------------------------------------------------
-- Unfoldings
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
-- Expressions
--------------------------------------------------------------------------------
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
-- Update occurrences of GlobalIds as directed by 'env'
-- The 'env' maps a GlobalId to a version with accurate CAF info
-- (and in due course perhaps other back-end-related info)
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))
-- In `updateGlobaLIds` Names of local binders should not shadow Name of
-- globals. This assertion is to check that.
assertNotInNameEnv :: NameEnv a -> [Id] -> b -> b
assertNotInNameEnv env ids x = ASSERT(not (any (\id -> elemNameEnv (idName id) env) ids)) x
|
