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 )
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
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 -- Main game plan: loop through the arguments, simplifying
145 -- each of them with an ArgOf continuation. Getting the right
146 -- cont_ty in the ArgOf continuation is a bit of a nuisance.
147 go [] args' = rebuild_primop (reverse args')
148 go (arg:args) args' = setSubstEnv se (simplExprB arg (mk_cont args args'))
150 cont_ty = contResultType in_scope expr_ty cont
151 mk_cont args args' = ArgOf NoDup (\ arg' -> go args (arg':args')) cont_ty
157 = -- Try the prim op simplification
158 -- It's really worth trying simplExpr again if it succeeds,
159 -- because you can find
160 -- case (eqChar# x 'a') of ...
162 -- case (case x of 'a' -> True; other -> False) of ...
163 case tryPrimOp op args' of
164 Just e' -> zapSubstEnv (simplExprB e' cont)
165 Nothing -> rebuild (Con (PrimOp op) args') cont
167 simplExprB (Con con@(DataCon _) args) cont
168 = simplConArgs args $ \ args' ->
169 rebuild (Con con args') cont
171 simplExprB expr@(Con con@(Literal _) args) cont
172 = ASSERT( null args )
175 simplExprB (App fun arg) cont
176 = getSubstEnv `thenSmpl` \ se ->
177 simplExprB fun (ApplyTo NoDup arg se cont)
179 simplExprB (Case scrut bndr alts) cont
180 = getSubstEnv `thenSmpl` \ se ->
181 simplExprB scrut (Select NoDup bndr alts se cont)
183 simplExprB (Note (Coerce to from) e) cont
184 | to == from = simplExprB e cont
185 | otherwise = getSubstEnv `thenSmpl` \ se ->
186 simplExprB e (CoerceIt NoDup to se cont)
188 -- hack: we only distinguish subsumed cost centre stacks for the purposes of
189 -- inlining. All other CCCSs are mapped to currentCCS.
190 simplExprB (Note (SCC cc) e) cont
191 = setEnclosingCC currentCCS $
192 simplExpr e Stop `thenSmpl` \ e ->
193 rebuild (mkNote (SCC cc) e) cont
195 simplExprB (Note note e) cont
196 = simplExpr e Stop `thenSmpl` \ e' ->
197 rebuild (mkNote note e') cont
199 -- Let to case, but only if the RHS isn't a WHNF
200 simplExprB (Let (NonRec bndr rhs) body) cont
201 = getSubstEnv `thenSmpl` \ se ->
202 simplBeta bndr rhs se body cont
204 simplExprB (Let bind body) cont
205 = simplBind bind (simplExprB body cont) `thenSmpl` \ (binds, stuff) ->
206 returnSmpl (addBinds binds stuff)
208 -- Type-beta reduction
209 simplExprB expr@(Lam bndr body) cont@(ApplyTo _ (Type ty_arg) arg_se body_cont)
210 = ASSERT( isTyVar bndr )
211 tick BetaReduction `thenSmpl_`
212 setSubstEnv arg_se (simplType ty_arg) `thenSmpl` \ ty' ->
213 extendTySubst bndr ty' $
214 simplExprB body body_cont
216 -- Ordinary beta reduction
217 simplExprB expr@(Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
218 = tick BetaReduction `thenSmpl_`
219 simplBeta bndr' arg arg_se body body_cont
221 bndr' = zapLambdaBndr bndr body body_cont
223 simplExprB (Lam bndr body) cont
224 = simplBinder bndr $ \ bndr' ->
225 simplExpr body Stop `thenSmpl` \ body' ->
226 rebuild (Lam bndr' body') cont
228 simplExprB (Type ty) cont
229 = ASSERT( case cont of { Stop -> True; ArgOf _ _ _ -> True; other -> False } )
230 simplType ty `thenSmpl` \ ty' ->
231 rebuild (Type ty') cont
235 ---------------------------------
237 simplArg :: InArg -> SimplM OutArg
238 simplArg arg = simplExpr arg Stop
241 ---------------------------------
242 simplConArgs makes sure that the arguments all end up being atomic.
243 That means it may generate some Lets, hence the
246 simplConArgs :: [InArg] -> ([OutArg] -> SimplM OutExprStuff) -> SimplM OutExprStuff
247 simplConArgs [] thing_inside
250 simplConArgs (arg:args) thing_inside
251 = switchOffInlining (simplArg arg) `thenSmpl` \ arg' ->
252 -- Simplify the RHS with inlining switched off, so that
253 -- only absolutely essential things will happen.
255 simplConArgs args $ \ args' ->
257 -- If the argument ain't trivial, then let-bind it
258 if exprIsTrivial arg' then
259 thing_inside (arg' : args')
261 newId (coreExprType arg') $ \ arg_id ->
262 thing_inside (Var arg_id : args') `thenSmpl` \ res ->
263 returnSmpl (addBind (NonRec arg_id arg') res)
267 ---------------------------------
269 simplType :: InType -> SimplM OutType
271 = getTyEnv `thenSmpl` \ (ty_subst, in_scope) ->
272 returnSmpl (fullSubstTy ty_subst in_scope ty)
277 -- Find out whether the lambda is saturated,
278 -- if not zap the over-optimistic info in the binder
280 zapLambdaBndr bndr body body_cont
281 | isTyVar bndr || safe_info || definitely_saturated 20 body body_cont
282 -- The "20" is to catch pathalogical cases with bazillions of arguments
283 -- because we are using an n**2 algorithm here
284 = bndr -- No need to zap
286 = setInlinePragma (setIdDemandInfo bndr wwLazy)
290 inline_prag = getInlinePragma bndr
291 demand = getIdDemandInfo bndr
293 safe_info = is_safe_inline_prag && not (isStrict demand)
295 is_safe_inline_prag = case inline_prag of
296 ICanSafelyBeINLINEd StrictOcc nalts -> False
297 ICanSafelyBeINLINEd LazyOcc nalts -> False
300 safe_inline_prag = case inline_prag of
301 ICanSafelyBeINLINEd _ nalts
302 -> ICanSafelyBeINLINEd InsideLam nalts
305 definitely_saturated 0 _ _ = False -- Too expensive to find out
306 definitely_saturated n (Lam _ body) (ApplyTo _ _ _ cont) = definitely_saturated (n-1) body cont
307 definitely_saturated n (Lam _ _) other_cont = False
308 definitely_saturated n _ _ = True
311 %************************************************************************
313 \subsection{Variables}
315 %************************************************************************
320 simplVar inline_call var cont
321 = getValEnv `thenSmpl` \ (id_subst, in_scope) ->
322 case lookupVarEnv id_subst var of
324 -> zapSubstEnv (simplExprB e cont)
326 Just (SubstMe e ty_subst id_subst)
327 -> setSubstEnv (ty_subst, id_subst) (simplExprB e cont)
330 var' = case lookupVarSet in_scope var of
334 if isLocallyDefined var && not (idMustBeINLINEd var) then
336 pprTrace "simplVar:" (ppr var) var
341 getSwitchChecker `thenSmpl` \ sw_chkr ->
342 completeVar sw_chkr in_scope inline_call var' cont
344 completeVar sw_chkr in_scope inline_call var cont
346 {- MAGIC UNFOLDINGS NOT USED NOW
347 | maybeToBool maybe_magic_result
348 = tick MagicUnfold `thenSmpl_`
351 -- Look for existing specialisations before trying inlining
352 | maybeToBool maybe_specialisation
353 = tick SpecialisationDone `thenSmpl_`
354 setSubstEnv (spec_bindings, emptyVarEnv) (
355 -- See note below about zapping the substitution here
357 simplExprB spec_template remaining_cont
360 -- Don't actually inline the scrutinee when we see
361 -- case x of y { .... }
362 -- and x has unfolding (C a b). Why not? Because
363 -- we get a silly binding y = C a b. If we don't
364 -- inline knownCon can directly substitute x for y instead.
365 | has_unfolding && var_is_case_scrutinee && unfolding_is_constr
366 = knownCon (Var var) con con_args cont
368 -- Look for an unfolding. There's a binding for the
369 -- thing, but perhaps we want to inline it anyway
370 | has_unfolding && (inline_call || ok_to_inline)
371 = getEnclosingCC `thenSmpl` \ encl_cc ->
372 if must_be_unfolded || costCentreOk encl_cc (coreExprCc unf_template)
375 tickUnfold var `thenSmpl_` (
378 -- The template is already simplified, so don't re-substitute.
379 -- This is VITAL. Consider
381 -- let y = \z -> ...x... in
383 -- We'll clone the inner \x, adding x->x' in the id_subst
384 -- Then when we inline y, we must *not* replace x by x' in
385 -- the inlined copy!!
387 if opt_D_dump_inlinings then
388 pprTrace "Inlining:" (ppr var <+> ppr unf_template) $
389 simplExprB unf_template cont
392 simplExprB unf_template cont
396 pprTrace "Inlining disallowed due to CC:\n" (ppr encl_cc <+> ppr unf_template <+> ppr (coreExprCc unf_template)) $
398 -- Can't unfold because of bad cost centre
399 rebuild (Var var) cont
401 | inline_call -- There was an InlineCall note, but we didn't inline!
402 = rebuild (Note InlineCall (Var var)) cont
405 = rebuild (Var var) cont
408 unfolding = getIdUnfolding var
410 {- MAGIC UNFOLDINGS NOT USED CURRENTLY
411 ---------- Magic unfolding stuff
412 maybe_magic_result = case unfolding of
413 MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
416 Just magic_result = maybe_magic_result
419 ---------- Unfolding stuff
420 has_unfolding = case unfolding of
421 CoreUnfolding _ _ _ -> True
424 -- overrides cost-centre business
425 must_be_unfolded = case getInlinePragma var of
426 IMustBeINLINEd -> True
429 CoreUnfolding form guidance unf_template = unfolding
431 unfolding_is_constr = case unf_template of
432 Con con _ -> conOkForAlt con
434 Con con con_args = unf_template
436 ---------- Specialisation stuff
437 ty_args = initial_ty_args cont
438 remaining_cont = drop_ty_args cont
439 maybe_specialisation = lookupSpecEnv (ppr var) (getIdSpecialisation var) ty_args
440 Just (spec_bindings, spec_template) = maybe_specialisation
442 initial_ty_args (ApplyTo _ (Type ty) (ty_subst,_) cont)
443 = fullSubstTy ty_subst in_scope ty : initial_ty_args cont
444 -- Having to do the substitution here is a bit of a bore
445 initial_ty_args other_cont = []
447 drop_ty_args (ApplyTo _ (Type _) _ cont) = drop_ty_args cont
448 drop_ty_args other_cont = other_cont
451 ok_to_inline = okToInline sw_chkr in_scope var form guidance cont
453 var_is_case_scrutinee = case cont of
454 Select _ _ _ _ _ -> True
457 ----------- costCentreOk
458 -- costCentreOk checks that it's ok to inline this thing
459 -- The time it *isn't* is this:
461 -- f x = let y = E in
462 -- scc "foo" (...y...)
464 -- Here y has a "current cost centre", and we can't inline it inside "foo",
465 -- regardless of whether E is a WHNF or not.
467 costCentreOk ccs_encl cc_rhs
468 = not opt_SccProfilingOn
469 || isSubsumedCCS ccs_encl -- can unfold anything into a subsumed scope
470 || not (isEmptyCC cc_rhs) -- otherwise need a cc on the unfolding
474 %************************************************************************
476 \subsection{Bindings}
478 %************************************************************************
481 simplBind :: CoreBind -> SimplM a -> SimplM ([CoreBind], a)
483 simplBind (NonRec bndr rhs) thing_inside
484 = simplTopRhs bndr rhs `thenSmpl` \ (binds, in_scope, rhs', arity) ->
485 setInScope in_scope $
486 completeBindNonRec (bndr `setIdArity` arity) rhs' thing_inside `thenSmpl` \ (maybe_bind, res) ->
488 binds' = case maybe_bind of
489 Just bind -> binds ++ [bind]
492 returnSmpl (binds', res)
494 simplBind (Rec pairs) thing_inside
495 = simplIds (map fst pairs) $ \ bndrs' ->
496 -- NB: bndrs' don't have unfoldings or spec-envs
497 -- We add them as we go down, using simplPrags
499 go (pairs `zip` bndrs') `thenSmpl` \ (pairs', thing') ->
500 returnSmpl ([Rec pairs'], thing')
502 go [] = thing_inside `thenSmpl` \ res ->
505 go (((bndr, rhs), bndr') : pairs)
506 = simplTopRhs bndr rhs `thenSmpl` \ (rhs_binds, in_scope, rhs', arity) ->
507 setInScope in_scope $
508 completeBindRec bndr (bndr' `setIdArity` arity)
509 rhs' (go pairs) `thenSmpl` \ (pairs', res) ->
510 returnSmpl (flatten rhs_binds pairs', res)
512 flatten (NonRec b r : binds) prs = (b,r) : flatten binds prs
513 flatten (Rec prs1 : binds) prs2 = prs1 ++ flatten binds prs2
517 completeBindRec bndr bndr' rhs' thing_inside
518 | postInlineUnconditionally bndr etad_rhs
519 -- NB: a loop breaker never has postInlineUnconditionally True
520 -- and non-loop-breakers only have *forward* references
521 -- Hence, it's safe to discard the binding
522 = tick PostInlineUnconditionally `thenSmpl_`
523 extendIdSubst bndr (Done etad_rhs) thing_inside
526 = -- Here's the only difference from completeBindNonRec: we
527 -- don't do simplBinder first, because we've already
528 -- done simplBinder on the recursive binders
529 simplPrags bndr bndr' etad_rhs `thenSmpl` \ bndr'' ->
530 modifyInScope bndr'' $
531 thing_inside `thenSmpl` \ (pairs, res) ->
532 returnSmpl ((bndr'', etad_rhs) : pairs, res)
534 etad_rhs = etaCoreExpr rhs'
538 %************************************************************************
540 \subsection{Right hand sides}
542 %************************************************************************
544 simplRhs basically just simplifies the RHS of a let(rec).
545 It does two important optimisations though:
547 * It floats let(rec)s out of the RHS, even if they
548 are hidden by big lambdas
550 * It does eta expansion
553 simplTopRhs :: InId -> InExpr
554 -> SimplM ([OutBind], InScopeEnv, OutExpr, ArityInfo)
556 = getSubstEnv `thenSmpl` \ bndr_se ->
557 simplRhs bndr bndr_se rhs
559 simplRhs bndr bndr_se rhs
560 | idWantsToBeINLINEd bndr -- Don't inline in the RHS of something that has an
561 -- inline pragma. But be careful that the InScopeEnv that
562 -- we return does still have inlinings on!
563 = switchOffInlining (simplExpr rhs Stop) `thenSmpl` \ rhs' ->
564 getInScope `thenSmpl` \ in_scope ->
565 returnSmpl ([], in_scope, rhs', unknownArity)
568 = -- Swizzle the inner lets past the big lambda (if any)
569 mkRhsTyLam rhs `thenSmpl` \ rhs' ->
571 -- Simplify the swizzled RHS
572 simplRhs2 bndr bndr_se rhs `thenSmpl` \ stuff@(floats, in_scope, rhs', arity) ->
574 if not (null floats) && exprIsWHNF rhs' then -- Do the float
575 tick LetFloatFromLet `thenSmpl_`
578 getInScope `thenSmpl` \ in_scope ->
579 returnSmpl ([], in_scope, mkLetBinds floats rhs', arity)
582 ---------------------------------------------------------
583 Try eta expansion for RHSs
585 We need to pass in the substitution environment for the RHS, because
586 it might be different to the current one (see simplBeta, as called
587 from simplExpr for an applied lambda). The binder needs to
590 simplRhs2 bndr bndr_se (Let bind body)
592 simplRhs2 bndr bndr_se body
593 ) `thenSmpl` \ (binds1, (binds2, in_scope, rhs', arity)) ->
594 returnSmpl (binds1 ++ binds2, in_scope, rhs', arity)
596 simplRhs2 bndr bndr_se rhs
597 | null ids -- Prevent eta expansion for both thunks
598 -- (would lose sharing) and variables (nothing gained).
599 -- To see why we ignore it for thunks, consider
600 -- let f = lookup env key in (f 1, f 2)
601 -- We'd better not eta expand f just because it is
604 -- Also if there isn't a lambda at the top we use
605 -- simplExprB so that we can do (more) let-floating
606 = simplExprB rhs Stop `thenSmpl` \ (binds, (in_scope, rhs')) ->
607 returnSmpl (binds, in_scope, rhs', unknownArity)
609 | otherwise -- Consider eta expansion
610 = getSwitchChecker `thenSmpl` \ sw_chkr ->
611 getInScope `thenSmpl` \ in_scope ->
612 simplBinders tyvars $ \ tyvars' ->
613 simplBinders ids $ \ ids' ->
615 if switchIsOn sw_chkr SimplDoLambdaEtaExpansion
616 && not (null extra_arg_tys)
618 tick EtaExpansion `thenSmpl_`
619 setSubstEnv bndr_se (mapSmpl simplType extra_arg_tys)
620 `thenSmpl` \ extra_arg_tys' ->
621 newIds extra_arg_tys' $ \ extra_bndrs' ->
622 simplExpr body (mk_cont extra_bndrs') `thenSmpl` \ body' ->
623 returnSmpl ( [], in_scope,
626 $ mkLams extra_bndrs' body',
627 atLeastArity (no_of_ids + no_of_extras))
629 simplExpr body Stop `thenSmpl` \ body' ->
630 returnSmpl ( [], in_scope,
633 atLeastArity no_of_ids)
636 (tyvars, ids, body) = collectTyAndValBinders rhs
637 no_of_ids = length ids
639 potential_extra_arg_tys :: [InType] -- NB: InType
640 potential_extra_arg_tys = case splitFunTys (applyTys (idType bndr) (mkTyVarTys tyvars)) of
641 (arg_tys, _) -> drop no_of_ids arg_tys
643 extra_arg_tys :: [InType]
644 extra_arg_tys = take no_extras_wanted potential_extra_arg_tys
645 no_of_extras = length extra_arg_tys
647 no_extras_wanted = -- Use information about how many args the fn is applied to
648 (arity - no_of_ids) `max`
650 -- See if the body could obviously do with more args
651 etaExpandCount body `max`
653 -- Finally, see if it's a state transformer, in which
654 -- case we eta-expand on principle! This can waste work,
655 -- but usually doesn't
656 case potential_extra_arg_tys of
657 [ty] | ty == realWorldStatePrimTy -> 1
660 arity = arityLowerBound (getIdArity bndr)
663 mk_cont (b:bs) = ApplyTo OkToDup (Var b) emptySubstEnv (mk_cont bs)
667 %************************************************************************
671 %************************************************************************
674 simplBeta :: InId -- Binder
675 -> InExpr -> SubstEnv -- Arg, with its subst-env
676 -> InExpr -> SimplCont -- Lambda body
677 -> SimplM OutExprStuff
679 simplBeta bndr rhs rhs_se body cont
681 = pprPanic "simplBeta" ((ppr bndr <+> ppr rhs) $$ ppr cont)
684 simplBeta bndr rhs rhs_se body cont
685 | (isStrict (getIdDemandInfo bndr) || is_dict bndr)
686 && not (exprIsWHNF rhs)
687 = tick Let2Case `thenSmpl_`
688 getSubstEnv `thenSmpl` \ body_se ->
690 simplExprB rhs (Select NoDup bndr [(DEFAULT, [], body)] body_se cont)
692 | preInlineUnconditionally bndr && not opt_NoPreInlining
693 = tick PreInlineUnconditionally `thenSmpl_`
694 case rhs_se of { (ty_subst, id_subst) ->
695 extendIdSubst bndr (SubstMe rhs ty_subst id_subst) $
696 simplExprB body cont }
699 = getSubstEnv `thenSmpl` \ bndr_se ->
700 setSubstEnv rhs_se (simplRhs bndr bndr_se rhs)
701 `thenSmpl` \ (floats, in_scope, rhs', arity) ->
702 setInScope in_scope $
703 completeBindNonRecE (bndr `setIdArity` arity) rhs' (
705 ) `thenSmpl` \ res ->
706 returnSmpl (addBinds floats res)
708 -- Return true only for dictionary types where the dictionary
709 -- has more than one component (else we risk poking on the component
710 -- of a newtype dictionary)
712 | not opt_DictsStrict = False
714 = case splitTyConApp_maybe (idType bndr) of
716 Just (tycon,tys) -> maybeToBool (tyConClass_maybe tycon) &&
717 length tys == tyConArity tycon &&
722 The completeBindNonRec family
723 - deals only with Ids, not TyVars
724 - take an already-simplified RHS
725 - always produce let bindings
727 They do *not* attempt to do let-to-case. Why? Because
728 they are used for top-level bindings, and in many situations where
729 the "rhs" is known to be a WHNF (so let-to-case is inappropriate).
732 completeBindNonRec :: InId -- Binder
733 -> OutExpr -- Simplified RHS
734 -> SimplM a -- Thing inside
735 -> SimplM (Maybe OutBind, a)
736 completeBindNonRec bndr rhs thing_inside
737 | isDeadBinder bndr -- This happens; for example, the case_bndr during case of
738 -- known constructor: case (a,b) of x { (p,q) -> ... }
739 -- Here x isn't mentioned in the RHS, so we don't want to
740 -- create the (dead) let-binding let x = (a,b) in ...
741 = thing_inside `thenSmpl` \ res ->
742 returnSmpl (Nothing,res)
744 | postInlineUnconditionally bndr etad_rhs
745 = tick PostInlineUnconditionally `thenSmpl_`
746 extendIdSubst bndr (Done etad_rhs) (
747 thing_inside `thenSmpl` \ res ->
748 returnSmpl (Nothing,res)
751 | otherwise -- Note that we use etad_rhs here
752 -- This gives maximum chance for a remaining binding
753 -- to be zapped by the indirection zapper in OccurAnal
754 = simplBinder bndr $ \ bndr' ->
755 simplPrags bndr bndr' etad_rhs `thenSmpl` \ bndr'' ->
756 modifyInScope bndr'' $
757 thing_inside `thenSmpl` \ res ->
758 returnSmpl (Just (NonRec bndr' etad_rhs), res)
760 etad_rhs = etaCoreExpr rhs
762 completeBindNonRecE :: InId -> OutExpr
763 -> SimplM (OutStuff a)
764 -> SimplM (OutStuff a)
765 completeBindNonRecE bndr rhs thing_inside
766 = completeBindNonRec bndr rhs thing_inside `thenSmpl` \ (maybe_bind, stuff) ->
768 Nothing -> returnSmpl stuff
769 Just bind -> returnSmpl (addBind bind stuff)
771 -- (simplPrags old_bndr new_bndr new_rhs) does two things
772 -- (a) it attaches the new unfolding to new_bndr
773 -- (b) it grabs the SpecEnv from old_bndr, applies the current
774 -- substitution to it, and attaches it to new_bndr
775 -- The assumption is that new_bndr, which is produced by simplBinder
776 -- has no unfolding or specenv.
778 simplPrags old_bndr new_bndr new_rhs
779 | isEmptySpecEnv spec_env
780 = returnSmpl (bndr_w_unfolding)
783 = getSimplBinderStuff `thenSmpl` \ (ty_subst, id_subst, in_scope, us) ->
785 spec_env' = substSpecEnv ty_subst in_scope (subst_val id_subst) spec_env
787 returnSmpl (bndr_w_unfolding `setIdSpecialisation` spec_env')
789 bndr_w_unfolding = new_bndr `setIdUnfolding` mkUnfolding new_rhs
791 spec_env = getIdSpecialisation old_bndr
792 subst_val id_subst ty_subst in_scope expr
793 = substExpr ty_subst id_subst in_scope expr
797 preInlineUnconditionally :: InId -> Bool
798 -- Examines a bndr to see if it is used just once in a
799 -- completely safe way, so that it is safe to discard the binding
800 -- inline its RHS at the (unique) usage site, REGARDLESS of how
801 -- big the RHS might be. If this is the case we don't simplify
802 -- the RHS first, but just inline it un-simplified.
804 -- This is much better than first simplifying a perhaps-huge RHS
805 -- and then inlining and re-simplifying it.
807 -- NB: we don't even look at the RHS to see if it's trivial
810 -- where x is used many times, but this is the unique occurrence
811 -- of y. We should NOT inline x at all its uses, because then
812 -- we'd do the same for y -- aargh! So we must base this
813 -- pre-rhs-simplification decision solely on x's occurrences, not
815 preInlineUnconditionally bndr
816 = case getInlinePragma bndr of
817 ICanSafelyBeINLINEd InsideLam _ -> False
818 ICanSafelyBeINLINEd not_in_lam True -> True -- Not inside a lambda,
819 -- one occurrence ==> safe!
823 postInlineUnconditionally :: InId -> OutExpr -> Bool
824 -- Examines a (bndr = rhs) binding, AFTER the rhs has been simplified
825 -- It returns True if it's ok to discard the binding and inline the
826 -- RHS at every use site.
828 -- NOTE: This isn't our last opportunity to inline.
829 -- We're at the binding site right now, and
830 -- we'll get another opportunity when we get to the ocurrence(s)
832 postInlineUnconditionally bndr rhs
836 = case getInlinePragma bndr of
837 IAmALoopBreaker -> False
838 IMustNotBeINLINEd -> False
839 IAmASpecPragmaId -> False -- Don't discard SpecPrag Ids
841 ICanSafelyBeINLINEd InsideLam one_branch -> exprIsTrivial rhs
842 -- Don't inline even WHNFs inside lambdas; this
843 -- isn't the last chance; see NOTE above.
845 ICanSafelyBeINLINEd not_in_lam one_branch -> one_branch || exprIsDupable rhs
847 other -> exprIsTrivial rhs -- Duplicating is *free*
848 -- NB: Even IWantToBeINLINEd and IMustBeINLINEd are ignored here
849 -- Why? Because we don't even want to inline them into the
850 -- RHS of constructor arguments. See NOTE above
852 inlineCase bndr scrut
853 = case getInlinePragma bndr of
854 -- Not expecting IAmALoopBreaker etc; this is a case binder!
856 ICanSafelyBeINLINEd StrictOcc one_branch
857 -> one_branch || exprIsDupable scrut
858 -- This case is the entire reason we distinguish StrictOcc from LazyOcc
859 -- We want eliminate the "case" only if we aren't going to
860 -- build a thunk instead, and that's what StrictOcc finds
862 -- case (f x) of y { DEFAULT -> g y }
863 -- Here we DO NOT WANT:
865 -- *even* if g is strict. We want to avoid constructing the
866 -- thunk for (f x)! So y gets a LazyOcc.
868 other -> exprIsTrivial scrut -- Duplication is free
869 && ( isUnLiftedType (idType bndr)
870 || scrut_is_evald_var -- So dropping the case won't change termination
871 || isStrict (getIdDemandInfo bndr)) -- It's going to get evaluated later, so again
872 -- termination doesn't change
874 -- Check whether or not scrut is known to be evaluted
875 -- It's not going to be a visible value (else the previous
876 -- blob would apply) so we just check the variable case
877 scrut_is_evald_var = case scrut of
878 Var v -> isEvaldUnfolding (getIdUnfolding v)
882 okToInline is used at call sites, so it is a bit more generous.
883 It's a very important function that embodies lots of heuristics.
886 okToInline :: SwitchChecker
889 -> FormSummary -- The thing is WHNF or bottom;
892 -> Bool -- True <=> inline it
894 -- A non-WHNF can be inlined if it doesn't occur inside a lambda,
895 -- and occurs exactly once or
896 -- occurs once in each branch of a case and is small
898 -- If the thing is in WHNF, there's no danger of duplicating work,
899 -- so we can inline if it occurs once, or is small
901 okToInline sw_chkr in_scope id form guidance cont
902 | essential_unfoldings_only
904 -- If "essential_unfoldings_only" is true we do no inlinings at all,
905 -- EXCEPT for things that absolutely have to be done
906 -- (see comments with idMustBeINLINEd)
909 = case getInlinePragma id of
910 IAmDead -> pprTrace "okToInline: dead" (ppr id) False
912 IAmASpecPragmaId -> False
913 IMustNotBeINLINEd -> False
914 IAmALoopBreaker -> False
915 IMustBeINLINEd -> True
916 IWantToBeINLINEd -> True
918 ICanSafelyBeINLINEd inside_lam one_branch
919 -> --pprTrace "inline (occurs once): " (ppr id <+> ppr small_enough <+> ppr one_branch <+> ppr whnf <+> ppr some_benefit <+> ppr not_inside_lam) $
920 (small_enough || one_branch) &&
921 ((whnf && some_benefit) || not_inside_lam)
924 not_inside_lam = case inside_lam of {InsideLam -> False; other -> True}
926 other -> (if opt_PprStyle_Debug then
927 pprTrace "inline:" (ppr id <+> ppr small_enough <+> ppr whnf <+> ppr some_benefit)
929 whnf && small_enough && some_benefit
930 -- We could consider using exprIsCheap here,
931 -- as in postInlineUnconditionally, but unlike the latter we wouldn't
932 -- necessarily eliminate a thunk; and the "form" doesn't tell
935 whnf = whnfOrBottom form
936 small_enough = smallEnoughToInline id arg_evals result_scrut guidance
937 (arg_evals, result_scrut) = get_evals cont
939 -- some_benefit checks that *something* interesting happens to
940 -- the variable after it's inlined.
941 some_benefit = contIsInteresting cont
943 -- Finding out whether the args are evaluated. This isn't completely easy
944 -- because the args are not yet simplified, so we have to peek into them.
945 get_evals (ApplyTo _ arg (te,ve) cont)
946 | isValArg arg = case get_evals cont of
947 (args, res) -> (get_arg_eval arg ve : args, res)
948 | otherwise = get_evals cont
950 get_evals (Select _ _ _ _ _) = ([], True)
951 get_evals other = ([], False)
953 get_arg_eval (Con con _) ve = isWHNFCon con
954 get_arg_eval (Var v) ve = case lookupVarEnv ve v of
955 Just (SubstMe e' _ ve') -> get_arg_eval e' ve'
956 Just (Done (Con con _)) -> isWHNFCon con
957 Just (Done (Var v')) -> get_var_eval v'
958 Just (Done other) -> False
959 Nothing -> get_var_eval v
960 get_arg_eval other ve = False
962 get_var_eval v = case lookupVarSet in_scope v of
963 Just v' -> isEvaldUnfolding (getIdUnfolding v')
964 Nothing -> isEvaldUnfolding (getIdUnfolding v)
966 essential_unfoldings_only = switchIsOn sw_chkr EssentialUnfoldingsOnly
968 contIsInteresting :: SimplCont -> Bool
969 contIsInteresting Stop = False
970 contIsInteresting (ArgOf _ _ _) = False
971 contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont
972 contIsInteresting (CoerceIt _ _ _ cont) = contIsInteresting cont
974 -- Even a case with only a default case is a bit interesting;
975 -- we may be able to eliminate it after inlining.
976 -- contIsInteresting (Select _ _ [(DEFAULT,_,_)] _ _) = False
978 contIsInteresting _ = True
981 Comment about some_benefit above
982 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
984 We want to avoid inlining an expression where there can't possibly be
985 any gain, such as in an argument position. Hence, if the continuation
986 is interesting (eg. a case scrutinee, application etc.) then we
987 inline, otherwise we don't.
989 Previously some_benefit used to return True only if the variable was
990 applied to some value arguments. This didn't work:
992 let x = _coerce_ (T Int) Int (I# 3) in
993 case _coerce_ Int (T Int) x of
996 we want to inline x, but can't see that it's a constructor in a case
997 scrutinee position, and some_benefit is False.
1001 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
1003 .... case dMonadST _@_ x0 of (a,b,c) -> ....
1005 we'd really like to inline dMonadST here, but we *don't* want to
1006 inline if the case expression is just
1008 case x of y { DEFAULT -> ... }
1010 since we can just eliminate this case instead (x is in WHNF). Similar
1011 applies when x is bound to a lambda expression. Hence
1012 contIsInteresting looks for case expressions with just a single
1015 %************************************************************************
1017 \subsection{The main rebuilder}
1019 %************************************************************************
1022 -------------------------------------------------------------------
1023 rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff
1026 = tick LeavesExamined `thenSmpl_`
1027 do_rebuild expr cont
1030 = getInScope `thenSmpl` \ in_scope ->
1031 returnSmpl ([], (in_scope, expr))
1033 ---------------------------------------------------------
1034 -- Stop continuation
1036 do_rebuild expr Stop = rebuild_done expr
1039 ---------------------------------------------------------
1040 -- ArgOf continuation
1042 do_rebuild expr (ArgOf _ cont_fn _) = cont_fn expr
1044 ---------------------------------------------------------
1045 -- ApplyTo continuation
1047 do_rebuild expr cont@(ApplyTo _ arg se cont')
1049 Var v -> case getIdStrictness v of
1050 NoStrictnessInfo -> non_strict_case
1051 StrictnessInfo demands result_bot _ -> ASSERT( not (null demands) || result_bot )
1052 -- If this happened we'd get an infinite loop
1053 rebuild_strict demands result_bot expr (idType v) cont
1054 other -> non_strict_case
1056 non_strict_case = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
1057 do_rebuild (App expr arg') cont'
1060 ---------------------------------------------------------
1061 -- Coerce continuation
1063 do_rebuild expr (CoerceIt _ to_ty se cont)
1065 simplType to_ty `thenSmpl` \ to_ty' ->
1066 do_rebuild (mk_coerce to_ty' expr) cont
1068 mk_coerce to_ty' (Note (Coerce _ from_ty) expr) = Note (Coerce to_ty' from_ty) expr
1069 mk_coerce to_ty' expr = Note (Coerce to_ty' (coreExprType expr)) expr
1072 ---------------------------------------------------------
1073 -- Case of known constructor or literal
1075 do_rebuild expr@(Con con args) cont@(Select _ _ _ _ _)
1076 | conOkForAlt con -- Knocks out PrimOps and NoRepLits
1077 = knownCon expr con args cont
1080 ---------------------------------------------------------
1081 -- Case of other value (e.g. a partial application or lambda)
1082 -- Turn it back into a let
1084 do_rebuild expr (Select _ bndr ((DEFAULT, bs, rhs):alts) se cont)
1085 | case mkFormSummary expr of { ValueForm -> True; other -> False }
1086 = ASSERT( null bs && null alts )
1087 tick Case2Let `thenSmpl_`
1089 completeBindNonRecE bndr expr $
1094 ---------------------------------------------------------
1095 -- The other Select cases
1097 do_rebuild scrut (Select _ bndr alts se cont)
1098 = getSwitchChecker `thenSmpl` \ chkr ->
1100 if all (cheapEqExpr rhs1) other_rhss
1101 && inlineCase bndr scrut
1102 && all binders_unused alts
1103 && switchIsOn chkr SimplDoCaseElim
1105 -- Get rid of the case altogether
1106 -- See the extensive notes on case-elimination below
1107 -- Remember to bind the binder though!
1108 tick CaseElim `thenSmpl_`
1110 extendIdSubst bndr (Done scrut) $
1111 simplExprB rhs1 cont
1115 rebuild_case chkr scrut bndr alts se cont
1117 (rhs1:other_rhss) = [rhs | (_,_,rhs) <- alts]
1118 binders_unused (_, bndrs, _) = all isDeadBinder bndrs
1123 ---------------------------------------------------------
1124 -- Rebuiling a function with strictness info
1126 rebuild_strict :: [Demand] -> Bool -- Stricness info
1127 -> OutExpr -> OutType -- Function and type
1128 -> SimplCont -- Continuation
1129 -> SimplM OutExprStuff
1131 rebuild_strict [] True fun fun_ty cont = rebuild_bot fun fun_ty cont
1132 rebuild_strict [] False fun fun_ty cont = do_rebuild fun cont
1134 rebuild_strict ds result_bot fun fun_ty (ApplyTo _ (Type ty_arg) se cont)
1135 -- Type arg; don't consume a demand
1136 = setSubstEnv se (simplType ty_arg) `thenSmpl` \ ty_arg' ->
1137 rebuild_strict ds result_bot (App fun (Type ty_arg'))
1138 (applyTy fun_ty ty_arg') cont
1140 rebuild_strict (d:ds) result_bot fun fun_ty (ApplyTo _ val_arg se cont)
1141 | not (isStrict d) -- Lazy value argument
1142 = setSubstEnv se (simplArg val_arg) `thenSmpl` \ val_arg' ->
1143 rebuild_strict ds result_bot (App fun val_arg') res_ty cont
1145 | otherwise -- Strict value argument
1146 = getInScope `thenSmpl` \ in_scope ->
1148 cont_ty = contResultType in_scope res_ty cont
1150 setSubstEnv se (simplExprB val_arg (ArgOf NoDup cont_fn cont_ty))
1152 Just (arg_ty, res_ty) = splitFunTy_maybe fun_ty
1153 cont_fn arg' = rebuild_strict ds result_bot
1154 (App fun arg') res_ty
1157 rebuild_strict ds result_bot fun fun_ty cont = do_rebuild fun cont
1159 ---------------------------------------------------------
1161 -- * case (error "hello") of { ... }
1162 -- * (error "Hello") arg
1165 rebuild_bot expr expr_ty Stop -- No coerce needed
1168 rebuild_bot expr expr_ty (CoerceIt _ to_ty se Stop) -- Don't "tick" on this,
1169 -- else simplifier never stops
1171 simplType to_ty `thenSmpl` \ to_ty' ->
1172 rebuild_done (mkNote (Coerce to_ty' expr_ty) expr)
1174 rebuild_bot expr expr_ty cont
1175 = tick CaseOfError `thenSmpl_`
1176 getInScope `thenSmpl` \ in_scope ->
1178 result_ty = contResultType in_scope expr_ty cont
1180 rebuild_done (mkNote (Coerce result_ty expr_ty) expr)
1183 Blob of helper functions for the "case-of-something-else" situation.
1186 ---------------------------------------------------------
1187 -- Case of something else
1189 rebuild_case sw_chkr scrut case_bndr alts se cont
1190 = -- Prepare case alternatives
1191 prepareCaseAlts (splitTyConApp_maybe (idType case_bndr))
1192 scrut_cons alts `thenSmpl` \ better_alts ->
1194 -- Set the new subst-env in place (before dealing with the case binder)
1197 -- Deal with the case binder, and prepare the continuation;
1198 -- The new subst_env is in place
1199 simplBinder case_bndr $ \ case_bndr' ->
1200 prepareCaseCont better_alts cont $ \ cont' ->
1203 -- Deal with variable scrutinee
1204 substForVarScrut scrut case_bndr' $ \ zap_occ_info ->
1206 case_bndr'' = zap_occ_info case_bndr'
1209 -- Deal with the case alternaatives
1210 simplAlts zap_occ_info scrut_cons
1211 case_bndr'' better_alts cont' `thenSmpl` \ alts' ->
1213 mkCase sw_chkr scrut case_bndr'' alts' `thenSmpl` \ case_expr ->
1214 rebuild_done case_expr
1216 -- scrut_cons tells what constructors the scrutinee can't possibly match
1217 scrut_cons = case scrut of
1218 Var v -> case getIdUnfolding v of
1219 OtherCon cons -> cons
1224 knownCon expr con args (Select _ bndr alts se cont)
1225 = tick KnownBranch `thenSmpl_`
1227 case findAlt con alts of
1228 (DEFAULT, bs, rhs) -> ASSERT( null bs )
1229 completeBindNonRecE bndr expr $
1232 (Literal lit, bs, rhs) -> ASSERT( null bs )
1233 extendIdSubst bndr (Done expr) $
1234 -- Unconditionally substitute, because expr must
1235 -- be a variable or a literal. It can't be a
1236 -- NoRep literal because they don't occur in
1240 (DataCon dc, bs, rhs) -> completeBindNonRecE bndr expr $
1241 extend bs real_args $
1244 real_args = drop (dataConNumInstArgs dc) args
1247 extend [] [] thing_inside = thing_inside
1248 extend (b:bs) (arg:args) thing_inside = extendIdSubst b (Done arg) $
1249 extend bs args thing_inside
1253 prepareCaseCont :: [InAlt] -> SimplCont
1254 -> (SimplCont -> SimplM (OutStuff a))
1255 -> SimplM (OutStuff a)
1256 -- Polymorphic recursion here!
1258 prepareCaseCont [alt] cont thing_inside = thing_inside cont
1259 prepareCaseCont alts cont thing_inside = mkDupableCont (coreAltsType alts) cont thing_inside
1262 substForVarScrut checks whether the scrutinee is a variable, v.
1263 If so, try to eliminate uses of v in the RHSs in favour of case_bndr;
1264 that way, there's a chance that v will now only be used once, and hence inlined.
1266 If we do this, then we have to nuke any occurrence info (eg IAmDead)
1267 in the case binder, because the case-binder now effectively occurs
1268 whenever v does. AND we have to do the same for the pattern-bound
1271 (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
1273 Here, b and p are dead. But when we move the argment inside the first
1274 case RHS, and eliminate the second case, we get
1276 case x or { (a,b) -> a b
1278 Urk! b is alive! Reason: the scrutinee was a variable, and case elimination
1279 happened. Hence the zap_occ_info function returned by substForVarScrut
1282 substForVarScrut (Var v) case_bndr' thing_inside
1283 | isLocallyDefined v -- No point for imported things
1284 = modifyInScope (v `setIdUnfolding` mkUnfolding (Var case_bndr')
1285 `setInlinePragma` IMustBeINLINEd) $
1286 -- We could extend the substitution instead, but it would be
1287 -- a hack because then the substitution wouldn't be idempotent
1289 thing_inside (\ bndr -> bndr `setInlinePragma` NoInlinePragInfo)
1291 substForVarScrut other_scrut case_bndr' thing_inside
1292 = thing_inside (\ bndr -> bndr) -- NoOp on bndr
1295 prepareCaseAlts does two things:
1297 1. Remove impossible alternatives
1299 2. If the DEFAULT alternative can match only one possible constructor,
1300 then make that constructor explicit.
1302 case e of x { DEFAULT -> rhs }
1304 case e of x { (a,b) -> rhs }
1305 where the type is a single constructor type. This gives better code
1306 when rhs also scrutinises x or e.
1309 prepareCaseAlts (Just (tycon, inst_tys)) scrut_cons alts
1311 = case (findDefault filtered_alts, missing_cons) of
1313 ((alts_no_deflt, Just rhs), [data_con]) -- Just one missing constructor!
1314 -> tick FillInCaseDefault `thenSmpl_`
1316 (_,_,ex_tyvars,_,_,_) = dataConSig data_con
1318 getUniquesSmpl (length ex_tyvars) `thenSmpl` \ tv_uniqs ->
1320 ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars
1321 mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
1323 newIds (dataConArgTys
1325 (inst_tys ++ mkTyVarTys ex_tyvars')) $ \ bndrs ->
1326 returnSmpl ((DataCon data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt)
1328 other -> returnSmpl filtered_alts
1330 -- Filter out alternatives that can't possibly match
1331 filtered_alts = case scrut_cons of
1333 other -> [alt | alt@(con,_,_) <- alts, not (con `elem` scrut_cons)]
1335 missing_cons = [data_con | data_con <- tyConDataCons tycon,
1336 not (data_con `elem` handled_data_cons)]
1337 handled_data_cons = [data_con | DataCon data_con <- scrut_cons] ++
1338 [data_con | (DataCon data_con, _, _) <- filtered_alts]
1341 prepareCaseAlts _ scrut_cons alts
1342 = returnSmpl alts -- Functions
1345 ----------------------
1346 simplAlts zap_occ_info scrut_cons case_bndr'' alts cont'
1347 = mapSmpl simpl_alt alts
1349 inst_tys' = case splitTyConApp_maybe (idType case_bndr'') of
1350 Just (tycon, inst_tys) -> inst_tys
1352 -- handled_cons is all the constructors that are dealt
1353 -- with, either by being impossible, or by there being an alternative
1354 handled_cons = scrut_cons ++ [con | (con,_,_) <- alts, con /= DEFAULT]
1356 simpl_alt (DEFAULT, _, rhs)
1357 = modifyInScope (case_bndr'' `setIdUnfolding` OtherCon handled_cons) $
1358 simplExpr rhs cont' `thenSmpl` \ rhs' ->
1359 returnSmpl (DEFAULT, [], rhs')
1361 simpl_alt (con, vs, rhs)
1362 = -- Deal with the case-bound variables
1363 -- Mark the ones that are in ! positions in the data constructor
1364 -- as certainly-evaluated
1365 simplBinders (add_evals con vs) $ \ vs' ->
1367 -- Bind the case-binder to (Con args)
1368 -- In the default case we record the constructors it *can't* be.
1369 -- We take advantage of any OtherCon info in the case scrutinee
1371 con_app = Con con (map Type inst_tys' ++ map varToCoreExpr vs')
1373 modifyInScope (case_bndr'' `setIdUnfolding` mkUnfolding con_app) $
1374 simplExpr rhs cont' `thenSmpl` \ rhs' ->
1375 returnSmpl (con, vs', rhs')
1378 -- add_evals records the evaluated-ness of the bound variables of
1379 -- a case pattern. This is *important*. Consider
1380 -- data T = T !Int !Int
1382 -- case x of { T a b -> T (a+1) b }
1384 -- We really must record that b is already evaluated so that we don't
1385 -- go and re-evaluated it when constructing the result.
1387 add_evals (DataCon dc) vs = stretchZipEqual add_eval vs (dataConStrictMarks dc)
1388 add_evals other_con vs = vs
1390 add_eval v m | isTyVar v = Nothing
1391 | otherwise = case m of
1392 MarkedStrict -> Just (zap_occ_info v `setIdUnfolding` OtherCon [])
1393 NotMarkedStrict -> Just (zap_occ_info v)
1397 Case elimination [see the code above]
1399 Start with a simple situation:
1401 case x# of ===> e[x#/y#]
1404 (when x#, y# are of primitive type, of course). We can't (in general)
1405 do this for algebraic cases, because we might turn bottom into
1408 Actually, we generalise this idea to look for a case where we're
1409 scrutinising a variable, and we know that only the default case can
1414 other -> ...(case x of
1418 Here the inner case can be eliminated. This really only shows up in
1419 eliminating error-checking code.
1421 We also make sure that we deal with this very common case:
1426 Here we are using the case as a strict let; if x is used only once
1427 then we want to inline it. We have to be careful that this doesn't
1428 make the program terminate when it would have diverged before, so we
1430 - x is used strictly, or
1431 - e is already evaluated (it may so if e is a variable)
1433 Lastly, we generalise the transformation to handle this:
1439 We only do this for very cheaply compared r's (constructors, literals
1440 and variables). If pedantic bottoms is on, we only do it when the
1441 scrutinee is a PrimOp which can't fail.
1443 We do it *here*, looking at un-simplified alternatives, because we
1444 have to check that r doesn't mention the variables bound by the
1445 pattern in each alternative, so the binder-info is rather useful.
1447 So the case-elimination algorithm is:
1449 1. Eliminate alternatives which can't match
1451 2. Check whether all the remaining alternatives
1452 (a) do not mention in their rhs any of the variables bound in their pattern
1453 and (b) have equal rhss
1455 3. Check we can safely ditch the case:
1456 * PedanticBottoms is off,
1457 or * the scrutinee is an already-evaluated variable
1458 or * the scrutinee is a primop which is ok for speculation
1459 -- ie we want to preserve divide-by-zero errors, and
1460 -- calls to error itself!
1462 or * [Prim cases] the scrutinee is a primitive variable
1464 or * [Alg cases] the scrutinee is a variable and
1465 either * the rhs is the same variable
1466 (eg case x of C a b -> x ===> x)
1467 or * there is only one alternative, the default alternative,
1468 and the binder is used strictly in its scope.
1469 [NB this is helped by the "use default binder where
1470 possible" transformation; see below.]
1473 If so, then we can replace the case with one of the rhss.
1476 %************************************************************************
1478 \subsection{Duplicating continuations}
1480 %************************************************************************
1483 mkDupableCont :: InType -- Type of the thing to be given to the continuation
1485 -> (SimplCont -> SimplM (OutStuff a))
1486 -> SimplM (OutStuff a)
1487 mkDupableCont ty cont thing_inside
1488 | contIsDupable cont
1491 mkDupableCont _ (CoerceIt _ ty se cont) thing_inside
1492 = mkDupableCont ty cont $ \ cont' ->
1493 thing_inside (CoerceIt OkToDup ty se cont')
1495 mkDupableCont join_arg_ty (ArgOf _ cont_fn res_ty) thing_inside
1496 = -- Build the RHS of the join point
1497 simplType join_arg_ty `thenSmpl` \ join_arg_ty' ->
1498 newId join_arg_ty' ( \ arg_id ->
1499 getSwitchChecker `thenSmpl` \ chkr ->
1500 cont_fn (Var arg_id) `thenSmpl` \ (binds, (_, rhs)) ->
1501 returnSmpl (Lam arg_id (mkLetBinds binds rhs))
1502 ) `thenSmpl` \ join_rhs ->
1504 -- Build the join Id and continuation
1505 newId (coreExprType join_rhs) $ \ join_id ->
1507 new_cont = ArgOf OkToDup
1508 (\arg' -> rebuild_done (App (Var join_id) arg'))
1512 -- Do the thing inside
1513 thing_inside new_cont `thenSmpl` \ res ->
1514 returnSmpl (addBind (NonRec join_id join_rhs) res)
1516 mkDupableCont ty (ApplyTo _ arg se cont) thing_inside
1517 = mkDupableCont (funResultTy ty) cont $ \ cont' ->
1518 setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
1519 if exprIsDupable arg' then
1520 thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont')
1522 newId (coreExprType arg') $ \ bndr ->
1523 thing_inside (ApplyTo OkToDup (Var bndr) emptySubstEnv cont') `thenSmpl` \ res ->
1524 returnSmpl (addBind (NonRec bndr arg') res)
1526 mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside
1527 = tick CaseOfCase `thenSmpl_` (
1529 simplBinder case_bndr $ \ case_bndr' ->
1530 prepareCaseCont alts cont $ \ cont' ->
1531 mapAndUnzipSmpl (mkDupableAlt case_bndr' cont') alts `thenSmpl` \ (alt_binds_s, alts') ->
1532 returnSmpl (concat alt_binds_s, (case_bndr', alts'))
1533 ) `thenSmpl` \ (alt_binds, (case_bndr', alts')) ->
1535 extendInScopes [b | NonRec b _ <- alt_binds] $
1536 thing_inside (Select OkToDup case_bndr' alts' emptySubstEnv Stop) `thenSmpl` \ res ->
1537 returnSmpl (addBinds alt_binds res)
1540 mkDupableAlt :: OutId -> SimplCont -> InAlt -> SimplM (OutStuff CoreAlt)
1541 mkDupableAlt case_bndr' cont alt@(con, bndrs, rhs)
1542 = simplBinders bndrs $ \ bndrs' ->
1543 simplExpr rhs cont `thenSmpl` \ rhs' ->
1544 if exprIsDupable rhs' then
1545 -- It's small, so don't bother to let-bind it
1546 returnSmpl ([], (con, bndrs', rhs'))
1548 -- It's big, so let-bind it
1550 rhs_ty' = coreExprType rhs'
1551 used_bndrs' = filter (not . isDeadBinder) (case_bndr' : bndrs')
1553 ( if null used_bndrs' && isUnLiftedType rhs_ty'
1554 then newId realWorldStatePrimTy $ \ rw_id ->
1555 returnSmpl ([rw_id], [varToCoreExpr realWorldPrimId])
1557 returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
1559 `thenSmpl` \ (final_bndrs', final_args) ->
1561 -- If we try to lift a primitive-typed something out
1562 -- for let-binding-purposes, we will *caseify* it (!),
1563 -- with potentially-disastrous strictness results. So
1564 -- instead we turn it into a function: \v -> e
1565 -- where v::State# RealWorld#. The value passed to this function
1566 -- is realworld#, which generates (almost) no code.
1568 -- There's a slight infelicity here: we pass the overall
1569 -- case_bndr to all the join points if it's used in *any* RHS,
1570 -- because we don't know its usage in each RHS separately
1572 newId (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr ->
1573 returnSmpl ([NonRec join_bndr (mkLams final_bndrs' rhs')],
1574 (con, bndrs', mkApps (Var join_bndr) final_args))