3578b0b437bcf7d7ef2d14c828b16871a35ebc2a
[ghc.git] / compiler / coreSyn / CoreTidy.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The AQUA Project, Glasgow University, 1996-1998
4
5
6 This module contains "tidying" code for *nested* expressions, bindings, rules.
7 The code for *top-level* bindings is in TidyPgm.
8 -}
9
10 {-# LANGUAGE CPP #-}
11 module CoreTidy (
12 tidyExpr, tidyVarOcc, tidyRule, tidyRules, tidyUnfolding
13 ) where
14
15 #include "HsVersions.h"
16
17 import CoreSyn
18 import CoreUnfold ( mkCoreUnfolding )
19 import CoreArity
20 import Id
21 import IdInfo
22 import Demand ( zapUsageEnvSig )
23 import Type( tidyType, tidyTyCoVarBndr )
24 import Coercion( tidyCo )
25 import Var
26 import VarEnv
27 import UniqFM
28 import Name hiding (tidyNameOcc)
29 import SrcLoc
30 import Maybes
31 import Data.List
32
33 {-
34 ************************************************************************
35 * *
36 \subsection{Tidying expressions, rules}
37 * *
38 ************************************************************************
39 -}
40
41 tidyBind :: TidyEnv
42 -> CoreBind
43 -> (TidyEnv, CoreBind)
44
45 tidyBind env (NonRec bndr rhs)
46 = tidyLetBndr env env (bndr,rhs) =: \ (env', bndr') ->
47 (env', NonRec bndr' (tidyExpr env' rhs))
48
49 tidyBind env (Rec prs)
50 = let
51 (env', bndrs') = mapAccumL (tidyLetBndr env') env prs
52 in
53 map (tidyExpr env') (map snd prs) =: \ rhss' ->
54 (env', Rec (zip bndrs' rhss'))
55
56
57 ------------ Expressions --------------
58 tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr
59 tidyExpr env (Var v) = Var (tidyVarOcc env v)
60 tidyExpr env (Type ty) = Type (tidyType env ty)
61 tidyExpr env (Coercion co) = Coercion (tidyCo env co)
62 tidyExpr _ (Lit lit) = Lit lit
63 tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a)
64 tidyExpr env (Tick t e) = Tick (tidyTickish env t) (tidyExpr env e)
65 tidyExpr env (Cast e co) = Cast (tidyExpr env e) (tidyCo env co)
66
67 tidyExpr env (Let b e)
68 = tidyBind env b =: \ (env', b') ->
69 Let b' (tidyExpr env' e)
70
71 tidyExpr env (Case e b ty alts)
72 = tidyBndr env b =: \ (env', b) ->
73 Case (tidyExpr env e) b (tidyType env ty)
74 (map (tidyAlt env') alts)
75
76 tidyExpr env (Lam b e)
77 = tidyBndr env b =: \ (env', b) ->
78 Lam b (tidyExpr env' e)
79
80 ------------ Case alternatives --------------
81 tidyAlt :: TidyEnv -> CoreAlt -> CoreAlt
82 tidyAlt env (con, vs, rhs)
83 = tidyBndrs env vs =: \ (env', vs) ->
84 (con, vs, tidyExpr env' rhs)
85
86 ------------ Tickish --------------
87 tidyTickish :: TidyEnv -> Tickish Id -> Tickish Id
88 tidyTickish env (Breakpoint ix ids) = Breakpoint ix (map (tidyVarOcc env) ids)
89 tidyTickish _ other_tickish = other_tickish
90
91 ------------ Rules --------------
92 tidyRules :: TidyEnv -> [CoreRule] -> [CoreRule]
93 tidyRules _ [] = []
94 tidyRules env (rule : rules)
95 = tidyRule env rule =: \ rule ->
96 tidyRules env rules =: \ rules ->
97 (rule : rules)
98
99 tidyRule :: TidyEnv -> CoreRule -> CoreRule
100 tidyRule _ rule@(BuiltinRule {}) = rule
101 tidyRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs,
102 ru_fn = fn, ru_rough = mb_ns })
103 = tidyBndrs env bndrs =: \ (env', bndrs) ->
104 map (tidyExpr env') args =: \ args ->
105 rule { ru_bndrs = bndrs, ru_args = args,
106 ru_rhs = tidyExpr env' rhs,
107 ru_fn = tidyNameOcc env fn,
108 ru_rough = map (fmap (tidyNameOcc env')) mb_ns }
109
110 {-
111 ************************************************************************
112 * *
113 \subsection{Tidying non-top-level binders}
114 * *
115 ************************************************************************
116 -}
117
118 tidyNameOcc :: TidyEnv -> Name -> Name
119 -- In rules and instances, we have Names, and we must tidy them too
120 -- Fortunately, we can lookup in the VarEnv with a name
121 tidyNameOcc (_, var_env) n = case lookupUFM var_env n of
122 Nothing -> n
123 Just v -> idName v
124
125 tidyVarOcc :: TidyEnv -> Var -> Var
126 tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v
127
128 -- tidyBndr is used for lambda and case binders
129 tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
130 tidyBndr env var
131 | isTyCoVar var = tidyTyCoVarBndr env var
132 | otherwise = tidyIdBndr env var
133
134 tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
135 tidyBndrs env vars = mapAccumL tidyBndr env vars
136
137 -- Non-top-level variables, not covars
138 tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id)
139 tidyIdBndr env@(tidy_env, var_env) id
140 = -- Do this pattern match strictly, otherwise we end up holding on to
141 -- stuff in the OccName.
142 case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') ->
143 let
144 -- Give the Id a fresh print-name, *and* rename its type
145 -- The SrcLoc isn't important now,
146 -- though we could extract it from the Id
147 --
148 ty' = tidyType env (idType id)
149 name' = mkInternalName (idUnique id) occ' noSrcSpan
150 id' = mkLocalIdWithInfo name' ty' new_info
151 var_env' = extendVarEnv var_env id id'
152
153 -- Note [Tidy IdInfo]
154 new_info = vanillaIdInfo `setOccInfo` occInfo old_info
155 `setUnfoldingInfo` new_unf
156 -- see Note [Preserve OneShotInfo]
157 `setOneShotInfo` oneShotInfo old_info
158 old_info = idInfo id
159 old_unf = unfoldingInfo old_info
160 new_unf | isEvaldUnfolding old_unf = evaldUnfolding
161 | otherwise = noUnfolding
162 -- See Note [Preserve evaluatedness]
163 in
164 ((tidy_env', var_env'), id')
165 }
166
167 tidyLetBndr :: TidyEnv -- Knot-tied version for unfoldings
168 -> TidyEnv -- The one to extend
169 -> (Id, CoreExpr) -> (TidyEnv, Var)
170 -- Used for local (non-top-level) let(rec)s
171 -- Just like tidyIdBndr above, but with more IdInfo
172 tidyLetBndr rec_tidy_env env@(tidy_env, var_env) (id,rhs)
173 = case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') ->
174 let
175 ty' = tidyType env (idType id)
176 name' = mkInternalName (idUnique id) occ' noSrcSpan
177 details = idDetails id
178 id' = mkLocalVar details name' ty' new_info
179 var_env' = extendVarEnv var_env id id'
180
181 -- Note [Tidy IdInfo]
182 -- We need to keep around any interesting strictness and
183 -- demand info because later on we may need to use it when
184 -- converting to A-normal form.
185 -- eg.
186 -- f (g x), where f is strict in its argument, will be converted
187 -- into case (g x) of z -> f z by CorePrep, but only if f still
188 -- has its strictness info.
189 --
190 -- Similarly for the demand info - on a let binder, this tells
191 -- CorePrep to turn the let into a case.
192 -- But: Remove the usage demand here
193 -- (See Note [Zapping DmdEnv after Demand Analyzer] in WorkWrap)
194 --
195 -- Similarly arity info for eta expansion in CorePrep
196 --
197 -- Set inline-prag info so that we preseve it across
198 -- separate compilation boundaries
199 old_info = idInfo id
200 new_info = vanillaIdInfo
201 `setOccInfo` occInfo old_info
202 `setArityInfo` exprArity rhs
203 `setStrictnessInfo` zapUsageEnvSig (strictnessInfo old_info)
204 `setDemandInfo` demandInfo old_info
205 `setInlinePragInfo` inlinePragInfo old_info
206 `setUnfoldingInfo` new_unf
207
208 new_unf | isStableUnfolding old_unf = tidyUnfolding rec_tidy_env old_unf old_unf
209 | isEvaldUnfolding old_unf = evaldUnfolding
210 -- See Note [Preserve evaluatedness]
211 | otherwise = noUnfolding
212 old_unf = unfoldingInfo old_info
213 in
214 ((tidy_env', var_env'), id') }
215
216 ------------ Unfolding --------------
217 tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding
218 tidyUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) _
219 = df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args }
220 where
221 (tidy_env', bndrs') = tidyBndrs tidy_env bndrs
222
223 tidyUnfolding tidy_env
224 (CoreUnfolding { uf_tmpl = unf_rhs, uf_is_top = top_lvl
225 , uf_src = src, uf_guidance = guidance })
226 unf_from_rhs
227 | isStableSource src
228 = mkCoreUnfolding src top_lvl (tidyExpr tidy_env unf_rhs) guidance
229 -- Preserves OccInfo
230
231 -- Note that uf_is_value and friends may be a thunk containing a reference
232 -- to the old template. Consequently it is important that we rebuild them,
233 -- despite the fact that they won't change, to avoid a space leak (since,
234 -- e.g., ToIface doesn't look at them; see #13564). This is the same
235 -- approach we use in Simplify.simplUnfolding and TcIface.tcUnfolding.
236
237 | otherwise
238 = unf_from_rhs
239 tidyUnfolding _ unf _ = unf -- NoUnfolding or OtherCon
240
241 {-
242 Note [Tidy IdInfo]
243 ~~~~~~~~~~~~~~~~~~
244 All nested Ids now have the same IdInfo, namely vanillaIdInfo, which
245 should save some space; except that we preserve occurrence info for
246 two reasons:
247
248 (a) To make printing tidy core nicer
249
250 (b) Because we tidy RULES and InlineRules, which may then propagate
251 via --make into the compilation of the next module, and we want
252 the benefit of that occurrence analysis when we use the rule or
253 or inline the function. In particular, it's vital not to lose
254 loop-breaker info, else we get an infinite inlining loop
255
256 Note that tidyLetBndr puts more IdInfo back.
257
258 Note [Preserve evaluatedness]
259 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
260 Consider
261 data T = MkT !Bool
262 ....(case v of MkT y ->
263 let z# = case y of
264 True -> 1#
265 False -> 2#
266 in ...)
267
268 The z# binding is ok because the RHS is ok-for-speculation,
269 but Lint will complain unless it can *see* that. So we
270 preserve the evaluated-ness on 'y' in tidyBndr.
271
272 (Another alternative would be to tidy unboxed lets into cases,
273 but that seems more indirect and surprising.)
274
275 Note [Preserve OneShotInfo]
276 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
277 We keep the OneShotInfo because we want it to propagate into the interface.
278 Not all OneShotInfo is determined by a compiler analysis; some is added by a
279 call of GHC.Exts.oneShot, which is then discarded before the end of the
280 optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we
281 must preserve this info in inlinings. See Note [The oneShot function] in MkId.
282
283 This applies to lambda binders only, hence it is stored in IfaceLamBndr.
284 -}
285
286 (=:) :: a -> (a -> b) -> b
287 m =: k = m `seq` k m