2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[Simplify]{The main module of the simplifier}
7 module Simplify ( simplTopBinds, simplExpr ) where
9 #include "HsVersions.h"
11 import CmdLineOpts ( switchIsOn, opt_SimplDoEtaReduction,
12 opt_SimplNoPreInlining, opt_DictsStrict,
16 import SimplUtils ( mkCase, transformRhs, findAlt,
17 simplBinder, simplBinders, simplIds, findDefault,
18 SimplCont(..), DupFlag(..), contResultType, analyseCont,
19 discardInline, countArgs, countValArgs, discardCont, contIsDupable
21 import Var ( mkSysTyVar, tyVarKind )
23 import Id ( Id, idType, idInfo, isDataConId,
24 idUnfolding, setIdUnfolding, isExportedId, isDeadBinder,
25 idDemandInfo, setIdInfo,
26 idOccInfo, setIdOccInfo,
27 zapLamIdInfo, idStrictness, setOneShotLambda,
29 import IdInfo ( OccInfo(..), StrictnessInfo(..), ArityInfo(..),
30 setArityInfo, setUnfoldingInfo,
33 import Demand ( Demand, isStrict, wwLazy )
34 import DataCon ( dataConNumInstArgs, dataConRepStrictness,
35 dataConSig, dataConArgTys
38 import CoreFVs ( mustHaveLocalBinding )
39 import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons,
42 import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsTrivial, exprIsConApp_maybe,
43 exprType, coreAltsType, exprArity, exprIsValue, idAppIsCheap,
44 exprOkForSpeculation, etaReduceExpr,
45 mkCoerce, mkSCC, mkInlineMe, mkAltExpr
47 import Rules ( lookupRule )
48 import CostCentre ( currentCCS )
49 import Type ( mkTyVarTys, isUnLiftedType, seqType,
50 mkFunTy, splitFunTy, splitTyConApp_maybe,
51 funResultTy, isDictTy, isDataType, applyTy
53 import Subst ( mkSubst, substTy, substExpr,
54 isInScope, lookupIdSubst, substIdInfo
56 import TyCon ( isDataTyCon, tyConDataConsIfAvailable,
59 import TysPrim ( realWorldStatePrimTy )
60 import PrelInfo ( realWorldPrimId )
61 import BasicTypes ( isLoopBreaker )
62 import Maybes ( maybeToBool )
63 import Util ( zipWithEqual, lengthExceeds )
68 The guts of the simplifier is in this module, but the driver
69 loop for the simplifier is in SimplCore.lhs.
72 %************************************************************************
76 %************************************************************************
79 simplTopBinds :: [InBind] -> SimplM [OutBind]
82 = -- Put all the top-level binders into scope at the start
83 -- so that if a transformation rule has unexpectedly brought
84 -- anything into scope, then we don't get a complaint about that.
85 -- It's rather as if the top-level binders were imported.
86 simplIds (bindersOfBinds binds) $ \ bndrs' ->
87 simpl_binds binds bndrs' `thenSmpl` \ (binds', _) ->
88 freeTick SimplifierDone `thenSmpl_`
92 -- We need to track the zapped top-level binders, because
93 -- they should have their fragile IdInfo zapped (notably occurrence info)
94 simpl_binds [] bs = ASSERT( null bs ) returnSmpl ([], panic "simplTopBinds corner")
95 simpl_binds (NonRec bndr rhs : binds) (b:bs) = simplLazyBind True bndr b rhs (simpl_binds binds bs)
96 simpl_binds (Rec pairs : binds) bs = simplRecBind True pairs (take n bs) (simpl_binds binds (drop n bs))
100 simplRecBind :: Bool -> [(InId, InExpr)] -> [OutId]
101 -> SimplM (OutStuff a) -> SimplM (OutStuff a)
102 simplRecBind top_lvl pairs bndrs' thing_inside
103 = go pairs bndrs' `thenSmpl` \ (binds', (binds'', res)) ->
104 returnSmpl (Rec (flattenBinds binds') : binds'', res)
106 go [] _ = thing_inside `thenSmpl` \ stuff ->
107 returnSmpl ([], stuff)
109 go ((bndr, rhs) : pairs) (bndr' : bndrs')
110 = simplLazyBind top_lvl bndr bndr' rhs (go pairs bndrs')
111 -- Don't float unboxed bindings out,
112 -- because we can't "rec" them
116 %************************************************************************
118 \subsection[Simplify-simplExpr]{The main function: simplExpr}
120 %************************************************************************
123 addLetBind :: OutId -> OutExpr -> SimplM (OutStuff a) -> SimplM (OutStuff a)
124 addLetBind bndr rhs thing_inside
125 = thing_inside `thenSmpl` \ (binds, res) ->
126 returnSmpl (NonRec bndr rhs : binds, res)
128 addLetBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
129 addLetBinds binds1 thing_inside
130 = thing_inside `thenSmpl` \ (binds2, res) ->
131 returnSmpl (binds1 ++ binds2, res)
133 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
134 -- Make a case expression instead of a let
135 -- These can arise either from the desugarer,
136 -- or from beta reductions: (\x.e) (x +# y)
138 addCaseBind bndr rhs thing_inside
139 = getInScope `thenSmpl` \ in_scope ->
140 thing_inside `thenSmpl` \ (floats, (_, body)) ->
141 returnSmpl ([], (in_scope, Case rhs bndr [(DEFAULT, [], mkLets floats body)]))
143 addNonRecBind bndr rhs thing_inside
144 -- Checks for needing a case binding
145 | needsCaseBinding (idType bndr) rhs = addCaseBind bndr rhs thing_inside
146 | otherwise = addLetBind bndr rhs thing_inside
149 The reason for this OutExprStuff stuff is that we want to float *after*
150 simplifying a RHS, not before. If we do so naively we get quadratic
151 behaviour as things float out.
153 To see why it's important to do it after, consider this (real) example:
167 a -- Can't inline a this round, cos it appears twice
171 Each of the ==> steps is a round of simplification. We'd save a
172 whole round if we float first. This can cascade. Consider
177 let f = let d1 = ..d.. in \y -> e
181 in \x -> ...(\y ->e)...
183 Only in this second round can the \y be applied, and it
184 might do the same again.
188 simplExpr :: CoreExpr -> SimplM CoreExpr
189 simplExpr expr = getSubst `thenSmpl` \ subst ->
190 simplExprC expr (Stop (substTy subst (exprType expr)))
191 -- The type in the Stop continuation is usually not used
192 -- It's only needed when discarding continuations after finding
193 -- a function that returns bottom.
194 -- Hence the lazy substitution
196 simplExprC :: CoreExpr -> SimplCont -> SimplM CoreExpr
197 -- Simplify an expression, given a continuation
199 simplExprC expr cont = simplExprF expr cont `thenSmpl` \ (floats, (_, body)) ->
200 returnSmpl (mkLets floats body)
202 simplExprF :: InExpr -> SimplCont -> SimplM OutExprStuff
203 -- Simplify an expression, returning floated binds
205 simplExprF (Var v) cont
208 simplExprF (Lit lit) (Select _ bndr alts se cont)
209 = knownCon (Lit lit) (LitAlt lit) [] bndr alts se cont
211 simplExprF (Lit lit) cont
212 = rebuild (Lit lit) cont
214 simplExprF (App fun arg) cont
215 = getSubstEnv `thenSmpl` \ se ->
216 simplExprF fun (ApplyTo NoDup arg se cont)
218 simplExprF (Case scrut bndr alts) cont
219 = getSubstEnv `thenSmpl` \ subst_env ->
220 getSwitchChecker `thenSmpl` \ chkr ->
221 if not (switchIsOn chkr NoCaseOfCase) then
222 -- Simplify the scrutinee with a Select continuation
223 simplExprF scrut (Select NoDup bndr alts subst_env cont)
226 -- If case-of-case is off, simply simplify the case expression
227 -- in a vanilla Stop context, and rebuild the result around it
228 simplExprC scrut (Select NoDup bndr alts subst_env
229 (Stop (contResultType cont))) `thenSmpl` \ case_expr' ->
230 rebuild case_expr' cont
233 simplExprF (Let (Rec pairs) body) cont
234 = simplIds (map fst pairs) $ \ bndrs' ->
235 -- NB: bndrs' don't have unfoldings or spec-envs
236 -- We add them as we go down, using simplPrags
238 simplRecBind False pairs bndrs' (simplExprF body cont)
240 simplExprF expr@(Lam _ _) cont = simplLam expr cont
242 simplExprF (Type ty) cont
243 = ASSERT( case cont of { Stop _ -> True; ArgOf _ _ _ -> True; other -> False } )
244 simplType ty `thenSmpl` \ ty' ->
245 rebuild (Type ty') cont
247 -- Comments about the Coerce case
248 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
249 -- It's worth checking for a coerce in the continuation,
250 -- in case we can cancel them. For example, in the initial form of a worker
251 -- we may find (coerce T (coerce S (\x.e))) y
252 -- and we'd like it to simplify to e[y/x] in one round of simplification
254 simplExprF (Note (Coerce to from) e) (CoerceIt outer_to cont)
255 = simplType from `thenSmpl` \ from' ->
256 if outer_to == from' then
257 -- The coerces cancel out
260 -- They don't cancel, but the inner one is redundant
261 simplExprF e (CoerceIt outer_to cont)
263 simplExprF (Note (Coerce to from) e) cont
264 = simplType to `thenSmpl` \ to' ->
265 simplExprF e (CoerceIt to' cont)
267 -- hack: we only distinguish subsumed cost centre stacks for the purposes of
268 -- inlining. All other CCCSs are mapped to currentCCS.
269 simplExprF (Note (SCC cc) e) cont
270 = setEnclosingCC currentCCS $
271 simplExpr e `thenSmpl` \ e ->
272 rebuild (mkSCC cc e) cont
274 simplExprF (Note InlineCall e) cont
275 = simplExprF e (InlinePlease cont)
277 -- Comments about the InlineMe case
278 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
279 -- Don't inline in the RHS of something that has an
280 -- inline pragma. But be careful that the InScopeEnv that
281 -- we return does still have inlinings on!
283 -- It really is important to switch off inlinings. This function
284 -- may be inlinined in other modules, so we don't want to remove
285 -- (by inlining) calls to functions that have specialisations, or
286 -- that may have transformation rules in an importing scope.
287 -- E.g. {-# INLINE f #-}
289 -- and suppose that g is strict *and* has specialisations.
290 -- If we inline g's wrapper, we deny f the chance of getting
291 -- the specialised version of g when f is inlined at some call site
292 -- (perhaps in some other module).
294 simplExprF (Note InlineMe e) cont
296 Stop _ -> -- Totally boring continuation
297 -- Don't inline inside an INLINE expression
298 switchOffInlining (simplExpr e) `thenSmpl` \ e' ->
299 rebuild (mkInlineMe e') cont
301 other -> -- Dissolve the InlineMe note if there's
302 -- an interesting context of any kind to combine with
303 -- (even a type application -- anything except Stop)
306 -- A non-recursive let is dealt with by simplBeta
307 simplExprF (Let (NonRec bndr rhs) body) cont
308 = getSubstEnv `thenSmpl` \ se ->
309 simplBeta bndr rhs se (contResultType cont) $
314 ---------------------------------
320 zap_it = mkLamBndrZapper fun cont
321 cont_ty = contResultType cont
323 -- Type-beta reduction
324 go (Lam bndr body) (ApplyTo _ (Type ty_arg) arg_se body_cont)
325 = ASSERT( isTyVar bndr )
326 tick (BetaReduction bndr) `thenSmpl_`
327 simplTyArg ty_arg arg_se `thenSmpl` \ ty_arg' ->
328 extendSubst bndr (DoneTy ty_arg')
331 -- Ordinary beta reduction
332 go (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
333 = tick (BetaReduction bndr) `thenSmpl_`
334 simplBeta zapped_bndr arg arg_se cont_ty
337 zapped_bndr = zap_it bndr
340 go lam@(Lam _ _) cont = completeLam [] lam cont
342 -- Exactly enough args
343 go expr cont = simplExprF expr cont
345 -- completeLam deals with the case where a lambda doesn't have an ApplyTo
347 -- We used to try for eta reduction here, but I found that this was
348 -- eta reducing things like
349 -- f = \x -> (coerce (\x -> e))
350 -- This made f's arity reduce, which is a bad thing, so I removed the
351 -- eta reduction at this point, and now do it only when binding
352 -- (at the call to postInlineUnconditionally)
354 completeLam acc (Lam bndr body) cont
355 = simplBinder bndr $ \ bndr' ->
356 completeLam (bndr':acc) body cont
358 completeLam acc body cont
359 = simplExpr body `thenSmpl` \ body' ->
360 rebuild (foldl (flip Lam) body' acc) cont
361 -- Remember, acc is the *reversed* binders
363 mkLamBndrZapper :: CoreExpr -- Function
364 -> SimplCont -- The context
365 -> Id -> Id -- Use this to zap the binders
366 mkLamBndrZapper fun cont
367 | n_args >= n_params fun = \b -> b -- Enough args
368 | otherwise = \b -> zapLamIdInfo b
370 -- NB: we count all the args incl type args
371 -- so we must count all the binders (incl type lambdas)
372 n_args = countArgs cont
374 n_params (Note _ e) = n_params e
375 n_params (Lam b e) = 1 + n_params e
376 n_params other = 0::Int
380 ---------------------------------
382 simplType :: InType -> SimplM OutType
384 = getSubst `thenSmpl` \ subst ->
386 new_ty = substTy subst ty
393 %************************************************************************
397 %************************************************************************
399 @simplBeta@ is used for non-recursive lets in expressions,
400 as well as true beta reduction.
402 Very similar to @simplLazyBind@, but not quite the same.
405 simplBeta :: InId -- Binder
406 -> InExpr -> SubstEnv -- Arg, with its subst-env
407 -> OutType -- Type of thing computed by the context
408 -> SimplM OutExprStuff -- The body
409 -> SimplM OutExprStuff
411 simplBeta bndr rhs rhs_se cont_ty thing_inside
413 = pprPanic "simplBeta" (ppr bndr <+> ppr rhs)
416 simplBeta bndr rhs rhs_se cont_ty thing_inside
417 | preInlineUnconditionally False {- not black listed -} bndr
418 = tick (PreInlineUnconditionally bndr) `thenSmpl_`
419 extendSubst bndr (ContEx rhs_se rhs) thing_inside
422 = -- Simplify the RHS
423 simplBinder bndr $ \ bndr' ->
424 simplValArg (idType bndr') (idDemandInfo bndr)
425 rhs rhs_se cont_ty $ \ rhs' ->
427 -- Now complete the binding and simplify the body
428 if needsCaseBinding (idType bndr') rhs' then
429 addCaseBind bndr' rhs' thing_inside
431 completeBinding bndr bndr' False False rhs' thing_inside
436 simplTyArg :: InType -> SubstEnv -> SimplM OutType
438 = getInScope `thenSmpl` \ in_scope ->
440 ty_arg' = substTy (mkSubst in_scope se) ty_arg
442 seqType ty_arg' `seq`
445 simplValArg :: OutType -- Type of arg
446 -> Demand -- Demand on the argument
447 -> InExpr -> SubstEnv
448 -> OutType -- Type of thing computed by the context
449 -> (OutExpr -> SimplM OutExprStuff)
450 -> SimplM OutExprStuff
452 simplValArg arg_ty demand arg arg_se cont_ty thing_inside
454 isUnLiftedType arg_ty ||
455 (opt_DictsStrict && isDictTy arg_ty && isDataType arg_ty)
456 -- Return true only for dictionary types where the dictionary
457 -- has more than one component (else we risk poking on the component
458 -- of a newtype dictionary)
459 = transformRhs arg `thenSmpl` \ t_arg ->
460 getEnv `thenSmpl` \ env ->
462 simplExprF t_arg (ArgOf NoDup cont_ty $ \ rhs' ->
463 setAllExceptInScope env $
464 etaFirst thing_inside rhs')
467 = simplRhs False {- Not top level -}
468 True {- OK to float unboxed -}
472 -- Do eta-reduction on the simplified RHS, if eta reduction is on
473 -- NB: etaFirst only eta-reduces if that results in something trivial
474 etaFirst | opt_SimplDoEtaReduction = \ thing_inside rhs -> thing_inside (etaCoreExprToTrivial rhs)
475 | otherwise = \ thing_inside rhs -> thing_inside rhs
477 -- Try for eta reduction, but *only* if we get all
478 -- the way to an exprIsTrivial expression. We don't want to remove
479 -- extra lambdas unless we are going to avoid allocating this thing altogether
480 etaCoreExprToTrivial rhs | exprIsTrivial rhs' = rhs'
483 rhs' = etaReduceExpr rhs
488 - deals only with Ids, not TyVars
489 - take an already-simplified RHS
491 It does *not* attempt to do let-to-case. Why? Because they are used for
494 (when let-to-case is impossible)
496 - many situations where the "rhs" is known to be a WHNF
497 (so let-to-case is inappropriate).
500 completeBinding :: InId -- Binder
501 -> OutId -- New binder
502 -> Bool -- True <=> top level
503 -> Bool -- True <=> black-listed; don't inline
504 -> OutExpr -- Simplified RHS
505 -> SimplM (OutStuff a) -- Thing inside
506 -> SimplM (OutStuff a)
508 completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside
509 | (case occ_info of -- This happens; for example, the case_bndr during case of
510 IAmDead -> True -- known constructor: case (a,b) of x { (p,q) -> ... }
511 other -> False) -- Here x isn't mentioned in the RHS, so we don't want to
512 -- create the (dead) let-binding let x = (a,b) in ...
515 | postInlineUnconditionally black_listed occ_info old_bndr new_rhs
516 -- Maybe we don't need a let-binding! Maybe we can just
517 -- inline it right away. Unlike the preInlineUnconditionally case
518 -- we are allowed to look at the RHS.
520 -- NB: a loop breaker never has postInlineUnconditionally True
521 -- and non-loop-breakers only have *forward* references
522 -- Hence, it's safe to discard the binding
524 -- NB: You might think that postInlineUnconditionally is an optimisation,
526 -- let x = f Bool in (x, y)
527 -- then because of the constructor, x will not be *inlined* in the pair,
528 -- so the trivial binding will stay. But in this postInlineUnconditionally
529 -- gag we use the *substitution* to substitute (f Bool) for x, and that *will*
531 = tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
532 extendSubst old_bndr (DoneEx new_rhs)
536 = getSubst `thenSmpl` \ subst ->
538 -- We make new IdInfo for the new binder by starting from the old binder,
539 -- doing appropriate substitutions.
540 -- Then we add arity and unfolding info to get the new binder
541 old_info = idInfo old_bndr
542 new_bndr_info = substIdInfo subst old_info (idInfo new_bndr)
543 `setArityInfo` ArityAtLeast (exprArity new_rhs)
545 -- Add the unfolding *only* for non-loop-breakers
546 -- Making loop breakers not have an unfolding at all
547 -- means that we can avoid tests in exprIsConApp, for example.
548 -- This is important: if exprIsConApp says 'yes' for a recursive
549 -- thing we can get into an infinite loop
550 info_w_unf | isLoopBreaker (occInfo old_info) = new_bndr_info
551 | otherwise = new_bndr_info `setUnfoldingInfo` mkUnfolding top_lvl new_rhs
553 final_id = new_bndr `setIdInfo` info_w_unf
555 -- These seqs forces the Id, and hence its IdInfo,
556 -- and hence any inner substitutions
558 addLetBind final_id new_rhs $
559 modifyInScope new_bndr final_id thing_inside
562 occ_info = idOccInfo old_bndr
566 %************************************************************************
568 \subsection{simplLazyBind}
570 %************************************************************************
572 simplLazyBind basically just simplifies the RHS of a let(rec).
573 It does two important optimisations though:
575 * It floats let(rec)s out of the RHS, even if they
576 are hidden by big lambdas
578 * It does eta expansion
581 simplLazyBind :: Bool -- True <=> top level
584 -> SimplM (OutStuff a) -- The body of the binding
585 -> SimplM (OutStuff a)
586 -- When called, the subst env is correct for the entire let-binding
587 -- and hence right for the RHS.
588 -- Also the binder has already been simplified, and hence is in scope
590 simplLazyBind top_lvl bndr bndr' rhs thing_inside
591 = getBlackList `thenSmpl` \ black_list_fn ->
593 black_listed = black_list_fn bndr
596 if preInlineUnconditionally black_listed bndr then
597 -- Inline unconditionally
598 tick (PreInlineUnconditionally bndr) `thenSmpl_`
599 getSubstEnv `thenSmpl` \ rhs_se ->
600 (extendSubst bndr (ContEx rhs_se rhs) thing_inside)
604 getSubstEnv `thenSmpl` \ rhs_se ->
605 simplRhs top_lvl False {- Not ok to float unboxed -}
607 rhs rhs_se $ \ rhs' ->
609 -- Now compete the binding and simplify the body
610 completeBinding bndr bndr' top_lvl black_listed rhs' thing_inside
616 simplRhs :: Bool -- True <=> Top level
617 -> Bool -- True <=> OK to float unboxed (speculative) bindings
618 -> OutType -> InExpr -> SubstEnv
619 -> (OutExpr -> SimplM (OutStuff a))
620 -> SimplM (OutStuff a)
621 simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside
622 = -- Swizzle the inner lets past the big lambda (if any)
623 -- and try eta expansion
624 transformRhs rhs `thenSmpl` \ t_rhs ->
627 setSubstEnv rhs_se (simplExprF t_rhs (Stop rhs_ty)) `thenSmpl` \ (floats, (in_scope', rhs')) ->
629 -- Float lets out of RHS
631 (floats_out, rhs'') | float_ubx = (floats, rhs')
632 | otherwise = splitFloats floats rhs'
634 if (top_lvl || wantToExpose 0 rhs') && -- Float lets if (a) we're at the top level
635 not (null floats_out) -- or (b) the resulting RHS is one we'd like to expose
637 tickLetFloat floats_out `thenSmpl_`
640 -- There's a subtlety here. There may be a binding (x* = e) in the
641 -- floats, where the '*' means 'will be demanded'. So is it safe
642 -- to float it out? Answer no, but it won't matter because
643 -- we only float if arg' is a WHNF,
644 -- and so there can't be any 'will be demanded' bindings in the floats.
646 WARN( any demanded_float floats_out, ppr floats_out )
647 addLetBinds floats_out $
648 setInScope in_scope' $
649 etaFirst thing_inside rhs''
650 -- in_scope' may be excessive, but that's OK;
651 -- it's a superset of what's in scope
653 -- Don't do the float
654 etaFirst thing_inside (mkLets floats rhs')
656 -- In a let-from-let float, we just tick once, arbitrarily
657 -- choosing the first floated binder to identify it
658 tickLetFloat (NonRec b r : fs) = tick (LetFloatFromLet b)
659 tickLetFloat (Rec ((b,r):prs) : fs) = tick (LetFloatFromLet b)
661 demanded_float (NonRec b r) = isStrict (idDemandInfo b) && not (isUnLiftedType (idType b))
662 -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them
663 demanded_float (Rec _) = False
665 -- Don't float any unlifted bindings out, because the context
666 -- is either a Rec group, or the top level, neither of which
667 -- can tolerate them.
668 splitFloats floats rhs
672 go (f:fs) | must_stay f = ([], mkLets (f:fs) rhs)
673 | otherwise = case go fs of
674 (out, rhs') -> (f:out, rhs')
676 must_stay (Rec prs) = False -- No unlifted bindings in here
677 must_stay (NonRec b r) = isUnLiftedType (idType b)
679 wantToExpose :: Int -> CoreExpr -> Bool
680 -- True for expressions that we'd like to expose at the
681 -- top level of an RHS. This includes partial applications
682 -- even if the args aren't cheap; the next pass will let-bind the
683 -- args and eta expand the partial application. So exprIsCheap won't do.
684 -- Here's the motivating example:
685 -- z = letrec g = \x y -> ...g... in g E
686 -- Even though E is a redex we'd like to float the letrec to give
687 -- g = \x y -> ...g...
689 -- Now the next use of SimplUtils.tryEtaExpansion will give
690 -- g = \x y -> ...g...
691 -- z = let v = E in \w -> g v w
692 -- And now we'll float the v to give
693 -- g = \x y -> ...g...
696 -- Which is what we want; chances are z will be inlined now.
698 -- This defn isn't quite like
699 -- exprIsCheap (it ignores non-cheap args)
700 -- exprIsValue (may not say True for a lone variable)
701 -- which is slightly weird
702 wantToExpose n (Var v) = idAppIsCheap v n
703 wantToExpose n (Lit l) = True
704 wantToExpose n (Lam _ e) = True
705 wantToExpose n (Note _ e) = wantToExpose n e
706 wantToExpose n (App f (Type _)) = wantToExpose n f
707 wantToExpose n (App f a) = wantToExpose (n+1) f
708 wantToExpose n other = False -- There won't be any lets
713 %************************************************************************
715 \subsection{Variables}
717 %************************************************************************
721 = getSubst `thenSmpl` \ subst ->
722 case lookupIdSubst subst var of
723 DoneEx e -> zapSubstEnv (simplExprF e cont)
724 ContEx env1 e -> setSubstEnv env1 (simplExprF e cont)
725 DoneId var1 occ -> WARN( not (isInScope var1 subst) && mustHaveLocalBinding var1,
726 text "simplVar:" <+> ppr var )
727 zapSubstEnv (completeCall var1 occ cont)
728 -- The template is already simplified, so don't re-substitute.
729 -- This is VITAL. Consider
731 -- let y = \z -> ...x... in
733 -- We'll clone the inner \x, adding x->x' in the id_subst
734 -- Then when we inline y, we must *not* replace x by x' in
735 -- the inlined copy!!
737 ---------------------------------------------------------
738 -- Dealing with a call
740 completeCall var occ cont
741 = getBlackList `thenSmpl` \ black_list_fn ->
742 getInScope `thenSmpl` \ in_scope ->
743 getSwitchChecker `thenSmpl` \ chkr ->
745 dont_use_rules = switchIsOn chkr DontApplyRules
746 no_case_of_case = switchIsOn chkr NoCaseOfCase
747 black_listed = black_list_fn var
749 (arg_infos, interesting_cont, inline_call) = analyseCont in_scope cont
750 discard_inline_cont | inline_call = discardInline cont
753 maybe_inline = callSiteInline black_listed inline_call occ
754 var arg_infos interesting_cont
756 -- First, look for an inlining
758 case maybe_inline of {
759 Just unfolding -- There is an inlining!
760 -> tick (UnfoldingDone var) `thenSmpl_`
761 simplExprF unfolding discard_inline_cont
764 Nothing -> -- No inlining!
766 -- Next, look for rules or specialisations that match
768 -- It's important to simplify the args first, because the rule-matcher
769 -- doesn't do substitution as it goes. We don't want to use subst_args
770 -- (defined in the 'where') because that throws away useful occurrence info,
771 -- and perhaps-very-important specialisations.
773 -- Some functions have specialisations *and* are strict; in this case,
774 -- we don't want to inline the wrapper of the non-specialised thing; better
775 -- to call the specialised thing instead.
776 -- But the black-listing mechanism means that inlining of the wrapper
777 -- won't occur for things that have specialisations till a later phase, so
778 -- it's ok to try for inlining first.
780 prepareArgs no_case_of_case var cont $ \ args' cont' ->
782 maybe_rule | dont_use_rules = Nothing
783 | otherwise = lookupRule in_scope var args'
786 Just (rule_name, rule_rhs) ->
787 tick (RuleFired rule_name) `thenSmpl_`
788 simplExprF rule_rhs cont' ;
790 Nothing -> -- No rules
793 rebuild (mkApps (Var var) args') cont'
799 ---------------------------------------------------------
800 -- Preparing arguments for a call
802 prepareArgs :: Bool -- True if the no-case-of-case switch is on
803 -> OutId -> SimplCont
804 -> ([OutExpr] -> SimplCont -> SimplM OutExprStuff)
805 -> SimplM OutExprStuff
806 prepareArgs no_case_of_case fun orig_cont thing_inside
807 = go [] demands orig_fun_ty orig_cont
809 orig_fun_ty = idType fun
810 is_data_con = isDataConId fun
812 (demands, result_bot)
813 | no_case_of_case = ([], False) -- Ignore strictness info if the no-case-of-case
814 -- flag is on. Strictness changes evaluation order
815 -- and that can change full laziness
817 = case idStrictness fun of
818 StrictnessInfo demands result_bot
819 | not (demands `lengthExceeds` countValArgs orig_cont)
820 -> -- Enough args, use the strictness given.
821 -- For bottoming functions we used to pretend that the arg
822 -- is lazy, so that we don't treat the arg as an
823 -- interesting context. This avoids substituting
824 -- top-level bindings for (say) strings into
825 -- calls to error. But now we are more careful about
826 -- inlining lone variables, so its ok (see SimplUtils.analyseCont)
827 (demands, result_bot)
829 other -> ([], False) -- Not enough args, or no strictness
831 -- Main game plan: loop through the arguments, simplifying
832 -- each of them in turn. We carry with us a list of demands,
833 -- and the type of the function-applied-to-earlier-args
835 -- We've run out of demands, and the result is now bottom
837 -- * case (error "hello") of { ... }
838 -- * (error "Hello") arg
839 -- * f (error "Hello") where f is strict
841 go acc [] fun_ty cont
843 = tick_case_of_error cont `thenSmpl_`
844 thing_inside (reverse acc) (discardCont cont)
847 go acc ds fun_ty (ApplyTo _ arg@(Type ty_arg) se cont)
848 = simplTyArg ty_arg se `thenSmpl` \ new_ty_arg ->
849 go (Type new_ty_arg : acc) ds (applyTy fun_ty new_ty_arg) cont
852 go acc ds fun_ty (ApplyTo _ val_arg se cont)
853 | not is_data_con -- Function isn't a data constructor
854 = simplValArg arg_ty dem val_arg se (contResultType cont) $ \ new_arg ->
855 go (new_arg : acc) ds' res_ty cont
857 | exprIsTrivial val_arg -- Function is a data contstructor, arg is trivial
858 = getInScope `thenSmpl` \ in_scope ->
860 new_arg = substExpr (mkSubst in_scope se) val_arg
861 -- Simplify the RHS with inlining switched off, so that
862 -- only absolutely essential things will happen.
863 -- If we don't do this, consider:
864 -- let x = +# p q in C {x}
865 -- Even though x get's an occurrence of 'many', its RHS looks cheap,
866 -- and there's a good chance it'll get inlined back into C's RHS. Urgh!
868 -- It's important that the substitution *does* deal with case-binder synonyms:
869 -- case x of y { True -> (x,1) }
870 -- Here we must be sure to substitute y for x when simplifying the args of the pair,
871 -- to increase the chances of being able to inline x. The substituter will do
872 -- that because the x->y mapping is held in the in-scope set.
874 -- It's not always the case that the new arg will be trivial
876 -- where, in one pass, f gets substituted by a constructor,
877 -- but x gets substituted by an expression (assume this is the
878 -- unique occurrence of x). It doesn't really matter -- it'll get
879 -- fixed up next pass. And it happens for dictionary construction,
880 -- which mentions the wrapper constructor to start with.
882 go (new_arg : acc) ds' res_ty cont
885 = simplValArg arg_ty dem val_arg se (contResultType cont) $ \ new_arg ->
886 -- A data constructor whose argument is now non-trivial;
887 -- so let/case bind it.
888 newId SLIT("a") arg_ty $ \ arg_id ->
889 addNonRecBind arg_id new_arg $
890 go (Var arg_id : acc) ds' res_ty cont
893 (arg_ty, res_ty) = splitFunTy fun_ty
894 (dem, ds') = case ds of
898 -- We're run out of arguments and the result ain't bottom
899 go acc ds fun_ty cont = thing_inside (reverse acc) cont
901 -- Boring: we must only record a tick if there was an interesting
902 -- continuation to discard. If not, we tick forever.
903 tick_case_of_error (Stop _) = returnSmpl ()
904 tick_case_of_error (CoerceIt _ (Stop _)) = returnSmpl ()
905 tick_case_of_error other = tick BottomFound
909 %************************************************************************
911 \subsection{Decisions about inlining}
913 %************************************************************************
915 NB: At one time I tried not pre/post-inlining top-level things,
916 even if they occur exactly once. Reason:
917 (a) some might appear as a function argument, so we simply
918 replace static allocation with dynamic allocation:
924 (b) some top level things might be black listed
926 HOWEVER, I found that some useful foldr/build fusion was lost (most
927 notably in spectral/hartel/parstof) because the foldr didn't see the build.
929 Doing the dynamic allocation isn't a big deal, in fact, but losing the
933 preInlineUnconditionally :: Bool {- Black listed -} -> InId -> Bool
934 -- Examines a bndr to see if it is used just once in a
935 -- completely safe way, so that it is safe to discard the binding
936 -- inline its RHS at the (unique) usage site, REGARDLESS of how
937 -- big the RHS might be. If this is the case we don't simplify
938 -- the RHS first, but just inline it un-simplified.
940 -- This is much better than first simplifying a perhaps-huge RHS
941 -- and then inlining and re-simplifying it.
943 -- NB: we don't even look at the RHS to see if it's trivial
946 -- where x is used many times, but this is the unique occurrence
947 -- of y. We should NOT inline x at all its uses, because then
948 -- we'd do the same for y -- aargh! So we must base this
949 -- pre-rhs-simplification decision solely on x's occurrences, not
952 -- Evne RHSs labelled InlineMe aren't caught here, because
953 -- there might be no benefit from inlining at the call site.
955 preInlineUnconditionally black_listed bndr
956 | black_listed || opt_SimplNoPreInlining = False
957 | otherwise = case idOccInfo bndr of
958 OneOcc in_lam once -> not in_lam && once
959 -- Not inside a lambda, one occurrence ==> safe!
963 postInlineUnconditionally :: Bool -- Black listed
965 -> InId -> OutExpr -> Bool
966 -- Examines a (bndr = rhs) binding, AFTER the rhs has been simplified
967 -- It returns True if it's ok to discard the binding and inline the
968 -- RHS at every use site.
970 -- NOTE: This isn't our last opportunity to inline.
971 -- We're at the binding site right now, and
972 -- we'll get another opportunity when we get to the ocurrence(s)
974 postInlineUnconditionally black_listed occ_info bndr rhs
975 | isExportedId bndr = False -- Don't inline these, ever
976 | black_listed = False
977 | isLoopBreaker occ_info = False
978 | otherwise = exprIsTrivial rhs -- Duplicating is free
979 -- Don't inline even WHNFs inside lambdas; doing so may
980 -- simply increase allocation when the function is called
981 -- This isn't the last chance; see NOTE above.
983 -- NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here
984 -- Why? Because we don't even want to inline them into the
985 -- RHS of constructor arguments. See NOTE above
987 -- NB: Even NOINLINEis ignored here: if the rhs is trivial
988 -- it's best to inline it anyway. We often get a=E; b=a
989 -- from desugaring, with both a and b marked NOINLINE.
994 %************************************************************************
996 \subsection{The main rebuilder}
998 %************************************************************************
1001 -------------------------------------------------------------------
1002 -- Finish rebuilding
1004 = getInScope `thenSmpl` \ in_scope ->
1005 returnSmpl ([], (in_scope, expr))
1007 ---------------------------------------------------------
1008 rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff
1010 -- Stop continuation
1011 rebuild expr (Stop _) = rebuild_done expr
1013 -- ArgOf continuation
1014 rebuild expr (ArgOf _ _ cont_fn) = cont_fn expr
1016 -- ApplyTo continuation
1017 rebuild expr cont@(ApplyTo _ arg se cont')
1018 = setSubstEnv se (simplExpr arg) `thenSmpl` \ arg' ->
1019 rebuild (App expr arg') cont'
1021 -- Coerce continuation
1022 rebuild expr (CoerceIt to_ty cont)
1023 = rebuild (mkCoerce to_ty (exprType expr) expr) cont
1025 -- Inline continuation
1026 rebuild expr (InlinePlease cont)
1027 = rebuild (Note InlineCall expr) cont
1029 rebuild scrut (Select _ bndr alts se cont)
1030 = rebuild_case scrut bndr alts se cont
1033 Case elimination [see the code above]
1035 Start with a simple situation:
1037 case x# of ===> e[x#/y#]
1040 (when x#, y# are of primitive type, of course). We can't (in general)
1041 do this for algebraic cases, because we might turn bottom into
1044 Actually, we generalise this idea to look for a case where we're
1045 scrutinising a variable, and we know that only the default case can
1050 other -> ...(case x of
1054 Here the inner case can be eliminated. This really only shows up in
1055 eliminating error-checking code.
1057 We also make sure that we deal with this very common case:
1062 Here we are using the case as a strict let; if x is used only once
1063 then we want to inline it. We have to be careful that this doesn't
1064 make the program terminate when it would have diverged before, so we
1066 - x is used strictly, or
1067 - e is already evaluated (it may so if e is a variable)
1069 Lastly, we generalise the transformation to handle this:
1075 We only do this for very cheaply compared r's (constructors, literals
1076 and variables). If pedantic bottoms is on, we only do it when the
1077 scrutinee is a PrimOp which can't fail.
1079 We do it *here*, looking at un-simplified alternatives, because we
1080 have to check that r doesn't mention the variables bound by the
1081 pattern in each alternative, so the binder-info is rather useful.
1083 So the case-elimination algorithm is:
1085 1. Eliminate alternatives which can't match
1087 2. Check whether all the remaining alternatives
1088 (a) do not mention in their rhs any of the variables bound in their pattern
1089 and (b) have equal rhss
1091 3. Check we can safely ditch the case:
1092 * PedanticBottoms is off,
1093 or * the scrutinee is an already-evaluated variable
1094 or * the scrutinee is a primop which is ok for speculation
1095 -- ie we want to preserve divide-by-zero errors, and
1096 -- calls to error itself!
1098 or * [Prim cases] the scrutinee is a primitive variable
1100 or * [Alg cases] the scrutinee is a variable and
1101 either * the rhs is the same variable
1102 (eg case x of C a b -> x ===> x)
1103 or * there is only one alternative, the default alternative,
1104 and the binder is used strictly in its scope.
1105 [NB this is helped by the "use default binder where
1106 possible" transformation; see below.]
1109 If so, then we can replace the case with one of the rhss.
1112 Blob of helper functions for the "case-of-something-else" situation.
1115 ---------------------------------------------------------
1116 -- Eliminate the case if possible
1118 rebuild_case scrut bndr alts se cont
1119 | maybeToBool maybe_con_app
1120 = knownCon scrut (DataAlt con) args bndr alts se cont
1122 | canEliminateCase scrut bndr alts
1123 = tick (CaseElim bndr) `thenSmpl_` (
1125 simplBinder bndr $ \ bndr' ->
1126 -- Remember to bind the case binder!
1127 completeBinding bndr bndr' False False scrut $
1128 simplExprF (head (rhssOfAlts alts)) cont)
1131 = complete_case scrut bndr alts se cont
1134 maybe_con_app = exprIsConApp_maybe scrut
1135 Just (con, args) = maybe_con_app
1137 -- See if we can get rid of the case altogether
1138 -- See the extensive notes on case-elimination above
1139 canEliminateCase scrut bndr alts
1140 = -- Check that the RHSs are all the same, and
1141 -- don't use the binders in the alternatives
1142 -- This test succeeds rapidly in the common case of
1143 -- a single DEFAULT alternative
1144 all (cheapEqExpr rhs1) other_rhss && all binders_unused alts
1146 -- Check that the scrutinee can be let-bound instead of case-bound
1147 && ( exprOkForSpeculation scrut
1148 -- OK not to evaluate it
1149 -- This includes things like (==# a# b#)::Bool
1150 -- so that we simplify
1151 -- case ==# a# b# of { True -> x; False -> x }
1154 -- This particular example shows up in default methods for
1155 -- comparision operations (e.g. in (>=) for Int.Int32)
1156 || exprIsValue scrut -- It's already evaluated
1157 || var_demanded_later scrut -- It'll be demanded later
1159 -- || not opt_SimplPedanticBottoms) -- Or we don't care!
1160 -- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
1161 -- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
1162 -- its argument: case x of { y -> dataToTag# y }
1163 -- Here we must *not* discard the case, because dataToTag# just fetches the tag from
1164 -- the info pointer. So we'll be pedantic all the time, and see if that gives any
1169 (rhs1:other_rhss) = rhssOfAlts alts
1170 binders_unused (_, bndrs, _) = all isDeadBinder bndrs
1172 var_demanded_later (Var v) = isStrict (idDemandInfo bndr) -- It's going to be evaluated later
1173 var_demanded_later other = False
1176 ---------------------------------------------------------
1177 -- Case of something else
1179 complete_case scrut case_bndr alts se cont
1180 = -- Prepare case alternatives
1181 prepareCaseAlts case_bndr (splitTyConApp_maybe (idType case_bndr))
1182 impossible_cons alts `thenSmpl` \ better_alts ->
1184 -- Set the new subst-env in place (before dealing with the case binder)
1187 -- Deal with the case binder, and prepare the continuation;
1188 -- The new subst_env is in place
1189 prepareCaseCont better_alts cont $ \ cont' ->
1192 -- Deal with variable scrutinee
1194 getSwitchChecker `thenSmpl` \ chkr ->
1195 simplCaseBinder (switchIsOn chkr NoCaseOfCase)
1196 scrut case_bndr $ \ case_bndr' zap_occ_info ->
1198 -- Deal with the case alternatives
1199 simplAlts zap_occ_info impossible_cons
1200 case_bndr' better_alts cont' `thenSmpl` \ alts' ->
1202 mkCase scrut case_bndr' alts'
1203 ) `thenSmpl` \ case_expr ->
1205 -- Notice that the simplBinder, prepareCaseCont, etc, do *not* scope
1206 -- over the rebuild_done; rebuild_done returns the in-scope set, and
1207 -- that should not include these chaps!
1208 rebuild_done case_expr
1210 impossible_cons = case scrut of
1211 Var v -> otherCons (idUnfolding v)
1215 knownCon :: OutExpr -> AltCon -> [OutExpr]
1216 -> InId -> [InAlt] -> SubstEnv -> SimplCont
1217 -> SimplM OutExprStuff
1219 knownCon expr con args bndr alts se cont
1220 = tick (KnownBranch bndr) `thenSmpl_`
1222 simplBinder bndr $ \ bndr' ->
1223 completeBinding bndr bndr' False False expr $
1224 -- Don't use completeBeta here. The expr might be
1225 -- an unboxed literal, like 3, or a variable
1226 -- whose unfolding is an unboxed literal... and
1227 -- completeBeta will just construct another case
1229 case findAlt con alts of
1230 (DEFAULT, bs, rhs) -> ASSERT( null bs )
1233 (LitAlt lit, bs, rhs) -> ASSERT( null bs )
1236 (DataAlt dc, bs, rhs) -> ASSERT( length bs == length real_args )
1237 extendSubstList bs (map mk real_args) $
1240 real_args = drop (dataConNumInstArgs dc) args
1241 mk (Type ty) = DoneTy ty
1242 mk other = DoneEx other
1247 prepareCaseCont :: [InAlt] -> SimplCont
1248 -> (SimplCont -> SimplM (OutStuff a))
1249 -> SimplM (OutStuff a)
1250 -- Polymorphic recursion here!
1252 prepareCaseCont [alt] cont thing_inside = thing_inside cont
1253 prepareCaseCont alts cont thing_inside = simplType (coreAltsType alts) `thenSmpl` \ alts_ty ->
1254 mkDupableCont alts_ty cont thing_inside
1255 -- At one time I passed in the un-simplified type, and simplified
1256 -- it only if we needed to construct a join binder, but that
1257 -- didn't work because we have to decompse function types
1258 -- (using funResultTy) in mkDupableCont.
1261 simplCaseBinder checks whether the scrutinee is a variable, v. If so,
1262 try to eliminate uses of v in the RHSs in favour of case_bndr; that
1263 way, there's a chance that v will now only be used once, and hence
1266 There is a time we *don't* want to do that, namely when
1267 -fno-case-of-case is on. This happens in the first simplifier pass,
1268 and enhances full laziness. Here's the bad case:
1269 f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
1270 If we eliminate the inner case, we trap it inside the I# v -> arm,
1271 which might prevent some full laziness happening. I've seen this
1272 in action in spectral/cichelli/Prog.hs:
1273 [(m,n) | m <- [1..max], n <- [1..max]]
1274 Hence the no_case_of_case argument
1277 If we do this, then we have to nuke any occurrence info (eg IAmDead)
1278 in the case binder, because the case-binder now effectively occurs
1279 whenever v does. AND we have to do the same for the pattern-bound
1282 (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
1284 Here, b and p are dead. But when we move the argment inside the first
1285 case RHS, and eliminate the second case, we get
1287 case x or { (a,b) -> a b }
1289 Urk! b is alive! Reason: the scrutinee was a variable, and case elimination
1290 happened. Hence the zap_occ_info function returned by simplCaseBinder
1293 simplCaseBinder no_case_of_case (Var v) case_bndr thing_inside
1294 | not no_case_of_case
1295 = simplBinder (zap case_bndr) $ \ case_bndr' ->
1296 modifyInScope v case_bndr' $
1297 -- We could extend the substitution instead, but it would be
1298 -- a hack because then the substitution wouldn't be idempotent
1299 -- any more (v is an OutId). And this just just as well.
1300 thing_inside case_bndr' zap
1302 zap b = b `setIdOccInfo` NoOccInfo
1304 simplCaseBinder add_eval_info other_scrut case_bndr thing_inside
1305 = simplBinder case_bndr $ \ case_bndr' ->
1306 thing_inside case_bndr' (\ bndr -> bndr) -- NoOp on bndr
1309 prepareCaseAlts does two things:
1311 1. Remove impossible alternatives
1313 2. If the DEFAULT alternative can match only one possible constructor,
1314 then make that constructor explicit.
1316 case e of x { DEFAULT -> rhs }
1318 case e of x { (a,b) -> rhs }
1319 where the type is a single constructor type. This gives better code
1320 when rhs also scrutinises x or e.
1323 prepareCaseAlts bndr (Just (tycon, inst_tys)) scrut_cons alts
1325 = case (findDefault filtered_alts, missing_cons) of
1327 ((alts_no_deflt, Just rhs), [data_con]) -- Just one missing constructor!
1328 -> tick (FillInCaseDefault bndr) `thenSmpl_`
1330 (_,_,ex_tyvars,_,_,_) = dataConSig data_con
1332 getUniquesSmpl (length ex_tyvars) `thenSmpl` \ tv_uniqs ->
1334 ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars
1335 mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
1336 arg_tys = dataConArgTys data_con
1337 (inst_tys ++ mkTyVarTys ex_tyvars')
1339 newIds SLIT("a") arg_tys $ \ bndrs ->
1340 returnSmpl ((DataAlt data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt)
1342 other -> returnSmpl filtered_alts
1344 -- Filter out alternatives that can't possibly match
1345 filtered_alts = case scrut_cons of
1347 other -> [alt | alt@(con,_,_) <- alts, not (con `elem` scrut_cons)]
1349 missing_cons = [data_con | data_con <- tyConDataConsIfAvailable tycon,
1350 not (data_con `elem` handled_data_cons)]
1351 handled_data_cons = [data_con | DataAlt data_con <- scrut_cons] ++
1352 [data_con | (DataAlt data_con, _, _) <- filtered_alts]
1355 prepareCaseAlts _ _ scrut_cons alts
1356 = returnSmpl alts -- Functions
1359 ----------------------
1360 simplAlts zap_occ_info scrut_cons case_bndr' alts cont'
1361 = mapSmpl simpl_alt alts
1363 inst_tys' = case splitTyConApp_maybe (idType case_bndr') of
1364 Just (tycon, inst_tys) -> inst_tys
1366 -- handled_cons is all the constructors that are dealt
1367 -- with, either by being impossible, or by there being an alternative
1368 handled_cons = scrut_cons ++ [con | (con,_,_) <- alts, con /= DEFAULT]
1370 simpl_alt (DEFAULT, _, rhs)
1371 = -- In the default case we record the constructors that the
1372 -- case-binder *can't* be.
1373 -- We take advantage of any OtherCon info in the case scrutinee
1374 modifyInScope case_bndr' (case_bndr' `setIdUnfolding` mkOtherCon handled_cons) $
1375 simplExprC rhs cont' `thenSmpl` \ rhs' ->
1376 returnSmpl (DEFAULT, [], rhs')
1378 simpl_alt (con, vs, rhs)
1379 = -- Deal with the pattern-bound variables
1380 -- Mark the ones that are in ! positions in the data constructor
1381 -- as certainly-evaluated.
1382 -- NB: it happens that simplBinders does *not* erase the OtherCon
1383 -- form of unfolding, so it's ok to add this info before
1384 -- doing simplBinders
1385 simplBinders (add_evals con vs) $ \ vs' ->
1387 -- Bind the case-binder to (con args)
1389 unfolding = mkUnfolding False (mkAltExpr con vs' inst_tys')
1391 modifyInScope case_bndr' (case_bndr' `setIdUnfolding` unfolding) $
1392 simplExprC rhs cont' `thenSmpl` \ rhs' ->
1393 returnSmpl (con, vs', rhs')
1396 -- add_evals records the evaluated-ness of the bound variables of
1397 -- a case pattern. This is *important*. Consider
1398 -- data T = T !Int !Int
1400 -- case x of { T a b -> T (a+1) b }
1402 -- We really must record that b is already evaluated so that we don't
1403 -- go and re-evaluate it when constructing the result.
1405 add_evals (DataAlt dc) vs = cat_evals vs (dataConRepStrictness dc)
1406 add_evals other_con vs = vs
1408 cat_evals [] [] = []
1409 cat_evals (v:vs) (str:strs)
1410 | isTyVar v = v : cat_evals vs (str:strs)
1411 | isStrict str = (v' `setIdUnfolding` mkOtherCon []) : cat_evals vs strs
1412 | otherwise = v' : cat_evals vs strs
1418 %************************************************************************
1420 \subsection{Duplicating continuations}
1422 %************************************************************************
1425 mkDupableCont :: OutType -- Type of the thing to be given to the continuation
1427 -> (SimplCont -> SimplM (OutStuff a))
1428 -> SimplM (OutStuff a)
1429 mkDupableCont ty cont thing_inside
1430 | contIsDupable cont
1433 mkDupableCont _ (CoerceIt ty cont) thing_inside
1434 = mkDupableCont ty cont $ \ cont' ->
1435 thing_inside (CoerceIt ty cont')
1437 mkDupableCont ty (InlinePlease cont) thing_inside
1438 = mkDupableCont ty cont $ \ cont' ->
1439 thing_inside (InlinePlease cont')
1441 mkDupableCont join_arg_ty (ArgOf _ cont_ty cont_fn) thing_inside
1442 = -- Build the RHS of the join point
1443 newId SLIT("a") join_arg_ty ( \ arg_id ->
1444 cont_fn (Var arg_id) `thenSmpl` \ (binds, (_, rhs)) ->
1445 returnSmpl (Lam (setOneShotLambda arg_id) (mkLets binds rhs))
1446 ) `thenSmpl` \ join_rhs ->
1448 -- Build the join Id and continuation
1449 -- We give it a "$j" name just so that for later amusement
1450 -- we can identify any join points that don't end up as let-no-escapes
1451 newId SLIT("$j") (exprType join_rhs) $ \ join_id ->
1453 new_cont = ArgOf OkToDup cont_ty
1454 (\arg' -> rebuild_done (App (Var join_id) arg'))
1457 tick (CaseOfCase join_id) `thenSmpl_`
1458 -- Want to tick here so that we go round again,
1459 -- and maybe copy or inline the code;
1460 -- not strictly CaseOf Case
1461 addLetBind join_id join_rhs (thing_inside new_cont)
1463 mkDupableCont ty (ApplyTo _ arg se cont) thing_inside
1464 = mkDupableCont (funResultTy ty) cont $ \ cont' ->
1465 setSubstEnv se (simplExpr arg) `thenSmpl` \ arg' ->
1466 if exprIsDupable arg' then
1467 thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont')
1469 newId SLIT("a") (exprType arg') $ \ bndr ->
1471 tick (CaseOfCase bndr) `thenSmpl_`
1472 -- Want to tick here so that we go round again,
1473 -- and maybe copy or inline the code;
1474 -- not strictly CaseOf Case
1476 addLetBind bndr arg' $
1477 -- But what if the arg should be case-bound? We can't use
1478 -- addNonRecBind here because its type is too specific.
1479 -- This has been this way for a long time, so I'll leave it,
1480 -- but I can't convince myself that it's right.
1482 thing_inside (ApplyTo OkToDup (Var bndr) emptySubstEnv cont')
1485 mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside
1486 = tick (CaseOfCase case_bndr) `thenSmpl_`
1488 simplBinder case_bndr $ \ case_bndr' ->
1489 prepareCaseCont alts cont $ \ cont' ->
1490 mapAndUnzipSmpl (mkDupableAlt case_bndr case_bndr' cont') alts `thenSmpl` \ (alt_binds_s, alts') ->
1491 returnSmpl (concat alt_binds_s, alts')
1492 ) `thenSmpl` \ (alt_binds, alts') ->
1494 extendInScopes [b | NonRec b _ <- alt_binds] $
1496 -- NB that the new alternatives, alts', are still InAlts, using the original
1497 -- binders. That means we can keep the case_bndr intact. This is important
1498 -- because another case-of-case might strike, and so we want to keep the
1499 -- info that the case_bndr is dead (if it is, which is often the case).
1500 -- This is VITAL when the type of case_bndr is an unboxed pair (often the
1501 -- case in I/O rich code. We aren't allowed a lambda bound
1502 -- arg of unboxed tuple type, and indeed such a case_bndr is always dead
1503 addLetBinds alt_binds $
1504 thing_inside (Select OkToDup case_bndr alts' se (Stop (contResultType cont)))
1506 mkDupableAlt :: InId -> OutId -> SimplCont -> InAlt -> SimplM (OutStuff InAlt)
1507 mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs)
1508 = simplBinders bndrs $ \ bndrs' ->
1509 simplExprC rhs cont `thenSmpl` \ rhs' ->
1511 if (case cont of { Stop _ -> exprIsDupable rhs'; other -> False}) then
1512 -- It is worth checking for a small RHS because otherwise we
1513 -- get extra let bindings that may cause an extra iteration of the simplifier to
1514 -- inline back in place. Quite often the rhs is just a variable or constructor.
1515 -- The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
1516 -- iterations because the version with the let bindings looked big, and so wasn't
1517 -- inlined, but after the join points had been inlined it looked smaller, and so
1520 -- But since the continuation is absorbed into the rhs, we only do this
1521 -- for a Stop continuation.
1523 -- NB: we have to check the size of rhs', not rhs.
1524 -- Duplicating a small InAlt might invalidate occurrence information
1525 -- However, if it *is* dupable, we return the *un* simplified alternative,
1526 -- because otherwise we'd need to pair it up with an empty subst-env.
1527 -- (Remember we must zap the subst-env before re-simplifying something).
1528 -- Rather than do this we simply agree to re-simplify the original (small) thing later.
1529 returnSmpl ([], alt)
1533 rhs_ty' = exprType rhs'
1534 (used_bndrs, used_bndrs')
1535 = unzip [pr | pr@(bndr,bndr') <- zip (case_bndr : bndrs)
1536 (case_bndr' : bndrs'),
1537 not (isDeadBinder bndr)]
1538 -- The new binders have lost their occurrence info,
1539 -- so we have to extract it from the old ones
1541 ( if null used_bndrs'
1542 -- If we try to lift a primitive-typed something out
1543 -- for let-binding-purposes, we will *caseify* it (!),
1544 -- with potentially-disastrous strictness results. So
1545 -- instead we turn it into a function: \v -> e
1546 -- where v::State# RealWorld#. The value passed to this function
1547 -- is realworld#, which generates (almost) no code.
1549 -- There's a slight infelicity here: we pass the overall
1550 -- case_bndr to all the join points if it's used in *any* RHS,
1551 -- because we don't know its usage in each RHS separately
1553 -- We used to say "&& isUnLiftedType rhs_ty'" here, but now
1554 -- we make the join point into a function whenever used_bndrs'
1555 -- is empty. This makes the join-point more CPR friendly.
1556 -- Consider: let j = if .. then I# 3 else I# 4
1557 -- in case .. of { A -> j; B -> j; C -> ... }
1559 -- Now CPR should not w/w j because it's a thunk, so
1560 -- that means that the enclosing function can't w/w either,
1561 -- which is a lose. Here's the example that happened in practice:
1562 -- kgmod :: Int -> Int -> Int
1563 -- kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
1567 then newId SLIT("w") realWorldStatePrimTy $ \ rw_id ->
1568 returnSmpl ([rw_id], [Var realWorldPrimId])
1570 returnSmpl (used_bndrs', map varToCoreExpr used_bndrs)
1572 `thenSmpl` \ (final_bndrs', final_args) ->
1574 -- See comment about "$j" name above
1575 newId SLIT("$j") (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr ->
1577 -- Notice that we make the lambdas into one-shot-lambdas. The
1578 -- join point is sure to be applied at most once, and doing so
1579 -- prevents the body of the join point being floated out by
1580 -- the full laziness pass
1581 returnSmpl ([NonRec join_bndr (mkLams (map setOneShotLambda final_bndrs') rhs')],
1582 (con, bndrs, mkApps (Var join_bndr) final_args))