9316ec08afda33b816eb091f7c0c16275c3a5351
[ghc.git] / compiler / simplCore / SimplEnv.hs
1 {-
2 (c) The AQUA Project, Glasgow University, 1993-1998
3
4 \section[SimplMonad]{The simplifier Monad}
5 -}
6
7 {-# LANGUAGE CPP #-}
8
9 module SimplEnv (
10 -- * The simplifier mode
11 setMode, getMode, updMode,
12
13 -- * Environments
14 SimplEnv(..), StaticEnv, pprSimplEnv, -- Temp not abstract
15 mkSimplEnv, extendIdSubst,
16 SimplEnv.extendTvSubst, SimplEnv.extendCvSubst,
17 zapSubstEnv, setSubstEnv,
18 getInScope, setInScopeAndZapFloats,
19 setInScopeSet, modifyInScope, addNewInScopeIds,
20 getSimplRules,
21
22 -- * Substitution results
23 SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope,
24
25 -- * Simplifying 'Id' binders
26 simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs,
27 simplBinder, simplBinders,
28 substTy, substTyVar, getTCvSubst,
29 substCo, substCoVar,
30
31 -- * Floats
32 Floats, emptyFloats, isEmptyFloats,
33 addNonRec, addLetFloats, addFloats, extendFloats, addFlts,
34 wrapFloats, setFloats, zapFloats, addRecFloats, mapFloats,
35 doFloatFromRhs, getFloatBinds,
36
37 JoinFloat, JoinFloats, emptyJoinFloats, isEmptyJoinFloats,
38 wrapJoinFloats, wrapJoinFloatsX, zapJoinFloats, addJoinFloats
39 ) where
40
41 #include "HsVersions.h"
42
43 import SimplMonad
44 import CoreMonad ( SimplifierMode(..) )
45 import CoreSyn
46 import CoreUtils
47 import Var
48 import VarEnv
49 import VarSet
50 import OrdList
51 import Id
52 import MkCore ( mkWildValBinder )
53 import TysWiredIn
54 import qualified Type
55 import Type hiding ( substTy, substTyVar, substTyVarBndr )
56 import qualified Coercion
57 import Coercion hiding ( substCo, substCoVar, substCoVarBndr )
58 import BasicTypes
59 import MonadUtils
60 import Outputable
61 import Util
62 import UniqFM ( pprUniqFM )
63
64 import Data.List
65
66 {-
67 ************************************************************************
68 * *
69 \subsubsection{The @SimplEnv@ type}
70 * *
71 ************************************************************************
72 -}
73
74 data SimplEnv
75 = SimplEnv {
76 ----------- Static part of the environment -----------
77 -- Static in the sense of lexically scoped,
78 -- wrt the original expression
79
80 seMode :: SimplifierMode,
81
82 -- The current substitution
83 seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
84 seCvSubst :: CvSubstEnv, -- InCoVar |--> OutCoercion
85 seIdSubst :: SimplIdSubst, -- InId |--> OutExpr
86
87 ----------- Dynamic part of the environment -----------
88 -- Dynamic in the sense of describing the setup where
89 -- the expression finally ends up
90
91 -- The current set of in-scope variables
92 -- They are all OutVars, and all bound in this module
93 seInScope :: InScopeSet, -- OutVars only
94 -- Includes all variables bound
95 -- by seLetFloats and seJoinFloats
96
97 -- Ordinary bindings
98 seLetFloats :: Floats,
99 -- See Note [Simplifier floats]
100
101 -- Join points
102 seJoinFloats :: JoinFloats
103 -- Handled separately; they don't go very far
104 -- We consider these to be /inside/ seLetFloats
105 -- because join points can refer to ordinary bindings,
106 -- but not vice versa
107 }
108
109 type StaticEnv = SimplEnv -- Just the static part is relevant
110
111 pprSimplEnv :: SimplEnv -> SDoc
112 -- Used for debugging; selective
113 pprSimplEnv env
114 = vcat [text "TvSubst:" <+> ppr (seTvSubst env),
115 text "CvSubst:" <+> ppr (seCvSubst env),
116 text "IdSubst:" <+> id_subst_doc,
117 text "InScope:" <+> in_scope_vars_doc
118 ]
119 where
120 id_subst_doc = pprUniqFM ppr (seIdSubst env)
121 in_scope_vars_doc = pprVarSet (getInScopeVars (seInScope env))
122 (vcat . map ppr_one)
123 ppr_one v | isId v = ppr v <+> ppr (idUnfolding v)
124 | otherwise = ppr v
125
126 type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
127 -- See Note [Extending the Subst] in CoreSubst
128
129 -- | A substitution result.
130 data SimplSR
131 = DoneEx OutExpr (Maybe JoinArity)
132 -- If x :-> DoneEx e ja is in the SimplIdSubst
133 -- then replace occurrences of x by e
134 -- and ja = Just a <=> x is a join-point of arity a
135 -- See Note [Join arity in SimplIdSubst]
136
137
138 | DoneId OutId
139 -- If x :-> DoneId v is in the SimplIdSubst
140 -- then replace occurrences of x by v
141 -- and v is a join-point of arity a
142 -- <=> x is a join-point of arity a
143
144 | ContEx TvSubstEnv -- A suspended substitution
145 CvSubstEnv
146 SimplIdSubst
147 InExpr
148 -- If x :-> ContEx tv cv id e is in the SimplISubst
149 -- then replace occurrences of x by (subst (tv,cv,id) e)
150
151 instance Outputable SimplSR where
152 ppr (DoneId v) = text "DoneId" <+> ppr v
153 ppr (DoneEx e mj) = text "DoneEx" <> pp_mj <+> ppr e
154 where
155 pp_mj = case mj of
156 Nothing -> empty
157 Just n -> parens (int n)
158
159 ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-,
160 ppr (filter_env tv), ppr (filter_env id) -}]
161 -- where
162 -- fvs = exprFreeVars e
163 -- filter_env env = filterVarEnv_Directly keep env
164 -- keep uniq _ = uniq `elemUFM_Directly` fvs
165
166 {-
167 Note [SimplEnv invariants]
168 ~~~~~~~~~~~~~~~~~~~~~~~~~~
169 seInScope:
170 The in-scope part of Subst includes *all* in-scope TyVars and Ids
171 The elements of the set may have better IdInfo than the
172 occurrences of in-scope Ids, and (more important) they will
173 have a correctly-substituted type. So we use a lookup in this
174 set to replace occurrences
175
176 The Ids in the InScopeSet are replete with their Rules,
177 and as we gather info about the unfolding of an Id, we replace
178 it in the in-scope set.
179
180 The in-scope set is actually a mapping OutVar -> OutVar, and
181 in case expressions we sometimes bind
182
183 seIdSubst:
184 The substitution is *apply-once* only, because InIds and OutIds
185 can overlap.
186 For example, we generally omit mappings
187 a77 -> a77
188 from the substitution, when we decide not to clone a77, but it's quite
189 legitimate to put the mapping in the substitution anyway.
190
191 Furthermore, consider
192 let x = case k of I# x77 -> ... in
193 let y = case k of I# x77 -> ... in ...
194 and suppose the body is strict in both x and y. Then the simplifier
195 will pull the first (case k) to the top; so the second (case k) will
196 cancel out, mapping x77 to, well, x77! But one is an in-Id and the
197 other is an out-Id.
198
199 Of course, the substitution *must* applied! Things in its domain
200 simply aren't necessarily bound in the result.
201
202 * substId adds a binding (DoneId new_id) to the substitution if
203 the Id's unique has changed
204
205 Note, though that the substitution isn't necessarily extended
206 if the type of the Id changes. Why not? Because of the next point:
207
208 * We *always, always* finish by looking up in the in-scope set
209 any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
210 Reason: so that we never finish up with a "old" Id in the result.
211 An old Id might point to an old unfolding and so on... which gives a space
212 leak.
213
214 [The DoneEx and DoneVar hits map to "new" stuff.]
215
216 * It follows that substExpr must not do a no-op if the substitution is empty.
217 substType is free to do so, however.
218
219 * When we come to a let-binding (say) we generate new IdInfo, including an
220 unfolding, attach it to the binder, and add this newly adorned binder to
221 the in-scope set. So all subsequent occurrences of the binder will get
222 mapped to the full-adorned binder, which is also the one put in the
223 binding site.
224
225 * The in-scope "set" usually maps x->x; we use it simply for its domain.
226 But sometimes we have two in-scope Ids that are synomyms, and should
227 map to the same target: x->x, y->x. Notably:
228 case y of x { ... }
229 That's why the "set" is actually a VarEnv Var
230
231 Note [Join arity in SimplIdSubst]
232 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
233 We have to remember which incoming variables are join points: the occurrences
234 may not be marked correctly yet, and we're in change of propagating the change if
235 OccurAnal makes something a join point).
236
237 Normally the in-scope set is where we keep the latest information, but
238 the in-scope set tracks only OutVars; if a binding is unconditionally
239 inlined (via DoneEx), it never makes it into the in-scope set, and we
240 need to know at the occurrence site that the variable is a join point
241 so that we know to drop the context. Thus we remember which join
242 points we're substituting. -}
243
244 mkSimplEnv :: SimplifierMode -> SimplEnv
245 mkSimplEnv mode
246 = SimplEnv { seMode = mode
247 , seInScope = init_in_scope
248 , seLetFloats = emptyFloats
249 , seJoinFloats = emptyJoinFloats
250 , seTvSubst = emptyVarEnv
251 , seCvSubst = emptyVarEnv
252 , seIdSubst = emptyVarEnv }
253 -- The top level "enclosing CC" is "SUBSUMED".
254
255 init_in_scope :: InScopeSet
256 init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy))
257 -- See Note [WildCard binders]
258
259 {-
260 Note [WildCard binders]
261 ~~~~~~~~~~~~~~~~~~~~~~~
262 The program to be simplified may have wild binders
263 case e of wild { p -> ... }
264 We want to *rename* them away, so that there are no
265 occurrences of 'wild-id' (with wildCardKey). The easy
266 way to do that is to start of with a representative
267 Id in the in-scope set
268
269 There can be *occurrences* of wild-id. For example,
270 MkCore.mkCoreApp transforms
271 e (a /# b) --> case (a /# b) of wild { DEFAULT -> e wild }
272 This is ok provided 'wild' isn't free in 'e', and that's the delicate
273 thing. Generally, you want to run the simplifier to get rid of the
274 wild-ids before doing much else.
275
276 It's a very dark corner of GHC. Maybe it should be cleaned up.
277 -}
278
279 getMode :: SimplEnv -> SimplifierMode
280 getMode env = seMode env
281
282 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
283 setMode mode env = env { seMode = mode }
284
285 updMode :: (SimplifierMode -> SimplifierMode) -> SimplEnv -> SimplEnv
286 updMode upd env = env { seMode = upd (seMode env) }
287
288 ---------------------
289 extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
290 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
291 = ASSERT2( isId var && not (isCoVar var), ppr var )
292 env { seIdSubst = extendVarEnv subst var res }
293
294 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
295 extendTvSubst env@(SimplEnv {seTvSubst = tsubst}) var res
296 = ASSERT( isTyVar var )
297 env {seTvSubst = extendVarEnv tsubst var res}
298
299 extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv
300 extendCvSubst env@(SimplEnv {seCvSubst = csubst}) var co
301 = ASSERT( isCoVar var )
302 env {seCvSubst = extendVarEnv csubst var co}
303
304 ---------------------
305 getInScope :: SimplEnv -> InScopeSet
306 getInScope env = seInScope env
307
308 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
309 setInScopeSet env in_scope = env {seInScope = in_scope}
310
311 setInScopeAndZapFloats :: SimplEnv -> SimplEnv -> SimplEnv
312 -- Set the in-scope set, and *zap* the floats
313 setInScopeAndZapFloats env env_with_scope
314 = env { seInScope = seInScope env_with_scope,
315 seLetFloats = emptyFloats,
316 seJoinFloats = emptyJoinFloats }
317
318 setFloats :: SimplEnv -> SimplEnv -> SimplEnv
319 -- Set the in-scope set *and* the floats
320 setFloats env env_with_floats
321 = env { seInScope = seInScope env_with_floats,
322 seLetFloats = seLetFloats env_with_floats,
323 seJoinFloats = seJoinFloats env_with_floats }
324
325 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
326 -- The new Ids are guaranteed to be freshly allocated
327 addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
328 = env { seInScope = in_scope `extendInScopeSetList` vs,
329 seIdSubst = id_subst `delVarEnvList` vs }
330 -- Why delete? Consider
331 -- let x = a*b in (x, \x -> x+3)
332 -- We add [x |-> a*b] to the substitution, but we must
333 -- _delete_ it from the substitution when going inside
334 -- the (\x -> ...)!
335
336 modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv
337 -- The variable should already be in scope, but
338 -- replace the existing version with this new one
339 -- which has more information
340 modifyInScope env@(SimplEnv {seInScope = in_scope}) v
341 = env {seInScope = extendInScopeSet in_scope v}
342
343 ---------------------
344 zapSubstEnv :: SimplEnv -> SimplEnv
345 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
346
347 setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv
348 setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }
349
350 mkContEx :: SimplEnv -> InExpr -> SimplSR
351 mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e
352
353 {-
354 ************************************************************************
355 * *
356 \subsection{Floats}
357 * *
358 ************************************************************************
359
360 Note [Simplifier floats]
361 ~~~~~~~~~~~~~~~~~~~~~~~~~
362 The Floats is a bunch of bindings, classified by a FloatFlag.
363
364 * All of them satisfy the let/app invariant
365
366 Examples
367
368 NonRec x (y:ys) FltLifted
369 Rec [(x,rhs)] FltLifted
370
371 NonRec x* (p:q) FltOKSpec -- RHS is WHNF. Question: why not FltLifted?
372 NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n
373
374 NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge
375
376 Can't happen:
377 NonRec x# (a /# b) -- Might fail; does not satisfy let/app
378 NonRec x# (f y) -- Might diverge; does not satisfy let/app
379 -}
380
381 data Floats = Floats (OrdList OutBind) FloatFlag
382 -- See Note [Simplifier floats]
383
384 type JoinFloat = OutBind
385 type JoinFloats = OrdList JoinFloat
386
387 data FloatFlag
388 = FltLifted -- All bindings are lifted and lazy *or*
389 -- consist of a single primitive string literal
390 -- Hence ok to float to top level, or recursive
391
392 | FltOkSpec -- All bindings are FltLifted *or*
393 -- strict (perhaps because unlifted,
394 -- perhaps because of a strict binder),
395 -- *and* ok-for-speculation
396 -- Hence ok to float out of the RHS
397 -- of a lazy non-recursive let binding
398 -- (but not to top level, or into a rec group)
399
400 | FltCareful -- At least one binding is strict (or unlifted)
401 -- and not guaranteed cheap
402 -- Do not float these bindings out of a lazy let
403
404 instance Outputable Floats where
405 ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds)
406
407 instance Outputable FloatFlag where
408 ppr FltLifted = text "FltLifted"
409 ppr FltOkSpec = text "FltOkSpec"
410 ppr FltCareful = text "FltCareful"
411
412 andFF :: FloatFlag -> FloatFlag -> FloatFlag
413 andFF FltCareful _ = FltCareful
414 andFF FltOkSpec FltCareful = FltCareful
415 andFF FltOkSpec _ = FltOkSpec
416 andFF FltLifted flt = flt
417
418 doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
419 -- If you change this function look also at FloatIn.noFloatFromRhs
420 doFloatFromRhs lvl rec str rhs (SimplEnv {seLetFloats = Floats fs ff})
421 = not (isNilOL fs) && want_to_float && can_float
422 where
423 want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs
424 -- See Note [Float when cheap or expandable]
425 can_float = case ff of
426 FltLifted -> True
427 FltOkSpec -> isNotTopLevel lvl && isNonRec rec
428 FltCareful -> isNotTopLevel lvl && isNonRec rec && str
429
430 {-
431 Note [Float when cheap or expandable]
432 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
433 We want to float a let from a let if the residual RHS is
434 a) cheap, such as (\x. blah)
435 b) expandable, such as (f b) if f is CONLIKE
436 But there are
437 - cheap things that are not expandable (eg \x. expensive)
438 - expandable things that are not cheap (eg (f b) where b is CONLIKE)
439 so we must take the 'or' of the two.
440 -}
441
442 emptyFloats :: Floats
443 emptyFloats = Floats nilOL FltLifted
444
445 emptyJoinFloats :: JoinFloats
446 emptyJoinFloats = nilOL
447
448 unitFloat :: OutBind -> Floats
449 -- This key function constructs a singleton float with the right form
450 unitFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind))
451 Floats (unitOL bind) (flag bind)
452 where
453 flag (Rec {}) = FltLifted
454 flag (NonRec bndr rhs)
455 | not (isStrictId bndr) = FltLifted
456 | exprIsLiteralString rhs = FltLifted
457 -- String literals can be floated freely.
458 -- See Note [CoreSyn top-level string ltierals] in CoreSyn.
459 | exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF)
460 | otherwise = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr )
461 FltCareful
462 -- Unlifted binders can only be let-bound if exprOkForSpeculation holds
463
464 unitJoinFloat :: OutBind -> JoinFloats
465 unitJoinFloat bind = ASSERT(all isJoinId (bindersOf bind))
466 unitOL bind
467
468 addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv
469 -- Add a non-recursive binding and extend the in-scope set
470 -- The latter is important; the binder may already be in the
471 -- in-scope set (although it might also have been created with newId)
472 -- but it may now have more IdInfo
473 addNonRec env@(SimplEnv { seLetFloats = floats
474 , seJoinFloats = jfloats
475 , seInScope = in_scope })
476 id rhs
477 | isJoinId id -- This test incidentally forces the Id, and hence
478 -- its IdInfo, and hence any inner substitutions
479 = env { seInScope = in_scope'
480 , seLetFloats = floats
481 , seJoinFloats = jfloats' }
482 | otherwise
483 = env { seInScope = in_scope'
484 , seLetFloats = floats'
485 , seJoinFloats = jfloats }
486 where
487 bind = NonRec id rhs
488 in_scope' = extendInScopeSet in_scope id
489 floats' = floats `addFlts` unitFloat bind
490 jfloats' = jfloats `addJoinFlts` unitJoinFloat bind
491
492 extendFloats :: SimplEnv -> OutBind -> SimplEnv
493 -- Add this binding to the floats, and extend the in-scope env too
494 extendFloats env@(SimplEnv { seLetFloats = floats
495 , seJoinFloats = jfloats
496 , seInScope = in_scope })
497 bind
498 | isJoinBind bind
499 = env { seInScope = in_scope'
500 , seLetFloats = floats
501 , seJoinFloats = jfloats' }
502 | otherwise
503 = env { seInScope = in_scope'
504 , seLetFloats = floats'
505 , seJoinFloats = jfloats }
506 where
507 bndrs = bindersOf bind
508
509 in_scope' = extendInScopeSetList in_scope bndrs
510 floats' = floats `addFlts` unitFloat bind
511 jfloats' = jfloats `addJoinFlts` unitJoinFloat bind
512
513 addLetFloats :: SimplEnv -> SimplEnv -> SimplEnv
514 -- Add the let-floats for env2 to env1;
515 -- *plus* the in-scope set for env2, which is bigger
516 -- than that for env1
517 addLetFloats env1 env2
518 = env1 { seLetFloats = seLetFloats env1 `addFlts` seLetFloats env2
519 , seInScope = seInScope env2 }
520
521 addFloats :: SimplEnv -> SimplEnv -> SimplEnv
522 -- Add both let-floats and join-floats for env2 to env1;
523 -- *plus* the in-scope set for env2, which is bigger
524 -- than that for env1
525 addFloats env1 env2
526 = env1 { seLetFloats = seLetFloats env1 `addFlts` seLetFloats env2
527 , seJoinFloats = seJoinFloats env1 `addJoinFlts` seJoinFloats env2
528 , seInScope = seInScope env2 }
529
530 addFlts :: Floats -> Floats -> Floats
531 addFlts (Floats bs1 l1) (Floats bs2 l2)
532 = Floats (bs1 `appOL` bs2) (l1 `andFF` l2)
533
534 addJoinFlts :: JoinFloats -> JoinFloats -> JoinFloats
535 addJoinFlts = appOL
536
537 zapFloats :: SimplEnv -> SimplEnv
538 zapFloats env = env { seLetFloats = emptyFloats
539 , seJoinFloats = emptyJoinFloats }
540
541 zapJoinFloats :: SimplEnv -> SimplEnv
542 zapJoinFloats env = env { seJoinFloats = emptyJoinFloats }
543
544 addJoinFloats :: SimplEnv -> JoinFloats -> SimplEnv
545 addJoinFloats env@(SimplEnv { seJoinFloats = fb1 }) fb2
546 = env { seJoinFloats = fb1 `addJoinFlts` fb2 }
547
548 addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv
549 -- Flattens the floats from env2 into a single Rec group,
550 -- prepends the floats from env1, and puts the result back in env2
551 -- This is all very specific to the way recursive bindings are
552 -- handled; see Simplify.simplRecBind
553 addRecFloats env1 env2@(SimplEnv {seLetFloats = Floats bs ff
554 ,seJoinFloats = jbs })
555 = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )
556 env2 {seLetFloats = seLetFloats env1 `addFlts` floats'
557 ,seJoinFloats = seJoinFloats env1 `addJoinFlts` jfloats'}
558 where
559 floats' | isNilOL bs = emptyFloats
560 | otherwise = unitFloat (Rec (flattenBinds (fromOL bs)))
561 jfloats' | isNilOL jbs = emptyJoinFloats
562 | otherwise = unitJoinFloat (Rec (flattenBinds (fromOL jbs)))
563
564 wrapFloats :: SimplEnv -> OutExpr -> OutExpr
565 -- Wrap the floats around the expression; they should all
566 -- satisfy the let/app invariant, so mkLets should do the job just fine
567 wrapFloats (SimplEnv { seLetFloats = Floats bs _
568 , seJoinFloats = jbs }) body
569 = foldrOL Let (wrapJoinFloats jbs body) bs
570 -- Note: Always safe to put the joins on the inside
571 -- since the values can't refer to them
572
573 wrapJoinFloatsX :: SimplEnv -> OutExpr -> (SimplEnv, OutExpr)
574 -- Wrap the seJoinFloats of the env around the expression,
575 -- and take them out of the SimplEnv
576 wrapJoinFloatsX env@(SimplEnv { seJoinFloats = jbs }) body
577 = (zapJoinFloats env, wrapJoinFloats jbs body)
578
579 wrapJoinFloats :: JoinFloats -> OutExpr -> OutExpr
580 -- Wrap the seJoinFloats of the env around the expression,
581 -- and take them out of the SimplEnv
582 wrapJoinFloats join_floats body
583 = foldrOL Let body join_floats
584
585 getFloatBinds :: SimplEnv -> [CoreBind]
586 getFloatBinds (SimplEnv {seLetFloats = Floats bs _, seJoinFloats = jbs})
587 = fromOL bs ++ fromOL jbs
588
589 isEmptyFloats :: SimplEnv -> Bool
590 isEmptyFloats env@(SimplEnv {seLetFloats = Floats bs _})
591 = isNilOL bs && isEmptyJoinFloats env
592
593 isEmptyJoinFloats :: SimplEnv -> Bool
594 isEmptyJoinFloats (SimplEnv {seJoinFloats = jbs})
595 = isNilOL jbs
596
597 mapFloats :: Floats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> Floats
598 mapFloats (Floats fs ff) fun
599 = Floats (mapOL app fs) ff
600 where
601 app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e'
602 app (Rec bs) = Rec (map fun bs)
603
604 {-
605 ************************************************************************
606 * *
607 Substitution of Vars
608 * *
609 ************************************************************************
610
611 Note [Global Ids in the substitution]
612 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
613 We look up even a global (eg imported) Id in the substitution. Consider
614 case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... }
615 The binder-swap in the occurrence analyser will add a binding
616 for a LocalId version of g (with the same unique though):
617 case X.g_34 of b { (a,b) -> let g_34 = b in
618 ... case X.g_34 of { (p,q) -> ...} ... }
619 So we want to look up the inner X.g_34 in the substitution, where we'll
620 find that it has been substituted by b. (Or conceivably cloned.)
621 -}
622
623 substId :: SimplEnv -> InId -> SimplSR
624 -- Returns DoneEx only on a non-Var expression
625 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
626 = case lookupVarEnv ids v of -- Note [Global Ids in the substitution]
627 Nothing -> DoneId (refineFromInScope in_scope v)
628 Just (DoneId v) -> DoneId (refineFromInScope in_scope v)
629 Just res -> res -- DoneEx non-var, or ContEx
630
631 -- Get the most up-to-date thing from the in-scope set
632 -- Even though it isn't in the substitution, it may be in
633 -- the in-scope set with better IdInfo
634
635 refineFromInScope :: InScopeSet -> Var -> Var
636 refineFromInScope in_scope v
637 | isLocalId v = case lookupInScope in_scope v of
638 Just v' -> v'
639 Nothing -> WARN( True, ppr v ) v -- This is an error!
640 | otherwise = v
641
642 lookupRecBndr :: SimplEnv -> InId -> OutId
643 -- Look up an Id which has been put into the envt by simplRecBndrs,
644 -- but where we have not yet done its RHS
645 lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
646 = case lookupVarEnv ids v of
647 Just (DoneId v) -> v
648 Just _ -> pprPanic "lookupRecBndr" (ppr v)
649 Nothing -> refineFromInScope in_scope v
650
651 {-
652 ************************************************************************
653 * *
654 \section{Substituting an Id binder}
655 * *
656 ************************************************************************
657
658
659 These functions are in the monad only so that they can be made strict via seq.
660 -}
661
662 simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
663 simplBinders env bndrs = mapAccumLM simplBinder env bndrs
664
665 -------------
666 simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
667 -- Used for lambda and case-bound variables
668 -- Clone Id if necessary, substitute type
669 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
670 -- The substitution is extended only if the variable is cloned, because
671 -- we *don't* need to use it to track occurrence info.
672 simplBinder env bndr
673 | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr
674 ; seqTyVar tv `seq` return (env', tv) }
675 | otherwise = do { let (env', id) = substIdBndr Nothing env bndr
676 ; seqId id `seq` return (env', id) }
677
678 ---------------
679 simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
680 -- A non-recursive let binder
681 simplNonRecBndr env id
682 = do { let (env1, id1) = substIdBndr Nothing env id
683 ; seqId id1 `seq` return (env1, id1) }
684
685 ---------------
686 simplNonRecJoinBndr :: SimplEnv -> OutType -> InBndr
687 -> SimplM (SimplEnv, OutBndr)
688 -- A non-recursive let binder for a join point; context being pushed inward may
689 -- change the type
690 simplNonRecJoinBndr env res_ty id
691 = do { let (env1, id1) = substIdBndr (Just res_ty) env id
692 ; seqId id1 `seq` return (env1, id1) }
693
694 ---------------
695 simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
696 -- Recursive let binders
697 simplRecBndrs env@(SimplEnv {}) ids
698 = ASSERT(all (not . isJoinId) ids)
699 do { let (env1, ids1) = mapAccumL (substIdBndr Nothing) env ids
700 ; seqIds ids1 `seq` return env1 }
701
702 ---------------
703 simplRecJoinBndrs :: SimplEnv -> OutType -> [InBndr] -> SimplM SimplEnv
704 -- Recursive let binders for join points; context being pushed inward may
705 -- change types
706 simplRecJoinBndrs env@(SimplEnv {}) res_ty ids
707 = ASSERT(all isJoinId ids)
708 do { let (env1, ids1) = mapAccumL (substIdBndr (Just res_ty)) env ids
709 ; seqIds ids1 `seq` return env1 }
710
711 ---------------
712 substIdBndr :: Maybe OutType -> SimplEnv -> InBndr -> (SimplEnv, OutBndr)
713 -- Might be a coercion variable
714 substIdBndr new_res_ty env bndr
715 | isCoVar bndr = substCoVarBndr env bndr
716 | otherwise = substNonCoVarIdBndr new_res_ty env bndr
717
718 ---------------
719 substNonCoVarIdBndr
720 :: Maybe OutType -- New result type, if a join binder
721 -> SimplEnv
722 -> InBndr -- Env and binder to transform
723 -> (SimplEnv, OutBndr)
724 -- Clone Id if necessary, substitute its type
725 -- Return an Id with its
726 -- * Type substituted
727 -- * UnfoldingInfo, Rules, WorkerInfo zapped
728 -- * Fragile OccInfo (only) zapped: Note [Robust OccInfo]
729 -- * Robust info, retained especially arity and demand info,
730 -- so that they are available to occurrences that occur in an
731 -- earlier binding of a letrec
732 --
733 -- For the robust info, see Note [Arity robustness]
734 --
735 -- Augment the substitution if the unique changed
736 -- Extend the in-scope set with the new Id
737 --
738 -- Similar to CoreSubst.substIdBndr, except that
739 -- the type of id_subst differs
740 -- all fragile info is zapped
741 substNonCoVarIdBndr new_res_ty
742 env@(SimplEnv { seInScope = in_scope
743 , seIdSubst = id_subst })
744 old_id
745 = ASSERT2( not (isCoVar old_id), ppr old_id )
746 (env { seInScope = in_scope `extendInScopeSet` new_id,
747 seIdSubst = new_subst }, new_id)
748 where
749 id1 = uniqAway in_scope old_id
750 id2 = substIdType env id1
751 id3 | Just res_ty <- new_res_ty
752 = id2 `setIdType` setJoinResTy (idJoinArity id2) res_ty (idType id2)
753 | otherwise
754 = id2
755 new_id = zapFragileIdInfo id3 -- Zaps rules, worker-info, unfolding
756 -- and fragile OccInfo
757
758 -- Extend the substitution if the unique has changed,
759 -- or there's some useful occurrence information
760 -- See the notes with substTyVarBndr for the delSubstEnv
761 new_subst | new_id /= old_id
762 = extendVarEnv id_subst old_id (DoneId new_id)
763 | otherwise
764 = delVarEnv id_subst old_id
765
766 ------------------------------------
767 seqTyVar :: TyVar -> ()
768 seqTyVar b = b `seq` ()
769
770 seqId :: Id -> ()
771 seqId id = seqType (idType id) `seq`
772 idInfo id `seq`
773 ()
774
775 seqIds :: [Id] -> ()
776 seqIds [] = ()
777 seqIds (id:ids) = seqId id `seq` seqIds ids
778
779 {-
780 Note [Arity robustness]
781 ~~~~~~~~~~~~~~~~~~~~~~~
782 We *do* transfer the arity from from the in_id of a let binding to the
783 out_id. This is important, so that the arity of an Id is visible in
784 its own RHS. For example:
785 f = \x. ....g (\y. f y)....
786 We can eta-reduce the arg to g, because f is a value. But that
787 needs to be visible.
788
789 This interacts with the 'state hack' too:
790 f :: Bool -> IO Int
791 f = \x. case x of
792 True -> f y
793 False -> \s -> ...
794 Can we eta-expand f? Only if we see that f has arity 1, and then we
795 take advantage of the 'state hack' on the result of
796 (f y) :: State# -> (State#, Int) to expand the arity one more.
797
798 There is a disadvantage though. Making the arity visible in the RHS
799 allows us to eta-reduce
800 f = \x -> f x
801 to
802 f = f
803 which technically is not sound. This is very much a corner case, so
804 I'm not worried about it. Another idea is to ensure that f's arity
805 never decreases; its arity started as 1, and we should never eta-reduce
806 below that.
807
808
809 Note [Robust OccInfo]
810 ~~~~~~~~~~~~~~~~~~~~~
811 It's important that we *do* retain the loop-breaker OccInfo, because
812 that's what stops the Id getting inlined infinitely, in the body of
813 the letrec.
814 -}
815
816
817 {-
818 ************************************************************************
819 * *
820 Impedance matching to type substitution
821 * *
822 ************************************************************************
823 -}
824
825 getTCvSubst :: SimplEnv -> TCvSubst
826 getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env
827 , seCvSubst = cv_env })
828 = mkTCvSubst in_scope (tv_env, cv_env)
829
830 substTy :: SimplEnv -> Type -> Type
831 substTy env ty = Type.substTy (getTCvSubst env) ty
832
833 substTyVar :: SimplEnv -> TyVar -> Type
834 substTyVar env tv = Type.substTyVar (getTCvSubst env) tv
835
836 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
837 substTyVarBndr env tv
838 = case Type.substTyVarBndr (getTCvSubst env) tv of
839 (TCvSubst in_scope' tv_env' cv_env', tv')
840 -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv')
841
842 substCoVar :: SimplEnv -> CoVar -> Coercion
843 substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv
844
845 substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar)
846 substCoVarBndr env cv
847 = case Coercion.substCoVarBndr (getTCvSubst env) cv of
848 (TCvSubst in_scope' tv_env' cv_env', cv')
849 -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv')
850
851 substCo :: SimplEnv -> Coercion -> Coercion
852 substCo env co = Coercion.substCo (getTCvSubst env) co
853
854 ------------------
855 substIdType :: SimplEnv -> Id -> Id
856 substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) id
857 | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env)
858 || noFreeVarsOfType old_ty
859 = id
860 | otherwise = Id.setIdType id (Type.substTy (TCvSubst in_scope tv_env cv_env) old_ty)
861 -- The tyCoVarsOfType is cheaper than it looks
862 -- because we cache the free tyvars of the type
863 -- in a Note in the id's type itself
864 where
865 old_ty = idType id