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