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
|
{-# LANGUAGE CPP, BangPatterns, Strict, RecordWildCards #-}
module UpdateCafInfos
( updateModDetailsCafInfos
) where
import GhcPrelude
import GHC.Core
import GHC.Driver.Types
import Id
import IdInfo
import InstEnv
import NameEnv
import NameSet
import Util
import Var
import Outputable
#include "HsVersions.h"
-- | Update CafInfos of all occurences (in rules, unfoldings, class instances)
updateModDetailsCafInfos
:: NameSet -- ^ Non-CAFFY names in the module. Names not in this set are CAFFY.
-> ModDetails -- ^ ModDetails to update
-> ModDetails
updateModDetailsCafInfos non_cafs mod_details =
{- pprTrace "updateModDetailsCafInfos" (text "non_cafs:" <+> ppr non_cafs) $ -}
let
ModDetails{ md_types = type_env -- for unfoldings
, md_insts = insts
, md_rules = rules
} = mod_details
-- type TypeEnv = NameEnv TyThing
~type_env' = mapNameEnv (updateTyThingCafInfos type_env' non_cafs) type_env
-- Not strict!
!insts' = strictMap (updateInstCafInfos type_env' non_cafs) insts
!rules' = strictMap (updateRuleCafInfos type_env') rules
in
mod_details{ md_types = type_env'
, md_insts = insts'
, md_rules = rules'
}
--------------------------------------------------------------------------------
-- Rules
--------------------------------------------------------------------------------
updateRuleCafInfos :: TypeEnv -> CoreRule -> CoreRule
updateRuleCafInfos _ rule@BuiltinRule{} = rule
updateRuleCafInfos type_env Rule{ .. } = Rule { ru_rhs = updateGlobalIds type_env ru_rhs, .. }
--------------------------------------------------------------------------------
-- Instances
--------------------------------------------------------------------------------
updateInstCafInfos :: TypeEnv -> NameSet -> ClsInst -> ClsInst
updateInstCafInfos type_env non_cafs =
updateClsInstDFun (updateIdUnfolding type_env . updateIdCafInfo non_cafs)
--------------------------------------------------------------------------------
-- TyThings
--------------------------------------------------------------------------------
updateTyThingCafInfos :: TypeEnv -> NameSet -> TyThing -> TyThing
updateTyThingCafInfos type_env non_cafs (AnId id) =
AnId (updateIdUnfolding type_env (updateIdCafInfo non_cafs id))
updateTyThingCafInfos _ _ 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
--------------------------------------------------------------------------------
updateIdCafInfo :: NameSet -> Id -> Id
updateIdCafInfo non_cafs id
| idName id `elemNameSet` non_cafs
= -- pprTrace "updateIdCafInfo" (text "Marking" <+> ppr id <+> parens (ppr (idName id)) <+> text "as non-CAFFY") $
id `setIdCafInfo` NoCafRefs
| otherwise
= id
--------------------------------------------------------------------------------
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 "UpdateCafInfos.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
|
