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 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
430 CoreUnfolding form guidance unf_template = unfolding
432 -- overrides cost-centre business
433 must_be_unfolded = case getInlinePragma var of
434 IMustBeINLINEd -> True
437 ok_to_inline = okToInline sw_chkr in_scope var form guidance cont
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
459 var_is_case_scrutinee = case cont of
460 Select _ _ _ _ _ -> True
463 ----------- costCentreOk
464 -- costCentreOk checks that it's ok to inline this thing
465 -- The time it *isn't* is this:
467 -- f x = let y = E in
468 -- scc "foo" (...y...)
470 -- Here y has a "current cost centre", and we can't inline it inside "foo",
471 -- regardless of whether E is a WHNF or not.
473 costCentreOk ccs_encl cc_rhs
474 = not opt_SccProfilingOn
475 || isSubsumedCCS ccs_encl -- can unfold anything into a subsumed scope
476 || not (isEmptyCC cc_rhs) -- otherwise need a cc on the unfolding
480 %************************************************************************
482 \subsection{Bindings}
484 %************************************************************************
487 simplBind :: InBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
489 simplBind (NonRec bndr rhs) thing_inside
490 = simplTopRhs bndr rhs `thenSmpl` \ (binds, in_scope, rhs', arity) ->
491 setInScope in_scope $
492 completeBindNonRec (bndr `setIdArity` arity) rhs' thing_inside `thenSmpl` \ stuff ->
493 returnSmpl (addBinds binds stuff)
495 simplBind (Rec pairs) thing_inside
496 = simplRecBind pairs thing_inside
497 -- The assymetry between the two cases is a bit unclean
499 simplRecBind :: [(InId, InExpr)] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
500 simplRecBind pairs thing_inside
501 = simplIds (map fst pairs) $ \ bndrs' ->
502 -- NB: bndrs' don't have unfoldings or spec-envs
503 -- We add them as we go down, using simplPrags
505 go (pairs `zip` bndrs') `thenSmpl` \ (pairs', stuff) ->
506 returnSmpl (addBind (Rec pairs') stuff)
508 go [] = thing_inside `thenSmpl` \ stuff ->
509 returnSmpl ([], stuff)
511 go (((bndr, rhs), bndr') : pairs)
512 = simplTopRhs bndr rhs `thenSmpl` \ (rhs_binds, in_scope, rhs', arity) ->
513 setInScope in_scope $
514 completeBindRec bndr (bndr' `setIdArity` arity)
515 rhs' (go pairs) `thenSmpl` \ (pairs', stuff) ->
516 returnSmpl (flatten rhs_binds pairs', stuff)
518 flatten (NonRec b r : binds) prs = (b,r) : flatten binds prs
519 flatten (Rec prs1 : binds) prs2 = prs1 ++ flatten binds prs2
523 completeBindRec bndr bndr' rhs' thing_inside
524 | postInlineUnconditionally bndr etad_rhs
525 -- NB: a loop breaker never has postInlineUnconditionally True
526 -- and non-loop-breakers only have *forward* references
527 -- Hence, it's safe to discard the binding
528 = tick PostInlineUnconditionally `thenSmpl_`
529 extendIdSubst bndr (Done etad_rhs) thing_inside
532 = -- Here's the only difference from completeBindNonRec: we
533 -- don't do simplBinder first, because we've already
534 -- done simplBinder on the recursive binders
535 simplPrags bndr bndr' etad_rhs `thenSmpl` \ bndr'' ->
536 modifyInScope bndr'' $
537 thing_inside `thenSmpl` \ (pairs, res) ->
538 returnSmpl ((bndr'', etad_rhs) : pairs, res)
540 etad_rhs = etaCoreExpr rhs'
544 %************************************************************************
546 \subsection{Right hand sides}
548 %************************************************************************
550 simplRhs basically just simplifies the RHS of a let(rec).
551 It does two important optimisations though:
553 * It floats let(rec)s out of the RHS, even if they
554 are hidden by big lambdas
556 * It does eta expansion
559 simplTopRhs :: InId -> InExpr
560 -> SimplM ([OutBind], InScopeEnv, OutExpr, ArityInfo)
562 = getSubstEnv `thenSmpl` \ bndr_se ->
563 simplRhs bndr bndr_se rhs
565 simplRhs bndr bndr_se rhs
566 | idWantsToBeINLINEd bndr -- Don't inline in the RHS of something that has an
567 -- inline pragma. But be careful that the InScopeEnv that
568 -- we return does still have inlinings on!
569 = switchOffInlining (simplExpr rhs Stop) `thenSmpl` \ rhs' ->
570 getInScope `thenSmpl` \ in_scope ->
571 returnSmpl ([], in_scope, rhs', unknownArity)
574 = -- Swizzle the inner lets past the big lambda (if any)
575 mkRhsTyLam rhs `thenSmpl` \ swizzled_rhs ->
577 -- Simplify the swizzled RHS
578 simplRhs2 bndr bndr_se swizzled_rhs `thenSmpl` \ (floats, (in_scope, rhs', arity)) ->
580 if not (null floats) && exprIsWHNF rhs' then -- Do the float
581 tick LetFloatFromLet `thenSmpl_`
582 returnSmpl (floats, in_scope, rhs', arity)
584 getInScope `thenSmpl` \ in_scope ->
585 returnSmpl ([], in_scope, mkLetBinds floats rhs', arity)
588 ---------------------------------------------------------
589 Try eta expansion for RHSs
591 We need to pass in the substitution environment for the RHS, because
592 it might be different to the current one (see simplBeta, as called
593 from simplExpr for an applied lambda). The binder needs to
596 simplRhs2 bndr bndr_se (Let bind body)
597 = simplBind bind (simplRhs2 bndr bndr_se body)
599 simplRhs2 bndr bndr_se rhs
600 | null ids -- Prevent eta expansion for both thunks
601 -- (would lose sharing) and variables (nothing gained).
602 -- To see why we ignore it for thunks, consider
603 -- let f = lookup env key in (f 1, f 2)
604 -- We'd better not eta expand f just because it is
607 -- Also if there isn't a lambda at the top we use
608 -- simplExprB so that we can do (more) let-floating
609 = simplExprB rhs Stop `thenSmpl` \ (binds, (in_scope, rhs')) ->
610 returnSmpl (binds, (in_scope, rhs', unknownArity))
612 | otherwise -- Consider eta expansion
613 = getSwitchChecker `thenSmpl` \ sw_chkr ->
614 getInScope `thenSmpl` \ in_scope ->
615 simplBinders tyvars $ \ tyvars' ->
616 simplBinders ids $ \ ids' ->
618 if switchIsOn sw_chkr SimplDoLambdaEtaExpansion
619 && not (null extra_arg_tys)
621 tick EtaExpansion `thenSmpl_`
622 setSubstEnv bndr_se (mapSmpl simplType extra_arg_tys)
623 `thenSmpl` \ extra_arg_tys' ->
624 newIds extra_arg_tys' $ \ extra_bndrs' ->
625 simplExpr body (mk_cont extra_bndrs') `thenSmpl` \ body' ->
627 expanded_rhs = mkLams tyvars'
629 $ mkLams extra_bndrs' body'
630 expanded_arity = atLeastArity (no_of_ids + no_of_extras)
632 returnSmpl ([], (in_scope, expanded_rhs, expanded_arity))
635 simplExpr body Stop `thenSmpl` \ body' ->
637 unexpanded_rhs = mkLams tyvars'
639 unexpanded_arity = atLeastArity no_of_ids
641 returnSmpl ([], (in_scope, unexpanded_rhs, unexpanded_arity))
644 (tyvars, ids, body) = collectTyAndValBinders rhs
645 no_of_ids = length ids
647 potential_extra_arg_tys :: [InType] -- NB: InType
648 potential_extra_arg_tys = case splitFunTys (applyTys (idType bndr) (mkTyVarTys tyvars)) of
649 (arg_tys, _) -> drop no_of_ids arg_tys
651 extra_arg_tys :: [InType]
652 extra_arg_tys = take no_extras_wanted potential_extra_arg_tys
653 no_of_extras = length extra_arg_tys
655 no_extras_wanted = -- Use information about how many args the fn is applied to
656 (arity - no_of_ids) `max`
658 -- See if the body could obviously do with more args
659 etaExpandCount body `max`
661 -- Finally, see if it's a state transformer, in which
662 -- case we eta-expand on principle! This can waste work,
663 -- but usually doesn't
664 case potential_extra_arg_tys of
665 [ty] | ty == realWorldStatePrimTy -> 1
668 arity = arityLowerBound (getIdArity bndr)
671 mk_cont (b:bs) = ApplyTo OkToDup (Var b) emptySubstEnv (mk_cont bs)
675 %************************************************************************
679 %************************************************************************
682 simplBeta :: InId -- Binder
683 -> InExpr -> SubstEnv -- Arg, with its subst-env
684 -> InExpr -> SimplCont -- Lambda body
685 -> SimplM OutExprStuff
687 simplBeta bndr rhs rhs_se body cont
689 = pprPanic "simplBeta" ((ppr bndr <+> ppr rhs) $$ ppr cont)
692 simplBeta bndr rhs rhs_se body cont
693 | isUnLiftedType bndr_ty
694 || (isStrict (getIdDemandInfo bndr) || is_dict bndr) && not (exprIsWHNF rhs)
695 = tick Let2Case `thenSmpl_`
696 getSubstEnv `thenSmpl` \ body_se ->
698 simplExprB rhs (Select NoDup bndr [(DEFAULT, [], body)] body_se cont)
700 | preInlineUnconditionally bndr && not opt_NoPreInlining
701 = tick PreInlineUnconditionally `thenSmpl_`
702 case rhs_se of { (ty_subst, id_subst) ->
703 extendIdSubst bndr (SubstMe rhs ty_subst id_subst) $
704 simplExprB body cont }
707 = getSubstEnv `thenSmpl` \ bndr_se ->
708 setSubstEnv rhs_se (simplRhs bndr bndr_se rhs)
709 `thenSmpl` \ (floats, in_scope, rhs', arity) ->
710 setInScope in_scope $
711 completeBindNonRec (bndr `setIdArity` arity) rhs' (
713 ) `thenSmpl` \ stuff ->
714 returnSmpl (addBinds floats stuff)
716 -- Return true only for dictionary types where the dictionary
717 -- has more than one component (else we risk poking on the component
718 -- of a newtype dictionary)
719 is_dict bndr = opt_DictsStrict && isDictTy bndr_ty && isDataType bndr_ty
720 bndr_ty = idType bndr
725 - deals only with Ids, not TyVars
726 - take an already-simplified RHS
727 - always produce let bindings
729 It does *not* attempt to do let-to-case. Why? Because they are used for
732 (when let-to-case is impossible)
734 - many situations where the "rhs" is known to be a WHNF
735 (so let-to-case is inappropriate).
738 completeBindNonRec :: InId -- Binder
739 -> OutExpr -- Simplified RHS
740 -> SimplM (OutStuff a) -- Thing inside
741 -> SimplM (OutStuff a)
742 completeBindNonRec bndr rhs thing_inside
743 | isDeadBinder bndr -- This happens; for example, the case_bndr during case of
744 -- known constructor: case (a,b) of x { (p,q) -> ... }
745 -- Here x isn't mentioned in the RHS, so we don't want to
746 -- create the (dead) let-binding let x = (a,b) in ...
749 | postInlineUnconditionally bndr etad_rhs
750 = tick PostInlineUnconditionally `thenSmpl_`
751 extendIdSubst bndr (Done etad_rhs)
754 | otherwise -- Note that we use etad_rhs here
755 -- This gives maximum chance for a remaining binding
756 -- to be zapped by the indirection zapper in OccurAnal
757 = simplBinder bndr $ \ bndr' ->
758 simplPrags bndr bndr' etad_rhs `thenSmpl` \ bndr'' ->
759 modifyInScope bndr'' $
760 thing_inside `thenSmpl` \ stuff ->
761 returnSmpl (addBind (NonRec bndr'' etad_rhs) stuff)
763 etad_rhs = etaCoreExpr rhs
765 -- (simplPrags old_bndr new_bndr new_rhs) does two things
766 -- (a) it attaches the new unfolding to new_bndr
767 -- (b) it grabs the SpecEnv from old_bndr, applies the current
768 -- substitution to it, and attaches it to new_bndr
769 -- The assumption is that new_bndr, which is produced by simplBinder
770 -- has no unfolding or specenv.
772 simplPrags old_bndr new_bndr new_rhs
773 | isEmptySpecEnv spec_env
774 = returnSmpl (bndr_w_unfolding)
777 = getSimplBinderStuff `thenSmpl` \ (ty_subst, id_subst, in_scope, us) ->
779 spec_env' = substSpecEnv ty_subst in_scope (subst_val id_subst) spec_env
780 final_bndr = bndr_w_unfolding `setIdSpecialisation` spec_env'
782 returnSmpl final_bndr
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
899 if opt_D_dump_inlinings then
900 pprTrace "Considering inlining"
901 (ppr id <+> vcat [text "inline prag:" <+> ppr inline_prag,
902 text "whnf" <+> ppr whnf,
903 text "small enough" <+> ppr small_enough,
904 text "some benefit" <+> ppr some_benefit,
905 text "arg evals" <+> ppr arg_evals,
906 text "result scrut" <+> ppr result_scrut,
907 text "ANSWER =" <+> if result then text "YES" else text "NO"])
915 IAmDead -> pprTrace "okToInline: dead" (ppr id) False
916 IAmASpecPragmaId -> False
917 IMustNotBeINLINEd -> False
918 IAmALoopBreaker -> False
919 IMustBeINLINEd -> True -- If "essential_unfoldings_only" is true we do no inlinings at all,
920 -- EXCEPT for things that absolutely have to be done
921 -- (see comments with idMustBeINLINEd)
922 IWantToBeINLINEd -> inlinings_enabled
923 ICanSafelyBeINLINEd inside_lam one_branch
924 -> inlinings_enabled && (unfold_always || consider_single inside_lam one_branch)
925 NoInlinePragInfo -> inlinings_enabled && (unfold_always || consider_multi)
927 inlinings_enabled = not (switchIsOn sw_chkr EssentialUnfoldingsOnly)
928 unfold_always = unfoldAlways guidance
930 -- Consider benefit for ICanSafelyBeINLINEd
931 consider_single inside_lam one_branch
932 = (small_enough || one_branch) && some_benefit && (whnf || not_inside_lam)
934 not_inside_lam = case inside_lam of {InsideLam -> False; other -> True}
936 -- Consider benefit for NoInlinePragInfo
937 consider_multi = whnf && small_enough && some_benefit
938 -- We could consider using exprIsCheap here,
939 -- as in postInlineUnconditionally, but unlike the latter we wouldn't
940 -- necessarily eliminate a thunk; and the "form" doesn't tell
943 inline_prag = getInlinePragma id
944 whnf = whnfOrBottom form
945 small_enough = smallEnoughToInline id arg_evals result_scrut guidance
946 (arg_evals, result_scrut) = get_evals cont
948 -- some_benefit checks that *something* interesting happens to
949 -- the variable after it's inlined.
950 some_benefit = contIsInteresting cont
952 -- Finding out whether the args are evaluated. This isn't completely easy
953 -- because the args are not yet simplified, so we have to peek into them.
954 get_evals (ApplyTo _ arg (te,ve) cont)
955 | isValArg arg = case get_evals cont of
956 (args, res) -> (get_arg_eval arg ve : args, res)
957 | otherwise = get_evals cont
959 get_evals (Select _ _ _ _ _) = ([], True)
960 get_evals other = ([], False)
962 get_arg_eval (Con con _) ve = isWHNFCon con
963 get_arg_eval (Var v) ve = case lookupVarEnv ve v of
964 Just (SubstMe e' _ ve') -> get_arg_eval e' ve'
965 Just (Done (Con con _)) -> isWHNFCon con
966 Just (Done (Var v')) -> get_var_eval v'
967 Just (Done other) -> False
968 Nothing -> get_var_eval v
969 get_arg_eval other ve = False
971 get_var_eval v = case lookupVarSet in_scope v of
972 Just v' -> isEvaldUnfolding (getIdUnfolding v')
973 Nothing -> isEvaldUnfolding (getIdUnfolding v)
976 contIsInteresting :: SimplCont -> Bool
977 contIsInteresting Stop = False
978 contIsInteresting (ArgOf _ _ _) = False
979 contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont
980 contIsInteresting (CoerceIt _ _ _ cont) = contIsInteresting cont
982 -- See notes below on why a case with only a DEFAULT case is not intersting
983 -- contIsInteresting (Select _ _ [(DEFAULT,_,_)] _ _) = False
985 contIsInteresting _ = True
988 Comment about some_benefit above
989 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
991 We want to avoid inlining an expression where there can't possibly be
992 any gain, such as in an argument position. Hence, if the continuation
993 is interesting (eg. a case scrutinee, application etc.) then we
994 inline, otherwise we don't.
996 Previously some_benefit used to return True only if the variable was
997 applied to some value arguments. This didn't work:
999 let x = _coerce_ (T Int) Int (I# 3) in
1000 case _coerce_ Int (T Int) x of
1003 we want to inline x, but can't see that it's a constructor in a case
1004 scrutinee position, and some_benefit is False.
1008 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
1010 .... case dMonadST _@_ x0 of (a,b,c) -> ....
1012 we'd really like to inline dMonadST here, but we *don't* want to
1013 inline if the case expression is just
1015 case x of y { DEFAULT -> ... }
1017 since we can just eliminate this case instead (x is in WHNF). Similar
1018 applies when x is bound to a lambda expression. Hence
1019 contIsInteresting looks for case expressions with just a single
1023 %************************************************************************
1025 \subsection{The main rebuilder}
1027 %************************************************************************
1030 -------------------------------------------------------------------
1031 rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff
1034 = tick LeavesExamined `thenSmpl_`
1035 do_rebuild expr cont
1038 = getInScope `thenSmpl` \ in_scope ->
1039 returnSmpl ([], (in_scope, expr))
1041 ---------------------------------------------------------
1042 -- Stop continuation
1044 do_rebuild expr Stop = rebuild_done expr
1047 ---------------------------------------------------------
1048 -- ArgOf continuation
1050 do_rebuild expr (ArgOf _ cont_fn _) = cont_fn expr
1052 ---------------------------------------------------------
1053 -- ApplyTo continuation
1055 do_rebuild expr cont@(ApplyTo _ arg se cont')
1057 Var v -> case getIdStrictness v of
1058 NoStrictnessInfo -> non_strict_case
1059 StrictnessInfo demands result_bot _ -> ASSERT( not (null demands) || result_bot )
1060 -- If this happened we'd get an infinite loop
1061 rebuild_strict demands result_bot expr (idType v) cont
1062 other -> non_strict_case
1064 non_strict_case = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
1065 do_rebuild (App expr arg') cont'
1068 ---------------------------------------------------------
1069 -- Coerce continuation
1071 do_rebuild expr (CoerceIt _ to_ty se cont)
1073 simplType to_ty `thenSmpl` \ to_ty' ->
1074 do_rebuild (mk_coerce to_ty' expr) cont
1076 mk_coerce to_ty' (Note (Coerce _ from_ty) expr) = Note (Coerce to_ty' from_ty) expr
1077 mk_coerce to_ty' expr = Note (Coerce to_ty' (coreExprType expr)) expr
1080 ---------------------------------------------------------
1081 -- Case of known constructor or literal
1083 do_rebuild expr@(Con con args) cont@(Select _ _ _ _ _)
1084 | conOkForAlt con -- Knocks out PrimOps and NoRepLits
1085 = knownCon expr con args cont
1088 ---------------------------------------------------------
1090 -- Case of other value (e.g. a partial application or lambda)
1091 -- Turn it back into a let
1093 do_rebuild expr (Select _ bndr ((DEFAULT, bs, rhs):alts) se cont)
1094 | case mkFormSummary expr of { ValueForm -> True; other -> False }
1095 = ASSERT( null bs && null alts )
1096 tick Case2Let `thenSmpl_`
1098 completeBindNonRec bndr expr $
1103 ---------------------------------------------------------
1104 -- The other Select cases
1106 do_rebuild scrut (Select _ bndr alts se cont)
1107 = getSwitchChecker `thenSmpl` \ chkr ->
1109 if all (cheapEqExpr rhs1) other_rhss
1110 && inlineCase bndr scrut
1111 && all binders_unused alts
1112 && switchIsOn chkr SimplDoCaseElim
1114 -- Get rid of the case altogether
1115 -- See the extensive notes on case-elimination below
1116 -- Remember to bind the binder though!
1117 tick CaseElim `thenSmpl_`
1119 extendIdSubst bndr (Done scrut) $
1120 simplExprB rhs1 cont
1124 rebuild_case chkr scrut bndr alts se cont
1126 (rhs1:other_rhss) = [rhs | (_,_,rhs) <- alts]
1127 binders_unused (_, bndrs, _) = all isDeadBinder bndrs
1130 Case elimination [see the code above]
1132 Start with a simple situation:
1134 case x# of ===> e[x#/y#]
1137 (when x#, y# are of primitive type, of course). We can't (in general)
1138 do this for algebraic cases, because we might turn bottom into
1141 Actually, we generalise this idea to look for a case where we're
1142 scrutinising a variable, and we know that only the default case can
1147 other -> ...(case x of
1151 Here the inner case can be eliminated. This really only shows up in
1152 eliminating error-checking code.
1154 We also make sure that we deal with this very common case:
1159 Here we are using the case as a strict let; if x is used only once
1160 then we want to inline it. We have to be careful that this doesn't
1161 make the program terminate when it would have diverged before, so we
1163 - x is used strictly, or
1164 - e is already evaluated (it may so if e is a variable)
1166 Lastly, we generalise the transformation to handle this:
1172 We only do this for very cheaply compared r's (constructors, literals
1173 and variables). If pedantic bottoms is on, we only do it when the
1174 scrutinee is a PrimOp which can't fail.
1176 We do it *here*, looking at un-simplified alternatives, because we
1177 have to check that r doesn't mention the variables bound by the
1178 pattern in each alternative, so the binder-info is rather useful.
1180 So the case-elimination algorithm is:
1182 1. Eliminate alternatives which can't match
1184 2. Check whether all the remaining alternatives
1185 (a) do not mention in their rhs any of the variables bound in their pattern
1186 and (b) have equal rhss
1188 3. Check we can safely ditch the case:
1189 * PedanticBottoms is off,
1190 or * the scrutinee is an already-evaluated variable
1191 or * the scrutinee is a primop which is ok for speculation
1192 -- ie we want to preserve divide-by-zero errors, and
1193 -- calls to error itself!
1195 or * [Prim cases] the scrutinee is a primitive variable
1197 or * [Alg cases] the scrutinee is a variable and
1198 either * the rhs is the same variable
1199 (eg case x of C a b -> x ===> x)
1200 or * there is only one alternative, the default alternative,
1201 and the binder is used strictly in its scope.
1202 [NB this is helped by the "use default binder where
1203 possible" transformation; see below.]
1206 If so, then we can replace the case with one of the rhss.
1210 ---------------------------------------------------------
1211 -- Rebuiling a function with strictness info
1213 rebuild_strict :: [Demand] -> Bool -- Stricness info
1214 -> OutExpr -> OutType -- Function and type
1215 -> SimplCont -- Continuation
1216 -> SimplM OutExprStuff
1218 rebuild_strict [] True fun fun_ty cont = rebuild_bot fun fun_ty cont
1219 rebuild_strict [] False fun fun_ty cont = do_rebuild fun cont
1221 rebuild_strict ds result_bot fun fun_ty (ApplyTo _ (Type ty_arg) se cont)
1222 -- Type arg; don't consume a demand
1223 = setSubstEnv se (simplType ty_arg) `thenSmpl` \ ty_arg' ->
1224 rebuild_strict ds result_bot (App fun (Type ty_arg'))
1225 (applyTy fun_ty ty_arg') cont
1227 rebuild_strict (d:ds) result_bot fun fun_ty (ApplyTo _ val_arg se cont)
1228 | isStrict d || isUnLiftedType arg_ty -- Strict value argument
1229 = getInScope `thenSmpl` \ in_scope ->
1231 cont_ty = contResultType in_scope res_ty cont
1233 setSubstEnv se (simplExprB val_arg (ArgOf NoDup cont_fn cont_ty))
1235 | otherwise -- Lazy value argument
1236 = setSubstEnv se (simplArg val_arg) `thenSmpl` \ val_arg' ->
1240 Just (arg_ty, res_ty) = splitFunTy_maybe fun_ty
1241 cont_fn arg' = rebuild_strict ds result_bot
1242 (App fun arg') res_ty
1245 rebuild_strict ds result_bot fun fun_ty cont = do_rebuild fun cont
1247 ---------------------------------------------------------
1249 -- * case (error "hello") of { ... }
1250 -- * (error "Hello") arg
1253 rebuild_bot expr expr_ty Stop -- No coerce needed
1256 rebuild_bot expr expr_ty (CoerceIt _ to_ty se Stop) -- Don't "tick" on this,
1257 -- else simplifier never stops
1259 simplType to_ty `thenSmpl` \ to_ty' ->
1260 rebuild_done (mkNote (Coerce to_ty' expr_ty) expr)
1262 rebuild_bot expr expr_ty cont
1263 = tick CaseOfError `thenSmpl_`
1264 getInScope `thenSmpl` \ in_scope ->
1266 result_ty = contResultType in_scope expr_ty cont
1268 rebuild_done (mkNote (Coerce result_ty expr_ty) expr)
1271 Blob of helper functions for the "case-of-something-else" situation.
1274 ---------------------------------------------------------
1275 -- Case of something else
1277 rebuild_case sw_chkr scrut case_bndr alts se cont
1278 = -- Prepare case alternatives
1279 prepareCaseAlts (splitTyConApp_maybe (idType case_bndr))
1280 scrut_cons alts `thenSmpl` \ better_alts ->
1282 -- Set the new subst-env in place (before dealing with the case binder)
1285 -- Deal with the case binder, and prepare the continuation;
1286 -- The new subst_env is in place
1287 simplBinder case_bndr $ \ case_bndr' ->
1288 prepareCaseCont better_alts cont $ \ cont' ->
1291 -- Deal with variable scrutinee
1292 substForVarScrut scrut case_bndr' $ \ zap_occ_info ->
1294 case_bndr'' = zap_occ_info case_bndr'
1297 -- Deal with the case alternaatives
1298 simplAlts zap_occ_info scrut_cons
1299 case_bndr'' better_alts cont' `thenSmpl` \ alts' ->
1301 mkCase sw_chkr scrut case_bndr'' alts' `thenSmpl` \ case_expr ->
1302 rebuild_done case_expr
1304 -- scrut_cons tells what constructors the scrutinee can't possibly match
1305 scrut_cons = case scrut of
1306 Var v -> case getIdUnfolding v of
1307 OtherCon cons -> cons
1312 knownCon expr con args (Select _ bndr alts se cont)
1313 = tick KnownBranch `thenSmpl_`
1315 case findAlt con alts of
1316 (DEFAULT, bs, rhs) -> ASSERT( null bs )
1317 completeBindNonRec bndr expr $
1320 (Literal lit, bs, rhs) -> ASSERT( null bs )
1321 extendIdSubst bndr (Done expr) $
1322 -- Unconditionally substitute, because expr must
1323 -- be a variable or a literal. It can't be a
1324 -- NoRep literal because they don't occur in
1328 (DataCon dc, bs, rhs) -> completeBindNonRec bndr expr $
1329 extend bs real_args $
1332 real_args = drop (dataConNumInstArgs dc) args
1335 extend [] [] thing_inside = thing_inside
1336 extend (b:bs) (arg:args) thing_inside = extendIdSubst b (Done arg) $
1337 extend bs args thing_inside
1341 prepareCaseCont :: [InAlt] -> SimplCont
1342 -> (SimplCont -> SimplM (OutStuff a))
1343 -> SimplM (OutStuff a)
1344 -- Polymorphic recursion here!
1346 prepareCaseCont [alt] cont thing_inside = thing_inside cont
1347 prepareCaseCont alts cont thing_inside = mkDupableCont (coreAltsType alts) cont thing_inside
1350 substForVarScrut checks whether the scrutinee is a variable, v.
1351 If so, try to eliminate uses of v in the RHSs in favour of case_bndr;
1352 that way, there's a chance that v will now only be used once, and hence inlined.
1354 If we do this, then we have to nuke any occurrence info (eg IAmDead)
1355 in the case binder, because the case-binder now effectively occurs
1356 whenever v does. AND we have to do the same for the pattern-bound
1359 (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
1361 Here, b and p are dead. But when we move the argment inside the first
1362 case RHS, and eliminate the second case, we get
1364 case x or { (a,b) -> a b
1366 Urk! b is alive! Reason: the scrutinee was a variable, and case elimination
1367 happened. Hence the zap_occ_info function returned by substForVarScrut
1370 substForVarScrut (Var v) case_bndr' thing_inside
1371 | isLocallyDefined v -- No point for imported things
1372 = modifyInScope (v `setIdUnfolding` mkUnfolding (Var case_bndr')
1373 `setInlinePragma` IMustBeINLINEd) $
1374 -- We could extend the substitution instead, but it would be
1375 -- a hack because then the substitution wouldn't be idempotent
1377 thing_inside (\ bndr -> bndr `setInlinePragma` NoInlinePragInfo)
1379 substForVarScrut other_scrut case_bndr' thing_inside
1380 = thing_inside (\ bndr -> bndr) -- NoOp on bndr
1383 prepareCaseAlts does two things:
1385 1. Remove impossible alternatives
1387 2. If the DEFAULT alternative can match only one possible constructor,
1388 then make that constructor explicit.
1390 case e of x { DEFAULT -> rhs }
1392 case e of x { (a,b) -> rhs }
1393 where the type is a single constructor type. This gives better code
1394 when rhs also scrutinises x or e.
1397 prepareCaseAlts (Just (tycon, inst_tys)) scrut_cons alts
1399 = case (findDefault filtered_alts, missing_cons) of
1401 ((alts_no_deflt, Just rhs), [data_con]) -- Just one missing constructor!
1402 -> tick FillInCaseDefault `thenSmpl_`
1404 (_,_,ex_tyvars,_,_,_) = dataConSig data_con
1406 getUniquesSmpl (length ex_tyvars) `thenSmpl` \ tv_uniqs ->
1408 ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars
1409 mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
1411 newIds (dataConArgTys
1413 (inst_tys ++ mkTyVarTys ex_tyvars')) $ \ bndrs ->
1414 returnSmpl ((DataCon data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt)
1416 other -> returnSmpl filtered_alts
1418 -- Filter out alternatives that can't possibly match
1419 filtered_alts = case scrut_cons of
1421 other -> [alt | alt@(con,_,_) <- alts, not (con `elem` scrut_cons)]
1423 missing_cons = [data_con | data_con <- tyConDataCons tycon,
1424 not (data_con `elem` handled_data_cons)]
1425 handled_data_cons = [data_con | DataCon data_con <- scrut_cons] ++
1426 [data_con | (DataCon data_con, _, _) <- filtered_alts]
1429 prepareCaseAlts _ scrut_cons alts
1430 = returnSmpl alts -- Functions
1433 ----------------------
1434 simplAlts zap_occ_info scrut_cons case_bndr'' alts cont'
1435 = mapSmpl simpl_alt alts
1437 inst_tys' = case splitTyConApp_maybe (idType case_bndr'') of
1438 Just (tycon, inst_tys) -> inst_tys
1440 -- handled_cons is all the constructors that are dealt
1441 -- with, either by being impossible, or by there being an alternative
1442 handled_cons = scrut_cons ++ [con | (con,_,_) <- alts, con /= DEFAULT]
1444 simpl_alt (DEFAULT, _, rhs)
1445 = -- In the default case we record the constructors that the
1446 -- case-binder *can't* be.
1447 -- We take advantage of any OtherCon info in the case scrutinee
1448 modifyInScope (case_bndr'' `setIdUnfolding` OtherCon handled_cons) $
1449 simplExpr rhs cont' `thenSmpl` \ rhs' ->
1450 returnSmpl (DEFAULT, [], rhs')
1452 simpl_alt (con, vs, rhs)
1453 = -- Deal with the pattern-bound variables
1454 -- Mark the ones that are in ! positions in the data constructor
1455 -- as certainly-evaluated
1456 simplBinders (add_evals con vs) $ \ vs' ->
1458 -- Bind the case-binder to (Con args)
1460 con_app = Con con (map Type inst_tys' ++ map varToCoreExpr vs')
1462 modifyInScope (case_bndr'' `setIdUnfolding` mkUnfolding con_app) $
1463 simplExpr rhs cont' `thenSmpl` \ rhs' ->
1464 returnSmpl (con, vs', rhs')
1467 -- add_evals records the evaluated-ness of the bound variables of
1468 -- a case pattern. This is *important*. Consider
1469 -- data T = T !Int !Int
1471 -- case x of { T a b -> T (a+1) b }
1473 -- We really must record that b is already evaluated so that we don't
1474 -- go and re-evaluated it when constructing the result.
1476 add_evals (DataCon dc) vs = stretchZipEqual add_eval vs (dataConStrictMarks dc)
1477 add_evals other_con vs = vs
1479 add_eval v m | isTyVar v = Nothing
1480 | otherwise = case m of
1481 MarkedStrict -> Just (zap_occ_info v `setIdUnfolding` OtherCon [])
1482 NotMarkedStrict -> Just (zap_occ_info v)
1488 %************************************************************************
1490 \subsection{Duplicating continuations}
1492 %************************************************************************
1495 mkDupableCont :: InType -- Type of the thing to be given to the continuation
1497 -> (SimplCont -> SimplM (OutStuff a))
1498 -> SimplM (OutStuff a)
1499 mkDupableCont ty cont thing_inside
1500 | contIsDupable cont
1503 mkDupableCont _ (CoerceIt _ ty se cont) thing_inside
1504 = mkDupableCont ty cont $ \ cont' ->
1505 thing_inside (CoerceIt OkToDup ty se cont')
1507 mkDupableCont join_arg_ty (ArgOf _ cont_fn res_ty) thing_inside
1508 = -- Build the RHS of the join point
1509 simplType join_arg_ty `thenSmpl` \ join_arg_ty' ->
1510 newId join_arg_ty' ( \ arg_id ->
1511 getSwitchChecker `thenSmpl` \ chkr ->
1512 cont_fn (Var arg_id) `thenSmpl` \ (binds, (_, rhs)) ->
1513 returnSmpl (Lam arg_id (mkLetBinds binds rhs))
1514 ) `thenSmpl` \ join_rhs ->
1516 -- Build the join Id and continuation
1517 newId (coreExprType join_rhs) $ \ join_id ->
1519 new_cont = ArgOf OkToDup
1520 (\arg' -> rebuild_done (App (Var join_id) arg'))
1524 -- Do the thing inside
1525 thing_inside new_cont `thenSmpl` \ res ->
1526 returnSmpl (addBind (NonRec join_id join_rhs) res)
1528 mkDupableCont ty (ApplyTo _ arg se cont) thing_inside
1529 = mkDupableCont (funResultTy ty) cont $ \ cont' ->
1530 setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
1531 if exprIsDupable arg' then
1532 thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont')
1534 newId (coreExprType arg') $ \ bndr ->
1535 thing_inside (ApplyTo OkToDup (Var bndr) emptySubstEnv cont') `thenSmpl` \ res ->
1536 returnSmpl (addBind (NonRec bndr arg') res)
1538 mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside
1539 = tick CaseOfCase `thenSmpl_` (
1541 simplBinder case_bndr $ \ case_bndr' ->
1542 prepareCaseCont alts cont $ \ cont' ->
1543 mapAndUnzipSmpl (mkDupableAlt case_bndr' cont') alts `thenSmpl` \ (alt_binds_s, alts') ->
1544 returnSmpl (concat alt_binds_s, (case_bndr', alts'))
1545 ) `thenSmpl` \ (alt_binds, (case_bndr', alts')) ->
1547 extendInScopes [b | NonRec b _ <- alt_binds] $
1548 thing_inside (Select OkToDup case_bndr' alts' emptySubstEnv Stop) `thenSmpl` \ res ->
1549 returnSmpl (addBinds alt_binds res)
1552 mkDupableAlt :: OutId -> SimplCont -> InAlt -> SimplM (OutStuff CoreAlt)
1553 mkDupableAlt case_bndr' cont alt@(con, bndrs, rhs)
1554 = simplBinders bndrs $ \ bndrs' ->
1555 simplExpr rhs cont `thenSmpl` \ rhs' ->
1556 if exprIsDupable rhs' then
1557 -- It's small, so don't bother to let-bind it
1558 returnSmpl ([], (con, bndrs', rhs'))
1560 -- It's big, so let-bind it
1562 rhs_ty' = coreExprType rhs'
1563 used_bndrs' = filter (not . isDeadBinder) (case_bndr' : bndrs')
1565 ( if null used_bndrs' && isUnLiftedType rhs_ty'
1566 then newId realWorldStatePrimTy $ \ rw_id ->
1567 returnSmpl ([rw_id], [varToCoreExpr realWorldPrimId])
1569 returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
1571 `thenSmpl` \ (final_bndrs', final_args) ->
1573 -- If we try to lift a primitive-typed something out
1574 -- for let-binding-purposes, we will *caseify* it (!),
1575 -- with potentially-disastrous strictness results. So
1576 -- instead we turn it into a function: \v -> e
1577 -- where v::State# RealWorld#. The value passed to this function
1578 -- is realworld#, which generates (almost) no code.
1580 -- There's a slight infelicity here: we pass the overall
1581 -- case_bndr to all the join points if it's used in *any* RHS,
1582 -- because we don't know its usage in each RHS separately
1584 newId (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr ->
1585 returnSmpl ([NonRec join_bndr (mkLams final_bndrs' rhs')],
1586 (con, bndrs', mkApps (Var join_bndr) final_args))