2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[Simplify]{The main module of the simplifier}
7 module Simplify ( simplBind ) where
9 #include "HsVersions.h"
11 import CmdLineOpts ( switchIsOn, opt_SccProfilingOn, opt_PprStyle_Debug,
12 opt_NoPreInlining, opt_DictsStrict, opt_D_dump_inlinings,
16 import SimplUtils ( mkCase, etaCoreExpr, etaExpandCount, findAlt, mkRhsTyLam,
17 simplBinder, simplBinders, simplIds, findDefault
19 import Var ( TyVar, mkSysTyVar, tyVarKind )
22 import Id ( Id, idType,
23 getIdUnfolding, setIdUnfolding,
24 getIdSpecialisation, setIdSpecialisation,
25 getIdDemandInfo, setIdDemandInfo,
26 getIdArity, setIdArity,
28 setInlinePragma, getInlinePragma, idMustBeINLINEd,
31 import IdInfo ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..),
32 ArityInfo, atLeastArity, arityLowerBound, unknownArity
34 import Demand ( Demand, isStrict, wwLazy )
35 import Const ( isWHNFCon, conOkForAlt )
36 import ConFold ( tryPrimOp )
37 import PrimOp ( PrimOp, primOpStrictness )
38 import DataCon ( DataCon, dataConNumInstArgs, dataConStrictMarks, dataConSig, dataConArgTys )
39 import Const ( Con(..) )
40 import MagicUFs ( applyMagicUnfoldingFun )
41 import Name ( isExported, isLocallyDefined )
43 import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..),
44 mkUnfolding, smallEnoughToInline,
45 isEvaldUnfolding, unfoldAlways
47 import CoreUtils ( IdSubst, SubstCoreExpr(..),
48 cheapEqExpr, exprIsDupable, exprIsWHNF, exprIsTrivial,
49 coreExprType, coreAltsType, exprIsCheap, substExpr,
50 FormSummary(..), mkFormSummary, whnfOrBottom
52 import SpecEnv ( lookupSpecEnv, isEmptySpecEnv, substSpecEnv )
53 import CostCentre ( isSubsumedCCS, currentCCS, isEmptyCC )
54 import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType, fullSubstTy,
55 mkFunTy, splitFunTys, splitTyConApp_maybe, splitFunTy_maybe,
56 applyTy, applyTys, funResultTy, isDictTy, isDataType
58 import TyCon ( isDataTyCon, tyConDataCons, tyConClass_maybe, tyConArity, isDataTyCon )
59 import TysPrim ( realWorldStatePrimTy )
60 import PrelVals ( realWorldPrimId )
61 import BasicTypes ( StrictnessMark(..) )
62 import Maybes ( maybeToBool )
63 import Util ( zipWithEqual, stretchZipEqual )
69 The guts of the simplifier is in this module, but the driver
70 loop for the simplifier is in SimplPgm.lhs.
73 %************************************************************************
75 \subsection[Simplify-simplExpr]{The main function: simplExpr}
77 %************************************************************************
80 addBind :: CoreBind -> OutStuff a -> OutStuff a
81 addBind bind (binds, res) = (bind:binds, res)
83 addBinds :: [CoreBind] -> OutStuff a -> OutStuff a
84 addBinds [] stuff = stuff
85 addBinds binds1 (binds2, res) = (binds1++binds2, res)
88 The reason for this OutExprStuff stuff is that we want to float *after*
89 simplifying a RHS, not before. If we do so naively we get quadratic
90 behaviour as things float out.
92 To see why it's important to do it after, consider this (real) example:
106 a -- Can't inline a this round, cos it appears twice
110 Each of the ==> steps is a round of simplification. We'd save a
111 whole round if we float first. This can cascade. Consider
116 let f = let d1 = ..d.. in \y -> e
120 in \x -> ...(\y ->e)...
122 Only in this second round can the \y be applied, and it
123 might do the same again.
127 simplExpr :: CoreExpr -> SimplCont -> SimplM CoreExpr
128 simplExpr expr cont = simplExprB expr cont `thenSmpl` \ (binds, (_, body)) ->
129 returnSmpl (mkLetBinds binds body)
131 simplExprB :: InExpr -> SimplCont -> SimplM OutExprStuff
133 simplExprB (Note InlineCall (Var v)) cont
134 = simplVar True v cont
136 simplExprB (Var v) cont
137 = simplVar False v cont
139 simplExprB expr@(Con (PrimOp op) args) cont
140 = simplType (coreExprType expr) `thenSmpl` \ expr_ty ->
141 getInScope `thenSmpl` \ in_scope ->
142 getSubstEnv `thenSmpl` \ se ->
144 (val_arg_demands, _) = primOpStrictness op
146 -- Main game plan: loop through the arguments, simplifying
147 -- each of them with an ArgOf continuation. Getting the right
148 -- cont_ty in the ArgOf continuation is a bit of a nuisance.
149 go [] ds args' = rebuild_primop (reverse args')
150 go (arg:args) ds args'
151 | isTypeArg arg = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
152 go args ds (arg':args')
153 go (arg:args) (d:ds) args'
154 | not (isStrict d) = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
155 go args ds (arg':args')
156 | otherwise = setSubstEnv se (simplExprB arg (mk_cont args ds args'))
158 cont_ty = contResultType in_scope expr_ty cont
159 mk_cont args ds args' = ArgOf NoDup (\ arg' -> go args ds (arg':args')) cont_ty
161 go args val_arg_demands []
165 = -- Try the prim op simplification
166 -- It's really worth trying simplExpr again if it succeeds,
167 -- because you can find
168 -- case (eqChar# x 'a') of ...
170 -- case (case x of 'a' -> True; other -> False) of ...
171 case tryPrimOp op args' of
172 Just e' -> zapSubstEnv (simplExprB e' cont)
173 Nothing -> rebuild (Con (PrimOp op) args') cont
175 simplExprB (Con con@(DataCon _) args) cont
176 = simplConArgs args $ \ args' ->
177 rebuild (Con con args') cont
179 simplExprB expr@(Con con@(Literal _) args) cont
180 = ASSERT( null args )
183 simplExprB (App fun arg) cont
184 = getSubstEnv `thenSmpl` \ se ->
185 simplExprB fun (ApplyTo NoDup arg se cont)
187 simplExprB (Case scrut bndr alts) cont
188 = getSubstEnv `thenSmpl` \ se ->
189 simplExprB scrut (Select NoDup bndr alts se cont)
191 simplExprB (Note (Coerce to from) e) cont
192 | to == from = simplExprB e cont
193 | otherwise = getSubstEnv `thenSmpl` \ se ->
194 simplExprB e (CoerceIt NoDup to se cont)
196 -- hack: we only distinguish subsumed cost centre stacks for the purposes of
197 -- inlining. All other CCCSs are mapped to currentCCS.
198 simplExprB (Note (SCC cc) e) cont
199 = setEnclosingCC currentCCS $
200 simplExpr e Stop `thenSmpl` \ e ->
201 rebuild (mkNote (SCC cc) e) cont
203 simplExprB (Note note e) cont
204 = simplExpr e Stop `thenSmpl` \ e' ->
205 rebuild (mkNote note e') cont
207 -- A non-recursive let is dealt with by simplBeta
208 simplExprB (Let (NonRec bndr rhs) body) cont
209 = getSubstEnv `thenSmpl` \ se ->
210 simplBeta bndr rhs se body cont
212 simplExprB (Let (Rec pairs) body) cont
213 = simplRecBind pairs (simplExprB body cont)
215 -- Type-beta reduction
216 simplExprB expr@(Lam bndr body) cont@(ApplyTo _ (Type ty_arg) arg_se body_cont)
217 = ASSERT( isTyVar bndr )
218 tick BetaReduction `thenSmpl_`
219 setSubstEnv arg_se (simplType ty_arg) `thenSmpl` \ ty' ->
220 extendTySubst bndr ty' $
221 simplExprB body body_cont
223 -- Ordinary beta reduction
224 simplExprB expr@(Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
225 = tick BetaReduction `thenSmpl_`
226 simplBeta bndr' arg arg_se body body_cont
228 bndr' = zapLambdaBndr bndr body body_cont
230 simplExprB (Lam bndr body) cont
231 = simplBinder bndr $ \ bndr' ->
232 simplExpr body Stop `thenSmpl` \ body' ->
233 rebuild (Lam bndr' body') cont
235 simplExprB (Type ty) cont
236 = ASSERT( case cont of { Stop -> True; ArgOf _ _ _ -> True; other -> False } )
237 simplType ty `thenSmpl` \ ty' ->
238 rebuild (Type ty') cont
242 ---------------------------------
244 simplArg :: InArg -> SimplM OutArg
245 simplArg arg = simplExpr arg Stop
248 ---------------------------------
249 simplConArgs makes sure that the arguments all end up being atomic.
250 That means it may generate some Lets, hence the
253 simplConArgs :: [InArg] -> ([OutArg] -> SimplM OutExprStuff) -> SimplM OutExprStuff
254 simplConArgs [] thing_inside
257 simplConArgs (arg:args) thing_inside
258 = switchOffInlining (simplArg arg) `thenSmpl` \ arg' ->
259 -- Simplify the RHS with inlining switched off, so that
260 -- only absolutely essential things will happen.
262 simplConArgs args $ \ args' ->
264 -- If the argument ain't trivial, then let-bind it
265 if exprIsTrivial arg' then
266 thing_inside (arg' : args')
268 newId (coreExprType arg') $ \ arg_id ->
269 thing_inside (Var arg_id : args') `thenSmpl` \ res ->
270 returnSmpl (addBind (NonRec arg_id arg') res)
274 ---------------------------------
276 simplType :: InType -> SimplM OutType
278 = getTyEnv `thenSmpl` \ (ty_subst, in_scope) ->
279 returnSmpl (fullSubstTy ty_subst in_scope ty)
284 -- Find out whether the lambda is saturated,
285 -- if not zap the over-optimistic info in the binder
287 zapLambdaBndr bndr body body_cont
288 | isTyVar bndr || safe_info || definitely_saturated 20 body body_cont
289 -- The "20" is to catch pathalogical cases with bazillions of arguments
290 -- because we are using an n**2 algorithm here
291 = bndr -- No need to zap
293 = setInlinePragma (setIdDemandInfo bndr wwLazy)
297 inline_prag = getInlinePragma bndr
298 demand = getIdDemandInfo bndr
300 safe_info = is_safe_inline_prag && not (isStrict demand)
302 is_safe_inline_prag = case inline_prag of
303 ICanSafelyBeINLINEd StrictOcc nalts -> False
304 ICanSafelyBeINLINEd LazyOcc nalts -> False
307 safe_inline_prag = case inline_prag of
308 ICanSafelyBeINLINEd _ nalts
309 -> ICanSafelyBeINLINEd InsideLam nalts
312 definitely_saturated :: Int -> CoreExpr -> SimplCont -> Bool
313 definitely_saturated 0 _ _ = False -- Too expensive to find out
314 definitely_saturated n (Lam _ body) (ApplyTo _ _ _ cont) = definitely_saturated (n-1) body cont
315 definitely_saturated n (Lam _ _) other_cont = False
316 definitely_saturated n _ _ = True
319 %************************************************************************
321 \subsection{Variables}
323 %************************************************************************
328 simplVar inline_call var cont
329 = getValEnv `thenSmpl` \ (id_subst, in_scope) ->
330 case lookupVarEnv id_subst var of
332 -> zapSubstEnv (simplExprB e cont)
334 Just (SubstMe e ty_subst id_subst)
335 -> setSubstEnv (ty_subst, id_subst) (simplExprB e cont)
338 var' = case lookupVarSet in_scope var of
342 if isLocallyDefined var && not (idMustBeINLINEd var) then
344 pprTrace "simplVar:" (ppr var) var
349 getSwitchChecker `thenSmpl` \ sw_chkr ->
350 completeVar sw_chkr in_scope inline_call var' cont
352 completeVar sw_chkr in_scope inline_call var cont
354 {- MAGIC UNFOLDINGS NOT USED NOW
355 | maybeToBool maybe_magic_result
356 = tick MagicUnfold `thenSmpl_`
359 -- Look for existing specialisations before trying inlining
360 | maybeToBool maybe_specialisation
361 = tick SpecialisationDone `thenSmpl_`
362 setSubstEnv (spec_bindings, emptyVarEnv) (
363 -- See note below about zapping the substitution here
365 simplExprB spec_template remaining_cont
368 -- Don't actually inline the scrutinee when we see
369 -- case x of y { .... }
370 -- and x has unfolding (C a b). Why not? Because
371 -- we get a silly binding y = C a b. If we don't
372 -- inline knownCon can directly substitute x for y instead.
373 | has_unfolding && var_is_case_scrutinee && unfolding_is_constr
374 = knownCon (Var var) con con_args cont
376 -- Look for an unfolding. There's a binding for the
377 -- thing, but perhaps we want to inline it anyway
378 | has_unfolding && (inline_call || ok_to_inline)
379 = getEnclosingCC `thenSmpl` \ encl_cc ->
380 if must_be_unfolded || costCentreOk encl_cc (coreExprCc unf_template)
383 tickUnfold var `thenSmpl_` (
386 -- The template is already simplified, so don't re-substitute.
387 -- This is VITAL. Consider
389 -- let y = \z -> ...x... in
391 -- We'll clone the inner \x, adding x->x' in the id_subst
392 -- Then when we inline y, we must *not* replace x by x' in
393 -- the inlined copy!!
395 if opt_D_dump_inlinings then
396 pprTrace "Inlining:" (ppr var <+> ppr unf_template) $
397 simplExprB unf_template cont
400 simplExprB unf_template cont
404 pprTrace "Inlining disallowed due to CC:\n" (ppr encl_cc <+> ppr unf_template <+> ppr (coreExprCc unf_template)) $
406 -- Can't unfold because of bad cost centre
407 rebuild (Var var) cont
409 | inline_call -- There was an InlineCall note, but we didn't inline!
410 = rebuild (Note InlineCall (Var var)) cont
413 = rebuild (Var var) cont
416 unfolding = getIdUnfolding var
418 {- MAGIC UNFOLDINGS NOT USED CURRENTLY
419 ---------- Magic unfolding stuff
420 maybe_magic_result = case unfolding of
421 MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
424 Just magic_result = maybe_magic_result
427 ---------- Unfolding stuff
428 has_unfolding = case unfolding of
429 CoreUnfolding _ _ _ -> True
431 CoreUnfolding form guidance unf_template = unfolding
433 -- overrides cost-centre business
434 must_be_unfolded = case getInlinePragma var of
435 IMustBeINLINEd -> True
438 ok_to_inline = okToInline sw_chkr in_scope var form guidance cont
439 unfolding_is_constr = case unf_template of
440 Con con _ -> conOkForAlt con
442 Con con con_args = unf_template
444 ---------- Specialisation stuff
445 ty_args = initial_ty_args cont
446 remaining_cont = drop_ty_args cont
447 maybe_specialisation = lookupSpecEnv (ppr var) (getIdSpecialisation var) ty_args
448 Just (spec_bindings, spec_template) = maybe_specialisation
450 initial_ty_args (ApplyTo _ (Type ty) (ty_subst,_) cont)
451 = fullSubstTy ty_subst in_scope ty : initial_ty_args cont
452 -- Having to do the substitution here is a bit of a bore
453 initial_ty_args other_cont = []
455 drop_ty_args (ApplyTo _ (Type _) _ cont) = drop_ty_args cont
456 drop_ty_args other_cont = other_cont
460 var_is_case_scrutinee = case cont of
461 Select _ _ _ _ _ -> True
464 ----------- costCentreOk
465 -- costCentreOk checks that it's ok to inline this thing
466 -- The time it *isn't* is this:
468 -- f x = let y = E in
469 -- scc "foo" (...y...)
471 -- Here y has a "current cost centre", and we can't inline it inside "foo",
472 -- regardless of whether E is a WHNF or not.
474 costCentreOk ccs_encl cc_rhs
475 = not opt_SccProfilingOn
476 || isSubsumedCCS ccs_encl -- can unfold anything into a subsumed scope
477 || not (isEmptyCC cc_rhs) -- otherwise need a cc on the unfolding
481 %************************************************************************
483 \subsection{Bindings}
485 %************************************************************************
488 simplBind :: InBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
490 simplBind (NonRec bndr rhs) thing_inside
491 = simplTopRhs bndr rhs `thenSmpl` \ (binds, in_scope, rhs', arity) ->
492 setInScope in_scope $
493 completeBindNonRec (bndr `setIdArity` arity) rhs' thing_inside `thenSmpl` \ stuff ->
494 returnSmpl (addBinds binds stuff)
496 simplBind (Rec pairs) thing_inside
497 = simplRecBind pairs thing_inside
498 -- The assymetry between the two cases is a bit unclean
500 simplRecBind :: [(InId, InExpr)] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
501 simplRecBind pairs thing_inside
502 = simplIds (map fst pairs) $ \ bndrs' ->
503 -- NB: bndrs' don't have unfoldings or spec-envs
504 -- We add them as we go down, using simplPrags
506 go (pairs `zip` bndrs') `thenSmpl` \ (pairs', stuff) ->
507 returnSmpl (addBind (Rec pairs') stuff)
509 go [] = thing_inside `thenSmpl` \ stuff ->
510 returnSmpl ([], stuff)
512 go (((bndr, rhs), bndr') : pairs)
513 = simplTopRhs bndr rhs `thenSmpl` \ (rhs_binds, in_scope, rhs', arity) ->
514 setInScope in_scope $
515 completeBindRec bndr (bndr' `setIdArity` arity)
516 rhs' (go pairs) `thenSmpl` \ (pairs', stuff) ->
517 returnSmpl (flatten rhs_binds pairs', stuff)
519 flatten (NonRec b r : binds) prs = (b,r) : flatten binds prs
520 flatten (Rec prs1 : binds) prs2 = prs1 ++ flatten binds prs2
524 completeBindRec bndr bndr' rhs' thing_inside
525 | postInlineUnconditionally bndr etad_rhs
526 -- NB: a loop breaker never has postInlineUnconditionally True
527 -- and non-loop-breakers only have *forward* references
528 -- Hence, it's safe to discard the binding
529 = tick PostInlineUnconditionally `thenSmpl_`
530 extendIdSubst bndr (Done etad_rhs) thing_inside
533 = -- Here's the only difference from completeBindNonRec: we
534 -- don't do simplBinder first, because we've already
535 -- done simplBinder on the recursive binders
536 simplPrags bndr bndr' etad_rhs `thenSmpl` \ bndr'' ->
537 modifyInScope bndr'' $
538 thing_inside `thenSmpl` \ (pairs, res) ->
539 returnSmpl ((bndr'', etad_rhs) : pairs, res)
541 etad_rhs = etaCoreExpr rhs'
545 %************************************************************************
547 \subsection{Right hand sides}
549 %************************************************************************
551 simplRhs basically just simplifies the RHS of a let(rec).
552 It does two important optimisations though:
554 * It floats let(rec)s out of the RHS, even if they
555 are hidden by big lambdas
557 * It does eta expansion
560 simplTopRhs :: InId -> InExpr
561 -> SimplM ([OutBind], InScopeEnv, OutExpr, ArityInfo)
563 = getSubstEnv `thenSmpl` \ bndr_se ->
564 simplRhs bndr bndr_se rhs
566 simplRhs bndr bndr_se rhs
567 | idWantsToBeINLINEd bndr -- Don't inline in the RHS of something that has an
568 -- inline pragma. But be careful that the InScopeEnv that
569 -- we return does still have inlinings on!
570 = switchOffInlining (simplExpr rhs Stop) `thenSmpl` \ rhs' ->
571 getInScope `thenSmpl` \ in_scope ->
572 returnSmpl ([], in_scope, rhs', unknownArity)
575 = -- Swizzle the inner lets past the big lambda (if any)
576 mkRhsTyLam rhs `thenSmpl` \ swizzled_rhs ->
578 -- Simplify the swizzled RHS
579 simplRhs2 bndr bndr_se swizzled_rhs `thenSmpl` \ (floats, (in_scope, rhs', arity)) ->
581 if not (null floats) && exprIsWHNF rhs' then -- Do the float
582 tick LetFloatFromLet `thenSmpl_`
583 returnSmpl (floats, in_scope, rhs', arity)
585 getInScope `thenSmpl` \ in_scope ->
586 returnSmpl ([], in_scope, mkLetBinds floats rhs', arity)
589 ---------------------------------------------------------
590 Try eta expansion for RHSs
592 We need to pass in the substitution environment for the RHS, because
593 it might be different to the current one (see simplBeta, as called
594 from simplExpr for an applied lambda). The binder needs to
597 simplRhs2 bndr bndr_se (Let bind body)
598 = simplBind bind (simplRhs2 bndr bndr_se body)
600 simplRhs2 bndr bndr_se rhs
601 | null ids -- Prevent eta expansion for both thunks
602 -- (would lose sharing) and variables (nothing gained).
603 -- To see why we ignore it for thunks, consider
604 -- let f = lookup env key in (f 1, f 2)
605 -- We'd better not eta expand f just because it is
608 -- Also if there isn't a lambda at the top we use
609 -- simplExprB so that we can do (more) let-floating
610 = simplExprB rhs Stop `thenSmpl` \ (binds, (in_scope, rhs')) ->
611 returnSmpl (binds, (in_scope, rhs', unknownArity))
613 | otherwise -- Consider eta expansion
614 = getSwitchChecker `thenSmpl` \ sw_chkr ->
615 getInScope `thenSmpl` \ in_scope ->
616 simplBinders tyvars $ \ tyvars' ->
617 simplBinders ids $ \ ids' ->
619 if switchIsOn sw_chkr SimplDoLambdaEtaExpansion
620 && not (null extra_arg_tys)
622 tick EtaExpansion `thenSmpl_`
623 setSubstEnv bndr_se (mapSmpl simplType extra_arg_tys)
624 `thenSmpl` \ extra_arg_tys' ->
625 newIds extra_arg_tys' $ \ extra_bndrs' ->
626 simplExpr body (mk_cont extra_bndrs') `thenSmpl` \ body' ->
628 expanded_rhs = mkLams tyvars'
630 $ mkLams extra_bndrs' body'
631 expanded_arity = atLeastArity (no_of_ids + no_of_extras)
633 returnSmpl ([], (in_scope, expanded_rhs, expanded_arity))
636 simplExpr body Stop `thenSmpl` \ body' ->
638 unexpanded_rhs = mkLams tyvars'
640 unexpanded_arity = atLeastArity no_of_ids
642 returnSmpl ([], (in_scope, unexpanded_rhs, unexpanded_arity))
645 (tyvars, ids, body) = collectTyAndValBinders rhs
646 no_of_ids = length ids
648 potential_extra_arg_tys :: [InType] -- NB: InType
649 potential_extra_arg_tys = case splitFunTys (applyTys (idType bndr) (mkTyVarTys tyvars)) of
650 (arg_tys, _) -> drop no_of_ids arg_tys
652 extra_arg_tys :: [InType]
653 extra_arg_tys = take no_extras_wanted potential_extra_arg_tys
654 no_of_extras = length extra_arg_tys
656 no_extras_wanted = -- Use information about how many args the fn is applied to
657 (arity - no_of_ids) `max`
659 -- See if the body could obviously do with more args
660 etaExpandCount body `max`
662 -- Finally, see if it's a state transformer, in which
663 -- case we eta-expand on principle! This can waste work,
664 -- but usually doesn't
665 case potential_extra_arg_tys of
666 [ty] | ty == realWorldStatePrimTy -> 1
669 arity = arityLowerBound (getIdArity bndr)
672 mk_cont (b:bs) = ApplyTo OkToDup (Var b) emptySubstEnv (mk_cont bs)
676 %************************************************************************
680 %************************************************************************
683 simplBeta :: InId -- Binder
684 -> InExpr -> SubstEnv -- Arg, with its subst-env
685 -> InExpr -> SimplCont -- Lambda body
686 -> SimplM OutExprStuff
688 simplBeta bndr rhs rhs_se body cont
690 = pprPanic "simplBeta" ((ppr bndr <+> ppr rhs) $$ ppr cont)
693 simplBeta bndr rhs rhs_se body cont
694 | isUnLiftedType bndr_ty
695 || (isStrict (getIdDemandInfo bndr) || is_dict bndr) && not (exprIsWHNF rhs)
696 = tick Let2Case `thenSmpl_`
697 getSubstEnv `thenSmpl` \ body_se ->
699 simplExprB rhs (Select NoDup bndr [(DEFAULT, [], body)] body_se cont)
701 | preInlineUnconditionally bndr && not opt_NoPreInlining
702 = tick PreInlineUnconditionally `thenSmpl_`
703 case rhs_se of { (ty_subst, id_subst) ->
704 extendIdSubst bndr (SubstMe rhs ty_subst id_subst) $
705 simplExprB body cont }
708 = getSubstEnv `thenSmpl` \ bndr_se ->
709 setSubstEnv rhs_se (simplRhs bndr bndr_se rhs)
710 `thenSmpl` \ (floats, in_scope, rhs', arity) ->
711 setInScope in_scope $
712 completeBindNonRec (bndr `setIdArity` arity) rhs' (
714 ) `thenSmpl` \ stuff ->
715 returnSmpl (addBinds floats stuff)
717 -- Return true only for dictionary types where the dictionary
718 -- has more than one component (else we risk poking on the component
719 -- of a newtype dictionary)
720 is_dict bndr = opt_DictsStrict && isDictTy bndr_ty && isDataType bndr_ty
721 bndr_ty = idType bndr
726 - deals only with Ids, not TyVars
727 - take an already-simplified RHS
728 - always produce let bindings
730 It does *not* attempt to do let-to-case. Why? Because they are used for
733 (when let-to-case is impossible)
735 - many situations where the "rhs" is known to be a WHNF
736 (so let-to-case is inappropriate).
739 completeBindNonRec :: InId -- Binder
740 -> OutExpr -- Simplified RHS
741 -> SimplM (OutStuff a) -- Thing inside
742 -> SimplM (OutStuff a)
743 completeBindNonRec bndr rhs thing_inside
744 | isDeadBinder bndr -- This happens; for example, the case_bndr during case of
745 -- known constructor: case (a,b) of x { (p,q) -> ... }
746 -- Here x isn't mentioned in the RHS, so we don't want to
747 -- create the (dead) let-binding let x = (a,b) in ...
750 | postInlineUnconditionally bndr etad_rhs
751 = tick PostInlineUnconditionally `thenSmpl_`
752 extendIdSubst bndr (Done etad_rhs)
755 | otherwise -- Note that we use etad_rhs here
756 -- This gives maximum chance for a remaining binding
757 -- to be zapped by the indirection zapper in OccurAnal
758 = simplBinder bndr $ \ bndr' ->
759 simplPrags bndr bndr' etad_rhs `thenSmpl` \ bndr'' ->
760 modifyInScope bndr'' $
761 thing_inside `thenSmpl` \ stuff ->
762 returnSmpl (addBind (NonRec bndr'' etad_rhs) stuff)
764 etad_rhs = etaCoreExpr rhs
766 -- (simplPrags old_bndr new_bndr new_rhs) does two things
767 -- (a) it attaches the new unfolding to new_bndr
768 -- (b) it grabs the SpecEnv from old_bndr, applies the current
769 -- substitution to it, and attaches it to new_bndr
770 -- The assumption is that new_bndr, which is produced by simplBinder
771 -- has no unfolding or specenv.
773 simplPrags old_bndr new_bndr new_rhs
774 | isEmptySpecEnv spec_env
775 = returnSmpl (bndr_w_unfolding)
778 = getSimplBinderStuff `thenSmpl` \ (ty_subst, id_subst, in_scope, us) ->
780 spec_env' = substSpecEnv ty_subst in_scope (subst_val id_subst) spec_env
781 final_bndr = bndr_w_unfolding `setIdSpecialisation` spec_env'
783 returnSmpl final_bndr
785 bndr_w_unfolding = new_bndr `setIdUnfolding` mkUnfolding new_rhs
787 spec_env = getIdSpecialisation old_bndr
788 subst_val id_subst ty_subst in_scope expr
789 = substExpr ty_subst id_subst in_scope expr
793 preInlineUnconditionally :: InId -> Bool
794 -- Examines a bndr to see if it is used just once in a
795 -- completely safe way, so that it is safe to discard the binding
796 -- inline its RHS at the (unique) usage site, REGARDLESS of how
797 -- big the RHS might be. If this is the case we don't simplify
798 -- the RHS first, but just inline it un-simplified.
800 -- This is much better than first simplifying a perhaps-huge RHS
801 -- and then inlining and re-simplifying it.
803 -- NB: we don't even look at the RHS to see if it's trivial
806 -- where x is used many times, but this is the unique occurrence
807 -- of y. We should NOT inline x at all its uses, because then
808 -- we'd do the same for y -- aargh! So we must base this
809 -- pre-rhs-simplification decision solely on x's occurrences, not
811 preInlineUnconditionally bndr
812 = case getInlinePragma bndr of
813 ICanSafelyBeINLINEd InsideLam _ -> False
814 ICanSafelyBeINLINEd not_in_lam True -> True -- Not inside a lambda,
815 -- one occurrence ==> safe!
819 postInlineUnconditionally :: InId -> OutExpr -> Bool
820 -- Examines a (bndr = rhs) binding, AFTER the rhs has been simplified
821 -- It returns True if it's ok to discard the binding and inline the
822 -- RHS at every use site.
824 -- NOTE: This isn't our last opportunity to inline.
825 -- We're at the binding site right now, and
826 -- we'll get another opportunity when we get to the ocurrence(s)
828 postInlineUnconditionally bndr rhs
832 = case getInlinePragma bndr of
833 IAmALoopBreaker -> False
834 IMustNotBeINLINEd -> False
835 IAmASpecPragmaId -> False -- Don't discard SpecPrag Ids
837 ICanSafelyBeINLINEd InsideLam one_branch -> exprIsTrivial rhs
838 -- Don't inline even WHNFs inside lambdas; this
839 -- isn't the last chance; see NOTE above.
841 ICanSafelyBeINLINEd not_in_lam one_branch -> one_branch || exprIsDupable rhs
843 other -> exprIsTrivial rhs -- Duplicating is *free*
844 -- NB: Even IWantToBeINLINEd and IMustBeINLINEd are ignored here
845 -- Why? Because we don't even want to inline them into the
846 -- RHS of constructor arguments. See NOTE above
848 inlineCase bndr scrut
849 = case getInlinePragma bndr of
850 -- Not expecting IAmALoopBreaker etc; this is a case binder!
852 ICanSafelyBeINLINEd StrictOcc one_branch
853 -> one_branch || exprIsDupable scrut
854 -- This case is the entire reason we distinguish StrictOcc from LazyOcc
855 -- We want eliminate the "case" only if we aren't going to
856 -- build a thunk instead, and that's what StrictOcc finds
858 -- case (f x) of y { DEFAULT -> g y }
859 -- Here we DO NOT WANT:
861 -- *even* if g is strict. We want to avoid constructing the
862 -- thunk for (f x)! So y gets a LazyOcc.
864 other -> exprIsTrivial scrut -- Duplication is free
865 && ( isUnLiftedType (idType bndr)
866 || scrut_is_evald_var -- So dropping the case won't change termination
867 || isStrict (getIdDemandInfo bndr)) -- It's going to get evaluated later, so again
868 -- termination doesn't change
870 -- Check whether or not scrut is known to be evaluted
871 -- It's not going to be a visible value (else the previous
872 -- blob would apply) so we just check the variable case
873 scrut_is_evald_var = case scrut of
874 Var v -> isEvaldUnfolding (getIdUnfolding v)
878 okToInline is used at call sites, so it is a bit more generous.
879 It's a very important function that embodies lots of heuristics.
882 okToInline :: SwitchChecker
885 -> FormSummary -- The thing is WHNF or bottom;
888 -> Bool -- True <=> inline it
890 -- A non-WHNF can be inlined if it doesn't occur inside a lambda,
891 -- and occurs exactly once or
892 -- occurs once in each branch of a case and is small
894 -- If the thing is in WHNF, there's no danger of duplicating work,
895 -- so we can inline if it occurs once, or is small
897 okToInline sw_chkr in_scope id form guidance cont
900 if opt_D_dump_inlinings then
901 pprTrace "Considering inlining"
902 (ppr id <+> vcat [text "inline prag:" <+> ppr inline_prag,
903 text "whnf" <+> ppr whnf,
904 text "small enough" <+> ppr small_enough,
905 text "some benefit" <+> ppr some_benefit,
906 text "arg evals" <+> ppr arg_evals,
907 text "result scrut" <+> ppr result_scrut,
908 text "ANSWER =" <+> if result then text "YES" else text "NO"])
916 IAmDead -> pprTrace "okToInline: dead" (ppr id) False
917 IAmASpecPragmaId -> False
918 IMustNotBeINLINEd -> False
919 IAmALoopBreaker -> False
920 IMustBeINLINEd -> True -- If "essential_unfoldings_only" is true we do no inlinings at all,
921 -- EXCEPT for things that absolutely have to be done
922 -- (see comments with idMustBeINLINEd)
923 IWantToBeINLINEd -> inlinings_enabled
924 ICanSafelyBeINLINEd inside_lam one_branch
925 -> inlinings_enabled && (unfold_always || consider_single inside_lam one_branch)
926 NoInlinePragInfo -> inlinings_enabled && (unfold_always || consider_multi)
928 inlinings_enabled = not (switchIsOn sw_chkr EssentialUnfoldingsOnly)
929 unfold_always = unfoldAlways guidance
931 -- Consider benefit for ICanSafelyBeINLINEd
932 consider_single inside_lam one_branch
933 = (small_enough || one_branch) && some_benefit && (whnf || not_inside_lam)
935 not_inside_lam = case inside_lam of {InsideLam -> False; other -> True}
937 -- Consider benefit for NoInlinePragInfo
938 consider_multi = whnf && small_enough && some_benefit
939 -- We could consider using exprIsCheap here,
940 -- as in postInlineUnconditionally, but unlike the latter we wouldn't
941 -- necessarily eliminate a thunk; and the "form" doesn't tell
944 inline_prag = getInlinePragma id
945 whnf = whnfOrBottom form
946 small_enough = smallEnoughToInline id arg_evals result_scrut guidance
947 (arg_evals, result_scrut) = get_evals cont
949 -- some_benefit checks that *something* interesting happens to
950 -- the variable after it's inlined.
951 some_benefit = contIsInteresting cont
953 -- Finding out whether the args are evaluated. This isn't completely easy
954 -- because the args are not yet simplified, so we have to peek into them.
955 get_evals (ApplyTo _ arg (te,ve) cont)
956 | isValArg arg = case get_evals cont of
957 (args, res) -> (get_arg_eval arg ve : args, res)
958 | otherwise = get_evals cont
960 get_evals (Select _ _ _ _ _) = ([], True)
961 get_evals other = ([], False)
963 get_arg_eval (Con con _) ve = isWHNFCon con
964 get_arg_eval (Var v) ve = case lookupVarEnv ve v of
965 Just (SubstMe e' _ ve') -> get_arg_eval e' ve'
966 Just (Done (Con con _)) -> isWHNFCon con
967 Just (Done (Var v')) -> get_var_eval v'
968 Just (Done other) -> False
969 Nothing -> get_var_eval v
970 get_arg_eval other ve = False
972 get_var_eval v = case lookupVarSet in_scope v of
973 Just v' -> isEvaldUnfolding (getIdUnfolding v')
974 Nothing -> isEvaldUnfolding (getIdUnfolding v)
977 contIsInteresting :: SimplCont -> Bool
978 contIsInteresting Stop = False
979 contIsInteresting (ArgOf _ _ _) = False
980 contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont
981 contIsInteresting (CoerceIt _ _ _ cont) = contIsInteresting cont
983 -- See notes below on why a case with only a DEFAULT case is not intersting
984 -- contIsInteresting (Select _ _ [(DEFAULT,_,_)] _ _) = False
986 contIsInteresting _ = True
989 Comment about some_benefit above
990 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
992 We want to avoid inlining an expression where there can't possibly be
993 any gain, such as in an argument position. Hence, if the continuation
994 is interesting (eg. a case scrutinee, application etc.) then we
995 inline, otherwise we don't.
997 Previously some_benefit used to return True only if the variable was
998 applied to some value arguments. This didn't work:
1000 let x = _coerce_ (T Int) Int (I# 3) in
1001 case _coerce_ Int (T Int) x of
1004 we want to inline x, but can't see that it's a constructor in a case
1005 scrutinee position, and some_benefit is False.
1009 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
1011 .... case dMonadST _@_ x0 of (a,b,c) -> ....
1013 we'd really like to inline dMonadST here, but we *don't* want to
1014 inline if the case expression is just
1016 case x of y { DEFAULT -> ... }
1018 since we can just eliminate this case instead (x is in WHNF). Similar
1019 applies when x is bound to a lambda expression. Hence
1020 contIsInteresting looks for case expressions with just a single
1024 %************************************************************************
1026 \subsection{The main rebuilder}
1028 %************************************************************************
1031 -------------------------------------------------------------------
1032 rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff
1035 = tick LeavesExamined `thenSmpl_`
1037 Var v -> case getIdStrictness v of
1038 NoStrictnessInfo -> do_rebuild expr cont
1039 StrictnessInfo demands result_bot _ -> ASSERT( not (null demands) || result_bot )
1040 -- If this happened we'd get an infinite loop
1041 rebuild_strict demands result_bot expr (idType v) cont
1042 other -> do_rebuild expr cont
1045 = getInScope `thenSmpl` \ in_scope ->
1046 returnSmpl ([], (in_scope, expr))
1048 ---------------------------------------------------------
1049 -- Stop continuation
1051 do_rebuild expr Stop = rebuild_done expr
1054 ---------------------------------------------------------
1055 -- ArgOf continuation
1057 do_rebuild expr (ArgOf _ cont_fn _) = cont_fn expr
1059 ---------------------------------------------------------
1060 -- ApplyTo continuation
1062 do_rebuild expr cont@(ApplyTo _ arg se cont')
1063 = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
1064 do_rebuild (App expr arg') cont'
1067 ---------------------------------------------------------
1068 -- Coerce continuation
1070 do_rebuild expr (CoerceIt _ to_ty se cont)
1072 simplType to_ty `thenSmpl` \ to_ty' ->
1073 do_rebuild (mk_coerce to_ty' expr) cont
1076 ---------------------------------------------------------
1077 -- Case of known constructor or literal
1079 do_rebuild expr@(Con con args) cont@(Select _ _ _ _ _)
1080 | conOkForAlt con -- Knocks out PrimOps and NoRepLits
1081 = knownCon expr con args cont
1084 ---------------------------------------------------------
1086 -- Case of other value (e.g. a partial application or lambda)
1087 -- Turn it back into a let
1089 do_rebuild expr (Select _ bndr ((DEFAULT, bs, rhs):alts) se cont)
1090 | case mkFormSummary expr of { ValueForm -> True; other -> False }
1091 = ASSERT( null bs && null alts )
1092 tick Case2Let `thenSmpl_`
1094 completeBindNonRec bndr expr $
1099 ---------------------------------------------------------
1100 -- The other Select cases
1102 do_rebuild scrut (Select _ bndr alts se cont)
1103 = getSwitchChecker `thenSmpl` \ chkr ->
1105 if all (cheapEqExpr rhs1) other_rhss
1106 && inlineCase bndr scrut
1107 && all binders_unused alts
1108 && switchIsOn chkr SimplDoCaseElim
1110 -- Get rid of the case altogether
1111 -- See the extensive notes on case-elimination below
1112 -- Remember to bind the binder though!
1113 tick CaseElim `thenSmpl_`
1115 extendIdSubst bndr (Done scrut) $
1116 simplExprB rhs1 cont
1120 rebuild_case chkr scrut bndr alts se cont
1122 (rhs1:other_rhss) = [rhs | (_,_,rhs) <- alts]
1123 binders_unused (_, bndrs, _) = all isDeadBinder bndrs
1126 Case elimination [see the code above]
1128 Start with a simple situation:
1130 case x# of ===> e[x#/y#]
1133 (when x#, y# are of primitive type, of course). We can't (in general)
1134 do this for algebraic cases, because we might turn bottom into
1137 Actually, we generalise this idea to look for a case where we're
1138 scrutinising a variable, and we know that only the default case can
1143 other -> ...(case x of
1147 Here the inner case can be eliminated. This really only shows up in
1148 eliminating error-checking code.
1150 We also make sure that we deal with this very common case:
1155 Here we are using the case as a strict let; if x is used only once
1156 then we want to inline it. We have to be careful that this doesn't
1157 make the program terminate when it would have diverged before, so we
1159 - x is used strictly, or
1160 - e is already evaluated (it may so if e is a variable)
1162 Lastly, we generalise the transformation to handle this:
1168 We only do this for very cheaply compared r's (constructors, literals
1169 and variables). If pedantic bottoms is on, we only do it when the
1170 scrutinee is a PrimOp which can't fail.
1172 We do it *here*, looking at un-simplified alternatives, because we
1173 have to check that r doesn't mention the variables bound by the
1174 pattern in each alternative, so the binder-info is rather useful.
1176 So the case-elimination algorithm is:
1178 1. Eliminate alternatives which can't match
1180 2. Check whether all the remaining alternatives
1181 (a) do not mention in their rhs any of the variables bound in their pattern
1182 and (b) have equal rhss
1184 3. Check we can safely ditch the case:
1185 * PedanticBottoms is off,
1186 or * the scrutinee is an already-evaluated variable
1187 or * the scrutinee is a primop which is ok for speculation
1188 -- ie we want to preserve divide-by-zero errors, and
1189 -- calls to error itself!
1191 or * [Prim cases] the scrutinee is a primitive variable
1193 or * [Alg cases] the scrutinee is a variable and
1194 either * the rhs is the same variable
1195 (eg case x of C a b -> x ===> x)
1196 or * there is only one alternative, the default alternative,
1197 and the binder is used strictly in its scope.
1198 [NB this is helped by the "use default binder where
1199 possible" transformation; see below.]
1202 If so, then we can replace the case with one of the rhss.
1206 ---------------------------------------------------------
1207 -- Rebuiling a function with strictness info
1208 -- This just a version of do_rebuild, enhanced with info about
1209 -- the strictness of the thing being rebuilt.
1211 rebuild_strict :: [Demand] -> Bool -- Stricness info
1212 -> OutExpr -> OutType -- Function and type
1213 -> SimplCont -- Continuation
1214 -> SimplM OutExprStuff
1216 rebuild_strict [] True fun fun_ty cont = rebuild_bot fun fun_ty cont
1217 rebuild_strict [] False fun fun_ty cont = do_rebuild fun cont
1219 rebuild_strict ds result_bot fun fun_ty (CoerceIt _ to_ty se cont)
1221 simplType to_ty `thenSmpl` \ to_ty' ->
1222 rebuild_strict ds result_bot (mk_coerce to_ty' fun) to_ty' cont
1224 rebuild_strict ds result_bot fun fun_ty (ApplyTo _ (Type ty_arg) se cont)
1225 -- Type arg; don't consume a demand
1226 = setSubstEnv se (simplType ty_arg) `thenSmpl` \ ty_arg' ->
1227 rebuild_strict ds result_bot (App fun (Type ty_arg'))
1228 (applyTy fun_ty ty_arg') cont
1230 rebuild_strict (d:ds) result_bot fun fun_ty (ApplyTo _ val_arg se cont)
1231 | isStrict d || isUnLiftedType arg_ty
1232 -- Strict value argument
1233 = getInScope `thenSmpl` \ in_scope ->
1235 cont_ty = contResultType in_scope res_ty cont
1237 setSubstEnv se (simplExprB val_arg (ArgOf NoDup cont_fn cont_ty))
1239 | otherwise -- Lazy value argument
1240 = setSubstEnv se (simplArg val_arg) `thenSmpl` \ val_arg' ->
1244 Just (arg_ty, res_ty) = splitFunTy_maybe fun_ty
1245 cont_fn arg' = rebuild_strict ds result_bot
1246 (App fun arg') res_ty
1249 rebuild_strict ds result_bot fun fun_ty cont = do_rebuild fun cont
1251 ---------------------------------------------------------
1253 -- * case (error "hello") of { ... }
1254 -- * (error "Hello") arg
1255 -- * f (error "Hello") where f is strict
1258 rebuild_bot expr expr_ty Stop -- No coerce needed
1261 rebuild_bot expr expr_ty (CoerceIt _ to_ty se Stop) -- Don't "tick" on this,
1262 -- else simplifier never stops
1264 simplType to_ty `thenSmpl` \ to_ty' ->
1265 rebuild_done (mkNote (Coerce to_ty' expr_ty) expr)
1267 rebuild_bot expr expr_ty cont -- Abandon the (strict) continuation,
1268 -- and just return expr
1269 = tick CaseOfError `thenSmpl_`
1270 getInScope `thenSmpl` \ in_scope ->
1272 result_ty = contResultType in_scope expr_ty cont
1274 rebuild_done (mkNote (Coerce result_ty expr_ty) expr)
1276 mk_coerce to_ty (Note (Coerce _ from_ty) expr) = Note (Coerce to_ty from_ty) expr
1277 mk_coerce to_ty expr = Note (Coerce to_ty (coreExprType expr)) expr
1280 Blob of helper functions for the "case-of-something-else" situation.
1283 ---------------------------------------------------------
1284 -- Case of something else
1286 rebuild_case sw_chkr scrut case_bndr alts se cont
1287 = -- Prepare case alternatives
1288 prepareCaseAlts (splitTyConApp_maybe (idType case_bndr))
1289 scrut_cons alts `thenSmpl` \ better_alts ->
1291 -- Set the new subst-env in place (before dealing with the case binder)
1294 -- Deal with the case binder, and prepare the continuation;
1295 -- The new subst_env is in place
1296 simplBinder case_bndr $ \ case_bndr' ->
1297 prepareCaseCont better_alts cont $ \ cont' ->
1300 -- Deal with variable scrutinee
1301 substForVarScrut scrut case_bndr' $ \ zap_occ_info ->
1303 case_bndr'' = zap_occ_info case_bndr'
1306 -- Deal with the case alternaatives
1307 simplAlts zap_occ_info scrut_cons
1308 case_bndr'' better_alts cont' `thenSmpl` \ alts' ->
1310 mkCase sw_chkr scrut case_bndr'' alts' `thenSmpl` \ case_expr ->
1311 rebuild_done case_expr
1313 -- scrut_cons tells what constructors the scrutinee can't possibly match
1314 scrut_cons = case scrut of
1315 Var v -> case getIdUnfolding v of
1316 OtherCon cons -> cons
1321 knownCon expr con args (Select _ bndr alts se cont)
1322 = tick KnownBranch `thenSmpl_`
1324 case findAlt con alts of
1325 (DEFAULT, bs, rhs) -> ASSERT( null bs )
1326 completeBindNonRec bndr expr $
1329 (Literal lit, bs, rhs) -> ASSERT( null bs )
1330 extendIdSubst bndr (Done expr) $
1331 -- Unconditionally substitute, because expr must
1332 -- be a variable or a literal. It can't be a
1333 -- NoRep literal because they don't occur in
1337 (DataCon dc, bs, rhs) -> completeBindNonRec bndr expr $
1338 extend bs real_args $
1341 real_args = drop (dataConNumInstArgs dc) args
1344 extend [] [] thing_inside = thing_inside
1345 extend (b:bs) (arg:args) thing_inside = extendIdSubst b (Done arg) $
1346 extend bs args thing_inside
1350 prepareCaseCont :: [InAlt] -> SimplCont
1351 -> (SimplCont -> SimplM (OutStuff a))
1352 -> SimplM (OutStuff a)
1353 -- Polymorphic recursion here!
1355 prepareCaseCont [alt] cont thing_inside = thing_inside cont
1356 prepareCaseCont alts cont thing_inside = mkDupableCont (coreAltsType alts) cont thing_inside
1359 substForVarScrut checks whether the scrutinee is a variable, v.
1360 If so, try to eliminate uses of v in the RHSs in favour of case_bndr;
1361 that way, there's a chance that v will now only be used once, and hence inlined.
1363 If we do this, then we have to nuke any occurrence info (eg IAmDead)
1364 in the case binder, because the case-binder now effectively occurs
1365 whenever v does. AND we have to do the same for the pattern-bound
1368 (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
1370 Here, b and p are dead. But when we move the argment inside the first
1371 case RHS, and eliminate the second case, we get
1373 case x or { (a,b) -> a b
1375 Urk! b is alive! Reason: the scrutinee was a variable, and case elimination
1376 happened. Hence the zap_occ_info function returned by substForVarScrut
1379 substForVarScrut (Var v) case_bndr' thing_inside
1380 | isLocallyDefined v -- No point for imported things
1381 = modifyInScope (v `setIdUnfolding` mkUnfolding (Var case_bndr')
1382 `setInlinePragma` IMustBeINLINEd) $
1383 -- We could extend the substitution instead, but it would be
1384 -- a hack because then the substitution wouldn't be idempotent
1386 thing_inside (\ bndr -> bndr `setInlinePragma` NoInlinePragInfo)
1388 substForVarScrut other_scrut case_bndr' thing_inside
1389 = thing_inside (\ bndr -> bndr) -- NoOp on bndr
1392 prepareCaseAlts does two things:
1394 1. Remove impossible alternatives
1396 2. If the DEFAULT alternative can match only one possible constructor,
1397 then make that constructor explicit.
1399 case e of x { DEFAULT -> rhs }
1401 case e of x { (a,b) -> rhs }
1402 where the type is a single constructor type. This gives better code
1403 when rhs also scrutinises x or e.
1406 prepareCaseAlts (Just (tycon, inst_tys)) scrut_cons alts
1408 = case (findDefault filtered_alts, missing_cons) of
1410 ((alts_no_deflt, Just rhs), [data_con]) -- Just one missing constructor!
1411 -> tick FillInCaseDefault `thenSmpl_`
1413 (_,_,ex_tyvars,_,_,_) = dataConSig data_con
1415 getUniquesSmpl (length ex_tyvars) `thenSmpl` \ tv_uniqs ->
1417 ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars
1418 mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
1420 newIds (dataConArgTys
1422 (inst_tys ++ mkTyVarTys ex_tyvars')) $ \ bndrs ->
1423 returnSmpl ((DataCon data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt)
1425 other -> returnSmpl filtered_alts
1427 -- Filter out alternatives that can't possibly match
1428 filtered_alts = case scrut_cons of
1430 other -> [alt | alt@(con,_,_) <- alts, not (con `elem` scrut_cons)]
1432 missing_cons = [data_con | data_con <- tyConDataCons tycon,
1433 not (data_con `elem` handled_data_cons)]
1434 handled_data_cons = [data_con | DataCon data_con <- scrut_cons] ++
1435 [data_con | (DataCon data_con, _, _) <- filtered_alts]
1438 prepareCaseAlts _ scrut_cons alts
1439 = returnSmpl alts -- Functions
1442 ----------------------
1443 simplAlts zap_occ_info scrut_cons case_bndr'' alts cont'
1444 = mapSmpl simpl_alt alts
1446 inst_tys' = case splitTyConApp_maybe (idType case_bndr'') of
1447 Just (tycon, inst_tys) -> inst_tys
1449 -- handled_cons is all the constructors that are dealt
1450 -- with, either by being impossible, or by there being an alternative
1451 handled_cons = scrut_cons ++ [con | (con,_,_) <- alts, con /= DEFAULT]
1453 simpl_alt (DEFAULT, _, rhs)
1454 = -- In the default case we record the constructors that the
1455 -- case-binder *can't* be.
1456 -- We take advantage of any OtherCon info in the case scrutinee
1457 modifyInScope (case_bndr'' `setIdUnfolding` OtherCon handled_cons) $
1458 simplExpr rhs cont' `thenSmpl` \ rhs' ->
1459 returnSmpl (DEFAULT, [], rhs')
1461 simpl_alt (con, vs, rhs)
1462 = -- Deal with the pattern-bound variables
1463 -- Mark the ones that are in ! positions in the data constructor
1464 -- as certainly-evaluated
1465 simplBinders (add_evals con vs) $ \ vs' ->
1467 -- Bind the case-binder to (Con args)
1469 con_app = Con con (map Type inst_tys' ++ map varToCoreExpr vs')
1471 modifyInScope (case_bndr'' `setIdUnfolding` mkUnfolding con_app) $
1472 simplExpr rhs cont' `thenSmpl` \ rhs' ->
1473 returnSmpl (con, vs', rhs')
1476 -- add_evals records the evaluated-ness of the bound variables of
1477 -- a case pattern. This is *important*. Consider
1478 -- data T = T !Int !Int
1480 -- case x of { T a b -> T (a+1) b }
1482 -- We really must record that b is already evaluated so that we don't
1483 -- go and re-evaluated it when constructing the result.
1485 add_evals (DataCon dc) vs = stretchZipEqual add_eval vs (dataConStrictMarks dc)
1486 add_evals other_con vs = vs
1488 add_eval v m | isTyVar v = Nothing
1489 | otherwise = case m of
1490 MarkedStrict -> Just (zap_occ_info v `setIdUnfolding` OtherCon [])
1491 NotMarkedStrict -> Just (zap_occ_info v)
1497 %************************************************************************
1499 \subsection{Duplicating continuations}
1501 %************************************************************************
1504 mkDupableCont :: InType -- Type of the thing to be given to the continuation
1506 -> (SimplCont -> SimplM (OutStuff a))
1507 -> SimplM (OutStuff a)
1508 mkDupableCont ty cont thing_inside
1509 | contIsDupable cont
1512 mkDupableCont _ (CoerceIt _ ty se cont) thing_inside
1513 = mkDupableCont ty cont $ \ cont' ->
1514 thing_inside (CoerceIt OkToDup ty se cont')
1516 mkDupableCont join_arg_ty (ArgOf _ cont_fn res_ty) thing_inside
1517 = -- Build the RHS of the join point
1518 simplType join_arg_ty `thenSmpl` \ join_arg_ty' ->
1519 newId join_arg_ty' ( \ arg_id ->
1520 getSwitchChecker `thenSmpl` \ chkr ->
1521 cont_fn (Var arg_id) `thenSmpl` \ (binds, (_, rhs)) ->
1522 returnSmpl (Lam arg_id (mkLetBinds binds rhs))
1523 ) `thenSmpl` \ join_rhs ->
1525 -- Build the join Id and continuation
1526 newId (coreExprType join_rhs) $ \ join_id ->
1528 new_cont = ArgOf OkToDup
1529 (\arg' -> rebuild_done (App (Var join_id) arg'))
1533 -- Do the thing inside
1534 thing_inside new_cont `thenSmpl` \ res ->
1535 returnSmpl (addBind (NonRec join_id join_rhs) res)
1537 mkDupableCont ty (ApplyTo _ arg se cont) thing_inside
1538 = mkDupableCont (funResultTy ty) cont $ \ cont' ->
1539 setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
1540 if exprIsDupable arg' then
1541 thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont')
1543 newId (coreExprType arg') $ \ bndr ->
1544 thing_inside (ApplyTo OkToDup (Var bndr) emptySubstEnv cont') `thenSmpl` \ res ->
1545 returnSmpl (addBind (NonRec bndr arg') res)
1547 mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside
1548 = tick CaseOfCase `thenSmpl_` (
1550 simplBinder case_bndr $ \ case_bndr' ->
1551 prepareCaseCont alts cont $ \ cont' ->
1552 mapAndUnzipSmpl (mkDupableAlt case_bndr' cont') alts `thenSmpl` \ (alt_binds_s, alts') ->
1553 returnSmpl (concat alt_binds_s, (case_bndr', alts'))
1554 ) `thenSmpl` \ (alt_binds, (case_bndr', alts')) ->
1556 extendInScopes [b | NonRec b _ <- alt_binds] $
1557 thing_inside (Select OkToDup case_bndr' alts' emptySubstEnv Stop) `thenSmpl` \ res ->
1558 returnSmpl (addBinds alt_binds res)
1561 mkDupableAlt :: OutId -> SimplCont -> InAlt -> SimplM (OutStuff CoreAlt)
1562 mkDupableAlt case_bndr' cont alt@(con, bndrs, rhs)
1563 = simplBinders bndrs $ \ bndrs' ->
1564 simplExpr rhs cont `thenSmpl` \ rhs' ->
1565 if exprIsDupable rhs' then
1566 -- It's small, so don't bother to let-bind it
1567 returnSmpl ([], (con, bndrs', rhs'))
1569 -- It's big, so let-bind it
1571 rhs_ty' = coreExprType rhs'
1572 used_bndrs' = filter (not . isDeadBinder) (case_bndr' : bndrs')
1574 ( if null used_bndrs' && isUnLiftedType rhs_ty'
1575 then newId realWorldStatePrimTy $ \ rw_id ->
1576 returnSmpl ([rw_id], [varToCoreExpr realWorldPrimId])
1578 returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
1580 `thenSmpl` \ (final_bndrs', final_args) ->
1582 -- If we try to lift a primitive-typed something out
1583 -- for let-binding-purposes, we will *caseify* it (!),
1584 -- with potentially-disastrous strictness results. So
1585 -- instead we turn it into a function: \v -> e
1586 -- where v::State# RealWorld#. The value passed to this function
1587 -- is realworld#, which generates (almost) no code.
1589 -- There's a slight infelicity here: we pass the overall
1590 -- case_bndr to all the join points if it's used in *any* RHS,
1591 -- because we don't know its usage in each RHS separately
1593 newId (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr ->
1594 returnSmpl ([NonRec join_bndr (mkLams final_bndrs' rhs')],
1595 (con, bndrs', mkApps (Var join_bndr) final_args))