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,
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 0 _ _ = False -- Too expensive to find out
313 definitely_saturated n (Lam _ body) (ApplyTo _ _ _ cont) = definitely_saturated (n-1) body cont
314 definitely_saturated n (Lam _ _) other_cont = False
315 definitely_saturated n _ _ = True
318 %************************************************************************
320 \subsection{Variables}
322 %************************************************************************
327 simplVar inline_call var cont
328 = getValEnv `thenSmpl` \ (id_subst, in_scope) ->
329 case lookupVarEnv id_subst var of
331 -> zapSubstEnv (simplExprB e cont)
333 Just (SubstMe e ty_subst id_subst)
334 -> setSubstEnv (ty_subst, id_subst) (simplExprB e cont)
337 var' = case lookupVarSet in_scope var of
341 if isLocallyDefined var && not (idMustBeINLINEd var) then
343 pprTrace "simplVar:" (ppr var) var
348 getSwitchChecker `thenSmpl` \ sw_chkr ->
349 completeVar sw_chkr in_scope inline_call var' cont
351 completeVar sw_chkr in_scope inline_call var cont
353 {- MAGIC UNFOLDINGS NOT USED NOW
354 | maybeToBool maybe_magic_result
355 = tick MagicUnfold `thenSmpl_`
358 -- Look for existing specialisations before trying inlining
359 | maybeToBool maybe_specialisation
360 = tick SpecialisationDone `thenSmpl_`
361 setSubstEnv (spec_bindings, emptyVarEnv) (
362 -- See note below about zapping the substitution here
364 simplExprB spec_template remaining_cont
367 -- Don't actually inline the scrutinee when we see
368 -- case x of y { .... }
369 -- and x has unfolding (C a b). Why not? Because
370 -- we get a silly binding y = C a b. If we don't
371 -- inline knownCon can directly substitute x for y instead.
372 | has_unfolding && var_is_case_scrutinee && unfolding_is_constr
373 = knownCon (Var var) con con_args cont
375 -- Look for an unfolding. There's a binding for the
376 -- thing, but perhaps we want to inline it anyway
377 | has_unfolding && (inline_call || ok_to_inline)
378 = getEnclosingCC `thenSmpl` \ encl_cc ->
379 if must_be_unfolded || costCentreOk encl_cc (coreExprCc unf_template)
382 tickUnfold var `thenSmpl_` (
385 -- The template is already simplified, so don't re-substitute.
386 -- This is VITAL. Consider
388 -- let y = \z -> ...x... in
390 -- We'll clone the inner \x, adding x->x' in the id_subst
391 -- Then when we inline y, we must *not* replace x by x' in
392 -- the inlined copy!!
394 if opt_D_dump_inlinings then
395 pprTrace "Inlining:" (ppr var <+> ppr unf_template) $
396 simplExprB unf_template cont
399 simplExprB unf_template cont
403 pprTrace "Inlining disallowed due to CC:\n" (ppr encl_cc <+> ppr unf_template <+> ppr (coreExprCc unf_template)) $
405 -- Can't unfold because of bad cost centre
406 rebuild (Var var) cont
408 | inline_call -- There was an InlineCall note, but we didn't inline!
409 = rebuild (Note InlineCall (Var var)) cont
412 = rebuild (Var var) cont
415 unfolding = getIdUnfolding var
417 {- MAGIC UNFOLDINGS NOT USED CURRENTLY
418 ---------- Magic unfolding stuff
419 maybe_magic_result = case unfolding of
420 MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
423 Just magic_result = maybe_magic_result
426 ---------- Unfolding stuff
427 has_unfolding = case unfolding of
428 CoreUnfolding _ _ _ -> True
431 -- overrides cost-centre business
432 must_be_unfolded = case getInlinePragma var of
433 IMustBeINLINEd -> True
436 CoreUnfolding form guidance unf_template = unfolding
438 unfolding_is_constr = case unf_template of
439 Con con _ -> conOkForAlt con
441 Con con con_args = unf_template
443 ---------- Specialisation stuff
444 ty_args = initial_ty_args cont
445 remaining_cont = drop_ty_args cont
446 maybe_specialisation = lookupSpecEnv (ppr var) (getIdSpecialisation var) ty_args
447 Just (spec_bindings, spec_template) = maybe_specialisation
449 initial_ty_args (ApplyTo _ (Type ty) (ty_subst,_) cont)
450 = fullSubstTy ty_subst in_scope ty : initial_ty_args cont
451 -- Having to do the substitution here is a bit of a bore
452 initial_ty_args other_cont = []
454 drop_ty_args (ApplyTo _ (Type _) _ cont) = drop_ty_args cont
455 drop_ty_args other_cont = other_cont
458 ok_to_inline = okToInline sw_chkr in_scope var form guidance 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` \ rhs' ->
578 -- Simplify the swizzled RHS
579 simplRhs2 bndr bndr_se 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
782 returnSmpl (bndr_w_unfolding `setIdSpecialisation` spec_env')
784 bndr_w_unfolding = new_bndr `setIdUnfolding` mkUnfolding new_rhs
786 spec_env = getIdSpecialisation old_bndr
787 subst_val id_subst ty_subst in_scope expr
788 = substExpr ty_subst id_subst in_scope expr
792 preInlineUnconditionally :: InId -> Bool
793 -- Examines a bndr to see if it is used just once in a
794 -- completely safe way, so that it is safe to discard the binding
795 -- inline its RHS at the (unique) usage site, REGARDLESS of how
796 -- big the RHS might be. If this is the case we don't simplify
797 -- the RHS first, but just inline it un-simplified.
799 -- This is much better than first simplifying a perhaps-huge RHS
800 -- and then inlining and re-simplifying it.
802 -- NB: we don't even look at the RHS to see if it's trivial
805 -- where x is used many times, but this is the unique occurrence
806 -- of y. We should NOT inline x at all its uses, because then
807 -- we'd do the same for y -- aargh! So we must base this
808 -- pre-rhs-simplification decision solely on x's occurrences, not
810 preInlineUnconditionally bndr
811 = case getInlinePragma bndr of
812 ICanSafelyBeINLINEd InsideLam _ -> False
813 ICanSafelyBeINLINEd not_in_lam True -> True -- Not inside a lambda,
814 -- one occurrence ==> safe!
818 postInlineUnconditionally :: InId -> OutExpr -> Bool
819 -- Examines a (bndr = rhs) binding, AFTER the rhs has been simplified
820 -- It returns True if it's ok to discard the binding and inline the
821 -- RHS at every use site.
823 -- NOTE: This isn't our last opportunity to inline.
824 -- We're at the binding site right now, and
825 -- we'll get another opportunity when we get to the ocurrence(s)
827 postInlineUnconditionally bndr rhs
831 = case getInlinePragma bndr of
832 IAmALoopBreaker -> False
833 IMustNotBeINLINEd -> False
834 IAmASpecPragmaId -> False -- Don't discard SpecPrag Ids
836 ICanSafelyBeINLINEd InsideLam one_branch -> exprIsTrivial rhs
837 -- Don't inline even WHNFs inside lambdas; this
838 -- isn't the last chance; see NOTE above.
840 ICanSafelyBeINLINEd not_in_lam one_branch -> one_branch || exprIsDupable rhs
842 other -> exprIsTrivial rhs -- Duplicating is *free*
843 -- NB: Even IWantToBeINLINEd and IMustBeINLINEd are ignored here
844 -- Why? Because we don't even want to inline them into the
845 -- RHS of constructor arguments. See NOTE above
847 inlineCase bndr scrut
848 = case getInlinePragma bndr of
849 -- Not expecting IAmALoopBreaker etc; this is a case binder!
851 ICanSafelyBeINLINEd StrictOcc one_branch
852 -> one_branch || exprIsDupable scrut
853 -- This case is the entire reason we distinguish StrictOcc from LazyOcc
854 -- We want eliminate the "case" only if we aren't going to
855 -- build a thunk instead, and that's what StrictOcc finds
857 -- case (f x) of y { DEFAULT -> g y }
858 -- Here we DO NOT WANT:
860 -- *even* if g is strict. We want to avoid constructing the
861 -- thunk for (f x)! So y gets a LazyOcc.
863 other -> exprIsTrivial scrut -- Duplication is free
864 && ( isUnLiftedType (idType bndr)
865 || scrut_is_evald_var -- So dropping the case won't change termination
866 || isStrict (getIdDemandInfo bndr)) -- It's going to get evaluated later, so again
867 -- termination doesn't change
869 -- Check whether or not scrut is known to be evaluted
870 -- It's not going to be a visible value (else the previous
871 -- blob would apply) so we just check the variable case
872 scrut_is_evald_var = case scrut of
873 Var v -> isEvaldUnfolding (getIdUnfolding v)
877 okToInline is used at call sites, so it is a bit more generous.
878 It's a very important function that embodies lots of heuristics.
881 okToInline :: SwitchChecker
884 -> FormSummary -- The thing is WHNF or bottom;
887 -> Bool -- True <=> inline it
889 -- A non-WHNF can be inlined if it doesn't occur inside a lambda,
890 -- and occurs exactly once or
891 -- occurs once in each branch of a case and is small
893 -- If the thing is in WHNF, there's no danger of duplicating work,
894 -- so we can inline if it occurs once, or is small
896 okToInline sw_chkr in_scope id form guidance cont
897 | essential_unfoldings_only
899 -- If "essential_unfoldings_only" is true we do no inlinings at all,
900 -- EXCEPT for things that absolutely have to be done
901 -- (see comments with idMustBeINLINEd)
904 = case getInlinePragma id of
905 IAmDead -> pprTrace "okToInline: dead" (ppr id) False
907 IAmASpecPragmaId -> False
908 IMustNotBeINLINEd -> False
909 IAmALoopBreaker -> False
910 IMustBeINLINEd -> True
911 IWantToBeINLINEd -> True
913 ICanSafelyBeINLINEd inside_lam one_branch
914 -> --pprTrace "inline (occurs once): " (ppr id <+> ppr small_enough <+> ppr one_branch <+> ppr whnf <+> ppr some_benefit <+> ppr not_inside_lam) $
915 (small_enough || one_branch) &&
916 ((whnf && some_benefit) || not_inside_lam)
919 not_inside_lam = case inside_lam of {InsideLam -> False; other -> True}
921 other -> (if opt_PprStyle_Debug then
922 pprTrace "inline:" (ppr id <+> ppr small_enough <+> ppr whnf <+> ppr some_benefit)
924 whnf && small_enough && some_benefit
925 -- We could consider using exprIsCheap here,
926 -- as in postInlineUnconditionally, but unlike the latter we wouldn't
927 -- necessarily eliminate a thunk; and the "form" doesn't tell
930 whnf = whnfOrBottom form
931 small_enough = smallEnoughToInline id arg_evals result_scrut guidance
932 (arg_evals, result_scrut) = get_evals cont
934 -- some_benefit checks that *something* interesting happens to
935 -- the variable after it's inlined.
936 some_benefit = contIsInteresting cont
938 -- Finding out whether the args are evaluated. This isn't completely easy
939 -- because the args are not yet simplified, so we have to peek into them.
940 get_evals (ApplyTo _ arg (te,ve) cont)
941 | isValArg arg = case get_evals cont of
942 (args, res) -> (get_arg_eval arg ve : args, res)
943 | otherwise = get_evals cont
945 get_evals (Select _ _ _ _ _) = ([], True)
946 get_evals other = ([], False)
948 get_arg_eval (Con con _) ve = isWHNFCon con
949 get_arg_eval (Var v) ve = case lookupVarEnv ve v of
950 Just (SubstMe e' _ ve') -> get_arg_eval e' ve'
951 Just (Done (Con con _)) -> isWHNFCon con
952 Just (Done (Var v')) -> get_var_eval v'
953 Just (Done other) -> False
954 Nothing -> get_var_eval v
955 get_arg_eval other ve = False
957 get_var_eval v = case lookupVarSet in_scope v of
958 Just v' -> isEvaldUnfolding (getIdUnfolding v')
959 Nothing -> isEvaldUnfolding (getIdUnfolding v)
961 essential_unfoldings_only = switchIsOn sw_chkr EssentialUnfoldingsOnly
963 contIsInteresting :: SimplCont -> Bool
964 contIsInteresting Stop = False
965 contIsInteresting (ArgOf _ _ _) = False
966 contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont
967 contIsInteresting (CoerceIt _ _ _ cont) = contIsInteresting cont
969 -- Even a case with only a default case is a bit interesting;
970 -- we may be able to eliminate it after inlining.
971 -- contIsInteresting (Select _ _ [(DEFAULT,_,_)] _ _) = False
973 contIsInteresting _ = True
976 Comment about some_benefit above
977 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
979 We want to avoid inlining an expression where there can't possibly be
980 any gain, such as in an argument position. Hence, if the continuation
981 is interesting (eg. a case scrutinee, application etc.) then we
982 inline, otherwise we don't.
984 Previously some_benefit used to return True only if the variable was
985 applied to some value arguments. This didn't work:
987 let x = _coerce_ (T Int) Int (I# 3) in
988 case _coerce_ Int (T Int) x of
991 we want to inline x, but can't see that it's a constructor in a case
992 scrutinee position, and some_benefit is False.
996 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
998 .... case dMonadST _@_ x0 of (a,b,c) -> ....
1000 we'd really like to inline dMonadST here, but we *don't* want to
1001 inline if the case expression is just
1003 case x of y { DEFAULT -> ... }
1005 since we can just eliminate this case instead (x is in WHNF). Similar
1006 applies when x is bound to a lambda expression. Hence
1007 contIsInteresting looks for case expressions with just a single
1010 %************************************************************************
1012 \subsection{The main rebuilder}
1014 %************************************************************************
1017 -------------------------------------------------------------------
1018 rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff
1021 = tick LeavesExamined `thenSmpl_`
1022 do_rebuild expr cont
1025 = getInScope `thenSmpl` \ in_scope ->
1026 returnSmpl ([], (in_scope, expr))
1028 ---------------------------------------------------------
1029 -- Stop continuation
1031 do_rebuild expr Stop = rebuild_done expr
1034 ---------------------------------------------------------
1035 -- ArgOf continuation
1037 do_rebuild expr (ArgOf _ cont_fn _) = cont_fn expr
1039 ---------------------------------------------------------
1040 -- ApplyTo continuation
1042 do_rebuild expr cont@(ApplyTo _ arg se cont')
1044 Var v -> case getIdStrictness v of
1045 NoStrictnessInfo -> non_strict_case
1046 StrictnessInfo demands result_bot _ -> ASSERT( not (null demands) || result_bot )
1047 -- If this happened we'd get an infinite loop
1048 rebuild_strict demands result_bot expr (idType v) cont
1049 other -> non_strict_case
1051 non_strict_case = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
1052 do_rebuild (App expr arg') cont'
1055 ---------------------------------------------------------
1056 -- Coerce continuation
1058 do_rebuild expr (CoerceIt _ to_ty se cont)
1060 simplType to_ty `thenSmpl` \ to_ty' ->
1061 do_rebuild (mk_coerce to_ty' expr) cont
1063 mk_coerce to_ty' (Note (Coerce _ from_ty) expr) = Note (Coerce to_ty' from_ty) expr
1064 mk_coerce to_ty' expr = Note (Coerce to_ty' (coreExprType expr)) expr
1067 ---------------------------------------------------------
1068 -- Case of known constructor or literal
1070 do_rebuild expr@(Con con args) cont@(Select _ _ _ _ _)
1071 | conOkForAlt con -- Knocks out PrimOps and NoRepLits
1072 = knownCon expr con args cont
1075 ---------------------------------------------------------
1077 -- Case of other value (e.g. a partial application or lambda)
1078 -- Turn it back into a let
1080 do_rebuild expr (Select _ bndr ((DEFAULT, bs, rhs):alts) se cont)
1081 | case mkFormSummary expr of { ValueForm -> True; other -> False }
1082 = ASSERT( null bs && null alts )
1083 tick Case2Let `thenSmpl_`
1085 completeBindNonRec bndr expr $
1090 ---------------------------------------------------------
1091 -- The other Select cases
1093 do_rebuild scrut (Select _ bndr alts se cont)
1094 = getSwitchChecker `thenSmpl` \ chkr ->
1096 if all (cheapEqExpr rhs1) other_rhss
1097 && inlineCase bndr scrut
1098 && all binders_unused alts
1099 && switchIsOn chkr SimplDoCaseElim
1101 -- Get rid of the case altogether
1102 -- See the extensive notes on case-elimination below
1103 -- Remember to bind the binder though!
1104 tick CaseElim `thenSmpl_`
1106 extendIdSubst bndr (Done scrut) $
1107 simplExprB rhs1 cont
1111 rebuild_case chkr scrut bndr alts se cont
1113 (rhs1:other_rhss) = [rhs | (_,_,rhs) <- alts]
1114 binders_unused (_, bndrs, _) = all isDeadBinder bndrs
1117 Case elimination [see the code above]
1119 Start with a simple situation:
1121 case x# of ===> e[x#/y#]
1124 (when x#, y# are of primitive type, of course). We can't (in general)
1125 do this for algebraic cases, because we might turn bottom into
1128 Actually, we generalise this idea to look for a case where we're
1129 scrutinising a variable, and we know that only the default case can
1134 other -> ...(case x of
1138 Here the inner case can be eliminated. This really only shows up in
1139 eliminating error-checking code.
1141 We also make sure that we deal with this very common case:
1146 Here we are using the case as a strict let; if x is used only once
1147 then we want to inline it. We have to be careful that this doesn't
1148 make the program terminate when it would have diverged before, so we
1150 - x is used strictly, or
1151 - e is already evaluated (it may so if e is a variable)
1153 Lastly, we generalise the transformation to handle this:
1159 We only do this for very cheaply compared r's (constructors, literals
1160 and variables). If pedantic bottoms is on, we only do it when the
1161 scrutinee is a PrimOp which can't fail.
1163 We do it *here*, looking at un-simplified alternatives, because we
1164 have to check that r doesn't mention the variables bound by the
1165 pattern in each alternative, so the binder-info is rather useful.
1167 So the case-elimination algorithm is:
1169 1. Eliminate alternatives which can't match
1171 2. Check whether all the remaining alternatives
1172 (a) do not mention in their rhs any of the variables bound in their pattern
1173 and (b) have equal rhss
1175 3. Check we can safely ditch the case:
1176 * PedanticBottoms is off,
1177 or * the scrutinee is an already-evaluated variable
1178 or * the scrutinee is a primop which is ok for speculation
1179 -- ie we want to preserve divide-by-zero errors, and
1180 -- calls to error itself!
1182 or * [Prim cases] the scrutinee is a primitive variable
1184 or * [Alg cases] the scrutinee is a variable and
1185 either * the rhs is the same variable
1186 (eg case x of C a b -> x ===> x)
1187 or * there is only one alternative, the default alternative,
1188 and the binder is used strictly in its scope.
1189 [NB this is helped by the "use default binder where
1190 possible" transformation; see below.]
1193 If so, then we can replace the case with one of the rhss.
1197 ---------------------------------------------------------
1198 -- Rebuiling a function with strictness info
1200 rebuild_strict :: [Demand] -> Bool -- Stricness info
1201 -> OutExpr -> OutType -- Function and type
1202 -> SimplCont -- Continuation
1203 -> SimplM OutExprStuff
1205 rebuild_strict [] True fun fun_ty cont = rebuild_bot fun fun_ty cont
1206 rebuild_strict [] False fun fun_ty cont = do_rebuild fun cont
1208 rebuild_strict ds result_bot fun fun_ty (ApplyTo _ (Type ty_arg) se cont)
1209 -- Type arg; don't consume a demand
1210 = setSubstEnv se (simplType ty_arg) `thenSmpl` \ ty_arg' ->
1211 rebuild_strict ds result_bot (App fun (Type ty_arg'))
1212 (applyTy fun_ty ty_arg') cont
1214 rebuild_strict (d:ds) result_bot fun fun_ty (ApplyTo _ val_arg se cont)
1215 | isStrict d || isUnLiftedType arg_ty -- Strict value argument
1216 = getInScope `thenSmpl` \ in_scope ->
1218 cont_ty = contResultType in_scope res_ty cont
1220 setSubstEnv se (simplExprB val_arg (ArgOf NoDup cont_fn cont_ty))
1222 | otherwise -- Lazy value argument
1223 = setSubstEnv se (simplArg val_arg) `thenSmpl` \ val_arg' ->
1227 Just (arg_ty, res_ty) = splitFunTy_maybe fun_ty
1228 cont_fn arg' = rebuild_strict ds result_bot
1229 (App fun arg') res_ty
1232 rebuild_strict ds result_bot fun fun_ty cont = do_rebuild fun cont
1234 ---------------------------------------------------------
1236 -- * case (error "hello") of { ... }
1237 -- * (error "Hello") arg
1240 rebuild_bot expr expr_ty Stop -- No coerce needed
1243 rebuild_bot expr expr_ty (CoerceIt _ to_ty se Stop) -- Don't "tick" on this,
1244 -- else simplifier never stops
1246 simplType to_ty `thenSmpl` \ to_ty' ->
1247 rebuild_done (mkNote (Coerce to_ty' expr_ty) expr)
1249 rebuild_bot expr expr_ty cont
1250 = tick CaseOfError `thenSmpl_`
1251 getInScope `thenSmpl` \ in_scope ->
1253 result_ty = contResultType in_scope expr_ty cont
1255 rebuild_done (mkNote (Coerce result_ty expr_ty) expr)
1258 Blob of helper functions for the "case-of-something-else" situation.
1261 ---------------------------------------------------------
1262 -- Case of something else
1264 rebuild_case sw_chkr scrut case_bndr alts se cont
1265 = -- Prepare case alternatives
1266 prepareCaseAlts (splitTyConApp_maybe (idType case_bndr))
1267 scrut_cons alts `thenSmpl` \ better_alts ->
1269 -- Set the new subst-env in place (before dealing with the case binder)
1272 -- Deal with the case binder, and prepare the continuation;
1273 -- The new subst_env is in place
1274 simplBinder case_bndr $ \ case_bndr' ->
1275 prepareCaseCont better_alts cont $ \ cont' ->
1278 -- Deal with variable scrutinee
1279 substForVarScrut scrut case_bndr' $ \ zap_occ_info ->
1281 case_bndr'' = zap_occ_info case_bndr'
1284 -- Deal with the case alternaatives
1285 simplAlts zap_occ_info scrut_cons
1286 case_bndr'' better_alts cont' `thenSmpl` \ alts' ->
1288 mkCase sw_chkr scrut case_bndr'' alts' `thenSmpl` \ case_expr ->
1289 rebuild_done case_expr
1291 -- scrut_cons tells what constructors the scrutinee can't possibly match
1292 scrut_cons = case scrut of
1293 Var v -> case getIdUnfolding v of
1294 OtherCon cons -> cons
1299 knownCon expr con args (Select _ bndr alts se cont)
1300 = tick KnownBranch `thenSmpl_`
1302 case findAlt con alts of
1303 (DEFAULT, bs, rhs) -> ASSERT( null bs )
1304 completeBindNonRec bndr expr $
1307 (Literal lit, bs, rhs) -> ASSERT( null bs )
1308 extendIdSubst bndr (Done expr) $
1309 -- Unconditionally substitute, because expr must
1310 -- be a variable or a literal. It can't be a
1311 -- NoRep literal because they don't occur in
1315 (DataCon dc, bs, rhs) -> completeBindNonRec bndr expr $
1316 extend bs real_args $
1319 real_args = drop (dataConNumInstArgs dc) args
1322 extend [] [] thing_inside = thing_inside
1323 extend (b:bs) (arg:args) thing_inside = extendIdSubst b (Done arg) $
1324 extend bs args thing_inside
1328 prepareCaseCont :: [InAlt] -> SimplCont
1329 -> (SimplCont -> SimplM (OutStuff a))
1330 -> SimplM (OutStuff a)
1331 -- Polymorphic recursion here!
1333 prepareCaseCont [alt] cont thing_inside = thing_inside cont
1334 prepareCaseCont alts cont thing_inside = mkDupableCont (coreAltsType alts) cont thing_inside
1337 substForVarScrut checks whether the scrutinee is a variable, v.
1338 If so, try to eliminate uses of v in the RHSs in favour of case_bndr;
1339 that way, there's a chance that v will now only be used once, and hence inlined.
1341 If we do this, then we have to nuke any occurrence info (eg IAmDead)
1342 in the case binder, because the case-binder now effectively occurs
1343 whenever v does. AND we have to do the same for the pattern-bound
1346 (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
1348 Here, b and p are dead. But when we move the argment inside the first
1349 case RHS, and eliminate the second case, we get
1351 case x or { (a,b) -> a b
1353 Urk! b is alive! Reason: the scrutinee was a variable, and case elimination
1354 happened. Hence the zap_occ_info function returned by substForVarScrut
1357 substForVarScrut (Var v) case_bndr' thing_inside
1358 | isLocallyDefined v -- No point for imported things
1359 = modifyInScope (v `setIdUnfolding` mkUnfolding (Var case_bndr')
1360 `setInlinePragma` IMustBeINLINEd) $
1361 -- We could extend the substitution instead, but it would be
1362 -- a hack because then the substitution wouldn't be idempotent
1364 thing_inside (\ bndr -> bndr `setInlinePragma` NoInlinePragInfo)
1366 substForVarScrut other_scrut case_bndr' thing_inside
1367 = thing_inside (\ bndr -> bndr) -- NoOp on bndr
1370 prepareCaseAlts does two things:
1372 1. Remove impossible alternatives
1374 2. If the DEFAULT alternative can match only one possible constructor,
1375 then make that constructor explicit.
1377 case e of x { DEFAULT -> rhs }
1379 case e of x { (a,b) -> rhs }
1380 where the type is a single constructor type. This gives better code
1381 when rhs also scrutinises x or e.
1384 prepareCaseAlts (Just (tycon, inst_tys)) scrut_cons alts
1386 = case (findDefault filtered_alts, missing_cons) of
1388 ((alts_no_deflt, Just rhs), [data_con]) -- Just one missing constructor!
1389 -> tick FillInCaseDefault `thenSmpl_`
1391 (_,_,ex_tyvars,_,_,_) = dataConSig data_con
1393 getUniquesSmpl (length ex_tyvars) `thenSmpl` \ tv_uniqs ->
1395 ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars
1396 mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
1398 newIds (dataConArgTys
1400 (inst_tys ++ mkTyVarTys ex_tyvars')) $ \ bndrs ->
1401 returnSmpl ((DataCon data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt)
1403 other -> returnSmpl filtered_alts
1405 -- Filter out alternatives that can't possibly match
1406 filtered_alts = case scrut_cons of
1408 other -> [alt | alt@(con,_,_) <- alts, not (con `elem` scrut_cons)]
1410 missing_cons = [data_con | data_con <- tyConDataCons tycon,
1411 not (data_con `elem` handled_data_cons)]
1412 handled_data_cons = [data_con | DataCon data_con <- scrut_cons] ++
1413 [data_con | (DataCon data_con, _, _) <- filtered_alts]
1416 prepareCaseAlts _ scrut_cons alts
1417 = returnSmpl alts -- Functions
1420 ----------------------
1421 simplAlts zap_occ_info scrut_cons case_bndr'' alts cont'
1422 = mapSmpl simpl_alt alts
1424 inst_tys' = case splitTyConApp_maybe (idType case_bndr'') of
1425 Just (tycon, inst_tys) -> inst_tys
1427 -- handled_cons is all the constructors that are dealt
1428 -- with, either by being impossible, or by there being an alternative
1429 handled_cons = scrut_cons ++ [con | (con,_,_) <- alts, con /= DEFAULT]
1431 simpl_alt (DEFAULT, _, rhs)
1432 = modifyInScope (case_bndr'' `setIdUnfolding` OtherCon handled_cons) $
1433 simplExpr rhs cont' `thenSmpl` \ rhs' ->
1434 returnSmpl (DEFAULT, [], rhs')
1436 simpl_alt (con, vs, rhs)
1437 = -- Deal with the case-bound variables
1438 -- Mark the ones that are in ! positions in the data constructor
1439 -- as certainly-evaluated
1440 simplBinders (add_evals con vs) $ \ vs' ->
1442 -- Bind the case-binder to (Con args)
1443 -- In the default case we record the constructors it *can't* be.
1444 -- We take advantage of any OtherCon info in the case scrutinee
1446 con_app = Con con (map Type inst_tys' ++ map varToCoreExpr vs')
1448 modifyInScope (case_bndr'' `setIdUnfolding` mkUnfolding con_app) $
1449 simplExpr rhs cont' `thenSmpl` \ rhs' ->
1450 returnSmpl (con, vs', rhs')
1453 -- add_evals records the evaluated-ness of the bound variables of
1454 -- a case pattern. This is *important*. Consider
1455 -- data T = T !Int !Int
1457 -- case x of { T a b -> T (a+1) b }
1459 -- We really must record that b is already evaluated so that we don't
1460 -- go and re-evaluated it when constructing the result.
1462 add_evals (DataCon dc) vs = stretchZipEqual add_eval vs (dataConStrictMarks dc)
1463 add_evals other_con vs = vs
1465 add_eval v m | isTyVar v = Nothing
1466 | otherwise = case m of
1467 MarkedStrict -> Just (zap_occ_info v `setIdUnfolding` OtherCon [])
1468 NotMarkedStrict -> Just (zap_occ_info v)
1474 %************************************************************************
1476 \subsection{Duplicating continuations}
1478 %************************************************************************
1481 mkDupableCont :: InType -- Type of the thing to be given to the continuation
1483 -> (SimplCont -> SimplM (OutStuff a))
1484 -> SimplM (OutStuff a)
1485 mkDupableCont ty cont thing_inside
1486 | contIsDupable cont
1489 mkDupableCont _ (CoerceIt _ ty se cont) thing_inside
1490 = mkDupableCont ty cont $ \ cont' ->
1491 thing_inside (CoerceIt OkToDup ty se cont')
1493 mkDupableCont join_arg_ty (ArgOf _ cont_fn res_ty) thing_inside
1494 = -- Build the RHS of the join point
1495 simplType join_arg_ty `thenSmpl` \ join_arg_ty' ->
1496 newId join_arg_ty' ( \ arg_id ->
1497 getSwitchChecker `thenSmpl` \ chkr ->
1498 cont_fn (Var arg_id) `thenSmpl` \ (binds, (_, rhs)) ->
1499 returnSmpl (Lam arg_id (mkLetBinds binds rhs))
1500 ) `thenSmpl` \ join_rhs ->
1502 -- Build the join Id and continuation
1503 newId (coreExprType join_rhs) $ \ join_id ->
1505 new_cont = ArgOf OkToDup
1506 (\arg' -> rebuild_done (App (Var join_id) arg'))
1510 -- Do the thing inside
1511 thing_inside new_cont `thenSmpl` \ res ->
1512 returnSmpl (addBind (NonRec join_id join_rhs) res)
1514 mkDupableCont ty (ApplyTo _ arg se cont) thing_inside
1515 = mkDupableCont (funResultTy ty) cont $ \ cont' ->
1516 setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
1517 if exprIsDupable arg' then
1518 thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont')
1520 newId (coreExprType arg') $ \ bndr ->
1521 thing_inside (ApplyTo OkToDup (Var bndr) emptySubstEnv cont') `thenSmpl` \ res ->
1522 returnSmpl (addBind (NonRec bndr arg') res)
1524 mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside
1525 = tick CaseOfCase `thenSmpl_` (
1527 simplBinder case_bndr $ \ case_bndr' ->
1528 prepareCaseCont alts cont $ \ cont' ->
1529 mapAndUnzipSmpl (mkDupableAlt case_bndr' cont') alts `thenSmpl` \ (alt_binds_s, alts') ->
1530 returnSmpl (concat alt_binds_s, (case_bndr', alts'))
1531 ) `thenSmpl` \ (alt_binds, (case_bndr', alts')) ->
1533 extendInScopes [b | NonRec b _ <- alt_binds] $
1534 thing_inside (Select OkToDup case_bndr' alts' emptySubstEnv Stop) `thenSmpl` \ res ->
1535 returnSmpl (addBinds alt_binds res)
1538 mkDupableAlt :: OutId -> SimplCont -> InAlt -> SimplM (OutStuff CoreAlt)
1539 mkDupableAlt case_bndr' cont alt@(con, bndrs, rhs)
1540 = simplBinders bndrs $ \ bndrs' ->
1541 simplExpr rhs cont `thenSmpl` \ rhs' ->
1542 if exprIsDupable rhs' then
1543 -- It's small, so don't bother to let-bind it
1544 returnSmpl ([], (con, bndrs', rhs'))
1546 -- It's big, so let-bind it
1548 rhs_ty' = coreExprType rhs'
1549 used_bndrs' = filter (not . isDeadBinder) (case_bndr' : bndrs')
1551 ( if null used_bndrs' && isUnLiftedType rhs_ty'
1552 then newId realWorldStatePrimTy $ \ rw_id ->
1553 returnSmpl ([rw_id], [varToCoreExpr realWorldPrimId])
1555 returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
1557 `thenSmpl` \ (final_bndrs', final_args) ->
1559 -- If we try to lift a primitive-typed something out
1560 -- for let-binding-purposes, we will *caseify* it (!),
1561 -- with potentially-disastrous strictness results. So
1562 -- instead we turn it into a function: \v -> e
1563 -- where v::State# RealWorld#. The value passed to this function
1564 -- is realworld#, which generates (almost) no code.
1566 -- There's a slight infelicity here: we pass the overall
1567 -- case_bndr to all the join points if it's used in *any* RHS,
1568 -- because we don't know its usage in each RHS separately
1570 newId (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr ->
1571 returnSmpl ([NonRec join_bndr (mkLams final_bndrs' rhs')],
1572 (con, bndrs', mkApps (Var join_bndr) final_args))