2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[Simplify]{The main module of the simplifier}
7 module Simplify ( simplBind ) where
9 #include "HsVersions.h"
11 import CmdLineOpts ( switchIsOn, opt_SccProfilingOn, opt_PprStyle_Debug,
12 opt_NoPreInlining, opt_DictsStrict, opt_D_dump_inlinings,
16 import SimplUtils ( mkCase, etaCoreExpr, etaExpandCount, findAlt, mkRhsTyLam,
17 simplBinder, simplBinders, simplIds, findDefault
19 import Var ( TyVar, mkSysTyVar, tyVarKind )
22 import Id ( Id, idType,
23 getIdUnfolding, setIdUnfolding,
24 getIdSpecialisation, setIdSpecialisation,
25 getIdDemandInfo, setIdDemandInfo,
26 getIdArity, setIdArity,
28 setInlinePragma, getInlinePragma, idMustBeINLINEd,
31 import IdInfo ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..),
32 ArityInfo, atLeastArity, arityLowerBound, unknownArity
34 import Demand ( Demand, isStrict, wwLazy )
35 import Const ( isWHNFCon, conOkForAlt )
36 import ConFold ( tryPrimOp )
37 import PrimOp ( PrimOp, primOpStrictness )
38 import DataCon ( DataCon, dataConNumInstArgs, dataConStrictMarks, dataConSig, dataConArgTys )
39 import Const ( Con(..) )
40 import MagicUFs ( applyMagicUnfoldingFun )
41 import Name ( isExported, isLocallyDefined )
43 import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..),
44 mkUnfolding, smallEnoughToInline,
45 isEvaldUnfolding, unfoldAlways
47 import CoreUtils ( IdSubst, SubstCoreExpr(..),
48 cheapEqExpr, exprIsDupable, exprIsWHNF, exprIsTrivial,
49 coreExprType, coreAltsType, exprIsCheap, substExpr,
50 FormSummary(..), mkFormSummary, whnfOrBottom
52 import SpecEnv ( lookupSpecEnv, isEmptySpecEnv, substSpecEnv )
53 import CostCentre ( isSubsumedCCS, currentCCS, isEmptyCC )
54 import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType, fullSubstTy,
55 mkFunTy, splitFunTys, splitTyConApp_maybe, splitFunTy_maybe,
56 applyTy, applyTys, funResultTy, isDictTy, isDataType
58 import TyCon ( isDataTyCon, tyConDataCons, tyConClass_maybe, tyConArity, isDataTyCon )
59 import TysPrim ( realWorldStatePrimTy )
60 import PrelVals ( realWorldPrimId )
61 import BasicTypes ( StrictnessMark(..) )
62 import Maybes ( maybeToBool )
63 import Util ( zipWithEqual, stretchZipEqual )
69 The guts of the simplifier is in this module, but the driver
70 loop for the simplifier is in SimplPgm.lhs.
73 %************************************************************************
75 \subsection[Simplify-simplExpr]{The main function: simplExpr}
77 %************************************************************************
80 addBind :: CoreBind -> OutStuff a -> OutStuff a
81 addBind bind (binds, res) = (bind:binds, res)
83 addBinds :: [CoreBind] -> OutStuff a -> OutStuff a
84 addBinds [] stuff = stuff
85 addBinds binds1 (binds2, res) = (binds1++binds2, res)
88 The reason for this OutExprStuff stuff is that we want to float *after*
89 simplifying a RHS, not before. If we do so naively we get quadratic
90 behaviour as things float out.
92 To see why it's important to do it after, consider this (real) example:
106 a -- Can't inline a this round, cos it appears twice
110 Each of the ==> steps is a round of simplification. We'd save a
111 whole round if we float first. This can cascade. Consider
116 let f = let d1 = ..d.. in \y -> e
120 in \x -> ...(\y ->e)...
122 Only in this second round can the \y be applied, and it
123 might do the same again.
127 simplExpr :: CoreExpr -> SimplCont -> SimplM CoreExpr
128 simplExpr expr cont = simplExprB expr cont `thenSmpl` \ (binds, (_, body)) ->
129 returnSmpl (mkLetBinds binds body)
131 simplExprB :: InExpr -> SimplCont -> SimplM OutExprStuff
133 simplExprB (Note InlineCall (Var v)) cont
134 = simplVar True v cont
136 simplExprB (Var v) cont
137 = simplVar False v cont
139 simplExprB expr@(Con (PrimOp op) args) cont
140 = simplType (coreExprType expr) `thenSmpl` \ expr_ty ->
141 getInScope `thenSmpl` \ in_scope ->
142 getSubstEnv `thenSmpl` \ se ->
144 (val_arg_demands, _) = primOpStrictness op
146 -- Main game plan: loop through the arguments, simplifying
147 -- each of them with an ArgOf continuation. Getting the right
148 -- cont_ty in the ArgOf continuation is a bit of a nuisance.
149 go [] ds args' = rebuild_primop (reverse args')
150 go (arg:args) ds args'
151 | isTypeArg arg = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
152 go args ds (arg':args')
153 go (arg:args) (d:ds) args'
154 | not (isStrict d) = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
155 go args ds (arg':args')
156 | otherwise = setSubstEnv se (simplExprB arg (mk_cont args ds args'))
158 cont_ty = contResultType in_scope expr_ty cont
159 mk_cont args ds args' = ArgOf NoDup (\ arg' -> go args ds (arg':args')) cont_ty
161 go args val_arg_demands []
165 = -- Try the prim op simplification
166 -- It's really worth trying simplExpr again if it succeeds,
167 -- because you can find
168 -- case (eqChar# x 'a') of ...
170 -- case (case x of 'a' -> True; other -> False) of ...
171 case tryPrimOp op args' of
172 Just e' -> zapSubstEnv (simplExprB e' cont)
173 Nothing -> rebuild (Con (PrimOp op) args') cont
175 simplExprB (Con con@(DataCon _) args) cont
176 = simplConArgs args $ \ args' ->
177 rebuild (Con con args') cont
179 simplExprB expr@(Con con@(Literal _) args) cont
180 = ASSERT( null args )
183 simplExprB (App fun arg) cont
184 = getSubstEnv `thenSmpl` \ se ->
185 simplExprB fun (ApplyTo NoDup arg se cont)
187 simplExprB (Case scrut bndr alts) cont
188 = getSubstEnv `thenSmpl` \ se ->
189 simplExprB scrut (Select NoDup bndr alts se cont)
191 simplExprB (Note (Coerce to from) e) cont
192 | to == from = simplExprB e cont
193 | otherwise = getSubstEnv `thenSmpl` \ se ->
194 simplExprB e (CoerceIt NoDup to se cont)
196 -- hack: we only distinguish subsumed cost centre stacks for the purposes of
197 -- inlining. All other CCCSs are mapped to currentCCS.
198 simplExprB (Note (SCC cc) e) cont
199 = setEnclosingCC currentCCS $
200 simplExpr e Stop `thenSmpl` \ e ->
201 rebuild (mkNote (SCC cc) e) cont
203 simplExprB (Note note e) cont
204 = simplExpr e Stop `thenSmpl` \ e' ->
205 rebuild (mkNote note e') cont
207 -- A non-recursive let is dealt with by simplBeta
208 simplExprB (Let (NonRec bndr rhs) body) cont
209 = getSubstEnv `thenSmpl` \ se ->
210 simplBeta bndr rhs se body cont
212 simplExprB (Let (Rec pairs) body) cont
213 = simplRecBind pairs (simplExprB body cont)
215 -- Type-beta reduction
216 simplExprB expr@(Lam bndr body) cont@(ApplyTo _ (Type ty_arg) arg_se body_cont)
217 = ASSERT( isTyVar bndr )
218 tick BetaReduction `thenSmpl_`
219 setSubstEnv arg_se (simplType ty_arg) `thenSmpl` \ ty' ->
220 extendTySubst bndr ty' $
221 simplExprB body body_cont
223 -- Ordinary beta reduction
224 simplExprB expr@(Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
225 = tick BetaReduction `thenSmpl_`
226 simplBeta bndr' arg arg_se body body_cont
228 bndr' = zapLambdaBndr bndr body body_cont
230 simplExprB (Lam bndr body) cont
231 = simplBinder bndr $ \ bndr' ->
232 simplExpr body Stop `thenSmpl` \ body' ->
233 rebuild (Lam bndr' body') cont
235 simplExprB (Type ty) cont
236 = ASSERT( case cont of { Stop -> True; ArgOf _ _ _ -> True; other -> False } )
237 simplType ty `thenSmpl` \ ty' ->
238 rebuild (Type ty') cont
242 ---------------------------------
244 simplArg :: InArg -> SimplM OutArg
245 simplArg arg = simplExpr arg Stop
248 ---------------------------------
249 simplConArgs makes sure that the arguments all end up being atomic.
250 That means it may generate some Lets, hence the
253 simplConArgs :: [InArg] -> ([OutArg] -> SimplM OutExprStuff) -> SimplM OutExprStuff
254 simplConArgs [] thing_inside
257 simplConArgs (arg:args) thing_inside
258 = switchOffInlining (simplArg arg) `thenSmpl` \ arg' ->
259 -- Simplify the RHS with inlining switched off, so that
260 -- only absolutely essential things will happen.
262 simplConArgs args $ \ args' ->
264 -- If the argument ain't trivial, then let-bind it
265 if exprIsTrivial arg' then
266 thing_inside (arg' : args')
268 newId (coreExprType arg') $ \ arg_id ->
269 thing_inside (Var arg_id : args') `thenSmpl` \ res ->
270 returnSmpl (addBind (NonRec arg_id arg') res)
274 ---------------------------------
276 simplType :: InType -> SimplM OutType
278 = getTyEnv `thenSmpl` \ (ty_subst, in_scope) ->
279 returnSmpl (fullSubstTy ty_subst in_scope ty)
284 -- Find out whether the lambda is saturated,
285 -- if not zap the over-optimistic info in the binder
287 zapLambdaBndr bndr body body_cont
288 | isTyVar bndr || safe_info || definitely_saturated 20 body body_cont
289 -- The "20" is to catch pathalogical cases with bazillions of arguments
290 -- because we are using an n**2 algorithm here
291 = bndr -- No need to zap
293 = setInlinePragma (setIdDemandInfo bndr wwLazy)
297 inline_prag = getInlinePragma bndr
298 demand = getIdDemandInfo bndr
300 safe_info = is_safe_inline_prag && not (isStrict demand)
302 is_safe_inline_prag = case inline_prag of
303 ICanSafelyBeINLINEd StrictOcc nalts -> False
304 ICanSafelyBeINLINEd LazyOcc nalts -> False
307 safe_inline_prag = case inline_prag of
308 ICanSafelyBeINLINEd _ nalts
309 -> ICanSafelyBeINLINEd InsideLam nalts
312 definitely_saturated :: Int -> CoreExpr -> SimplCont -> Bool
313 definitely_saturated 0 _ _ = False -- Too expensive to find out
314 definitely_saturated n (Lam _ body) (ApplyTo _ _ _ cont) = definitely_saturated (n-1) body cont
315 definitely_saturated n (Lam _ _) other_cont = False
316 definitely_saturated n _ _ = True
319 %************************************************************************
321 \subsection{Variables}
323 %************************************************************************
328 simplVar inline_call var cont
329 = getValEnv `thenSmpl` \ (id_subst, in_scope) ->
330 case lookupVarEnv id_subst var of
332 -> zapSubstEnv (simplExprB e cont)
334 Just (SubstMe e ty_subst id_subst)
335 -> setSubstEnv (ty_subst, id_subst) (simplExprB e cont)
338 var' = case lookupVarSet in_scope var of
342 if isLocallyDefined var && not (idMustBeINLINEd var) then
344 pprTrace "simplVar:" (ppr var) var
349 getSwitchChecker `thenSmpl` \ sw_chkr ->
350 completeVar sw_chkr in_scope inline_call var' cont
352 completeVar sw_chkr in_scope inline_call var cont
354 {- MAGIC UNFOLDINGS NOT USED NOW
355 | maybeToBool maybe_magic_result
356 = tick MagicUnfold `thenSmpl_`
359 -- Look for existing specialisations before trying inlining
360 | maybeToBool maybe_specialisation
361 = tick SpecialisationDone `thenSmpl_`
362 setSubstEnv (spec_bindings, emptyVarEnv) (
363 -- See note below about zapping the substitution here
365 simplExprB spec_template remaining_cont
368 -- Don't actually inline the scrutinee when we see
369 -- case x of y { .... }
370 -- and x has unfolding (C a b). Why not? Because
371 -- we get a silly binding y = C a b. If we don't
372 -- inline knownCon can directly substitute x for y instead.
373 | has_unfolding && var_is_case_scrutinee && unfolding_is_constr
374 = knownCon (Var var) con con_args cont
376 -- Look for an unfolding. There's a binding for the
377 -- thing, but perhaps we want to inline it anyway
378 | has_unfolding && (inline_call || ok_to_inline)
379 = getEnclosingCC `thenSmpl` \ encl_cc ->
380 if must_be_unfolded || costCentreOk encl_cc var
383 tickUnfold var `thenSmpl_` (
386 -- The template is already simplified, so don't re-substitute.
387 -- This is VITAL. Consider
389 -- let y = \z -> ...x... in
391 -- We'll clone the inner \x, adding x->x' in the id_subst
392 -- Then when we inline y, we must *not* replace x by x' in
393 -- the inlined copy!!
395 if opt_D_dump_inlinings then
396 pprTrace "Inlining:" (ppr var <+> ppr unf_template) $
397 simplExprB unf_template cont
400 simplExprB unf_template cont
404 pprTrace "Inlining disallowed due to CC:\n" (ppr encl_cc <+> ppr unf_template <+> ppr (coreExprCc unf_template)) $
406 -- Can't unfold because of bad cost centre
407 rebuild (Var var) cont
409 | inline_call -- There was an InlineCall note, but we didn't inline!
410 = rebuild (Note InlineCall (Var var)) cont
413 = rebuild (Var var) cont
416 unfolding = getIdUnfolding var
418 {- MAGIC UNFOLDINGS NOT USED CURRENTLY
419 ---------- Magic unfolding stuff
420 maybe_magic_result = case unfolding of
421 MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
424 Just magic_result = maybe_magic_result
427 ---------- Unfolding stuff
428 has_unfolding = case unfolding of
429 CoreUnfolding _ _ _ -> True
431 CoreUnfolding form guidance unf_template = unfolding
433 -- overrides cost-centre business
434 must_be_unfolded = case getInlinePragma var of
435 IMustBeINLINEd -> True
438 ok_to_inline = okToInline sw_chkr in_scope var form guidance cont
439 unfolding_is_constr = case unf_template of
440 Con con _ -> conOkForAlt con
442 Con con con_args = unf_template
444 ---------- Specialisation stuff
445 ty_args = initial_ty_args cont
446 remaining_cont = drop_ty_args cont
447 maybe_specialisation = lookupSpecEnv (ppr var) (getIdSpecialisation var) ty_args
448 Just (spec_bindings, spec_template) = maybe_specialisation
450 initial_ty_args (ApplyTo _ (Type ty) (ty_subst,_) cont)
451 = fullSubstTy ty_subst in_scope ty : initial_ty_args cont
452 -- Having to do the substitution here is a bit of a bore
453 initial_ty_args other_cont = []
455 drop_ty_args (ApplyTo _ (Type _) _ cont) = drop_ty_args cont
456 drop_ty_args other_cont = other_cont
460 var_is_case_scrutinee = case cont of
461 Select _ _ _ _ _ -> True
464 ----------- costCentreOk
465 -- costCentreOk checks that it's ok to inline this thing
466 -- The time it *isn't* is this:
468 -- f x = let y = E in
469 -- scc "foo" (...y...)
471 -- Here y has a "current cost centre", and we can't inline it inside "foo",
472 -- regardless of whether E is a WHNF or not.
474 -- We can inline a top-level binding anywhere.
476 costCentreOk ccs_encl x
477 = not opt_SccProfilingOn
478 || isSubsumedCCS ccs_encl -- can unfold anything into a subsumed scope
479 || not (isLocallyDefined x)
483 %************************************************************************
485 \subsection{Bindings}
487 %************************************************************************
490 simplBind :: InBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
492 simplBind (NonRec bndr rhs) thing_inside
493 = simplTopRhs bndr rhs `thenSmpl` \ (binds, in_scope, rhs', arity) ->
494 setInScope in_scope $
495 completeBindNonRec (bndr `setIdArity` arity) rhs' thing_inside `thenSmpl` \ stuff ->
496 returnSmpl (addBinds binds stuff)
498 simplBind (Rec pairs) thing_inside
499 = simplRecBind pairs thing_inside
500 -- The assymetry between the two cases is a bit unclean
502 simplRecBind :: [(InId, InExpr)] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
503 simplRecBind pairs thing_inside
504 = simplIds (map fst pairs) $ \ bndrs' ->
505 -- NB: bndrs' don't have unfoldings or spec-envs
506 -- We add them as we go down, using simplPrags
508 go (pairs `zip` bndrs') `thenSmpl` \ (pairs', stuff) ->
509 returnSmpl (addBind (Rec pairs') stuff)
511 go [] = thing_inside `thenSmpl` \ stuff ->
512 returnSmpl ([], stuff)
514 go (((bndr, rhs), bndr') : pairs)
515 = simplTopRhs bndr rhs `thenSmpl` \ (rhs_binds, in_scope, rhs', arity) ->
516 setInScope in_scope $
517 completeBindRec bndr (bndr' `setIdArity` arity)
518 rhs' (go pairs) `thenSmpl` \ (pairs', stuff) ->
519 returnSmpl (flatten rhs_binds pairs', stuff)
521 flatten (NonRec b r : binds) prs = (b,r) : flatten binds prs
522 flatten (Rec prs1 : binds) prs2 = prs1 ++ flatten binds prs2
526 completeBindRec bndr bndr' rhs' thing_inside
527 | postInlineUnconditionally bndr etad_rhs
528 -- NB: a loop breaker never has postInlineUnconditionally True
529 -- and non-loop-breakers only have *forward* references
530 -- Hence, it's safe to discard the binding
531 = tick PostInlineUnconditionally `thenSmpl_`
532 extendIdSubst bndr (Done etad_rhs) thing_inside
535 = -- Here's the only difference from completeBindNonRec: we
536 -- don't do simplBinder first, because we've already
537 -- done simplBinder on the recursive binders
538 simplPrags bndr bndr' etad_rhs `thenSmpl` \ bndr'' ->
539 modifyInScope bndr'' $
540 thing_inside `thenSmpl` \ (pairs, res) ->
541 returnSmpl ((bndr'', etad_rhs) : pairs, res)
543 etad_rhs = etaCoreExpr rhs'
547 %************************************************************************
549 \subsection{Right hand sides}
551 %************************************************************************
553 simplRhs basically just simplifies the RHS of a let(rec).
554 It does two important optimisations though:
556 * It floats let(rec)s out of the RHS, even if they
557 are hidden by big lambdas
559 * It does eta expansion
562 simplTopRhs :: InId -> InExpr
563 -> SimplM ([OutBind], InScopeEnv, OutExpr, ArityInfo)
565 = getSubstEnv `thenSmpl` \ bndr_se ->
566 simplRhs bndr bndr_se rhs
568 simplRhs bndr bndr_se rhs
569 | idWantsToBeINLINEd bndr -- Don't inline in the RHS of something that has an
570 -- inline pragma. But be careful that the InScopeEnv that
571 -- we return does still have inlinings on!
572 = switchOffInlining (simplExpr rhs Stop) `thenSmpl` \ rhs' ->
573 getInScope `thenSmpl` \ in_scope ->
574 returnSmpl ([], in_scope, rhs', unknownArity)
577 = -- Swizzle the inner lets past the big lambda (if any)
578 mkRhsTyLam rhs `thenSmpl` \ swizzled_rhs ->
580 -- Simplify the swizzled RHS
581 simplRhs2 bndr bndr_se swizzled_rhs `thenSmpl` \ (floats, (in_scope, rhs', arity)) ->
583 if not (null floats) && exprIsWHNF rhs' then -- Do the float
584 tick LetFloatFromLet `thenSmpl_`
585 returnSmpl (floats, in_scope, rhs', arity)
587 getInScope `thenSmpl` \ in_scope ->
588 returnSmpl ([], in_scope, mkLetBinds floats rhs', arity)
591 ---------------------------------------------------------
592 Try eta expansion for RHSs
594 We need to pass in the substitution environment for the RHS, because
595 it might be different to the current one (see simplBeta, as called
596 from simplExpr for an applied lambda). The binder needs to
599 simplRhs2 bndr bndr_se (Let bind body)
600 = simplBind bind (simplRhs2 bndr bndr_se body)
602 simplRhs2 bndr bndr_se rhs
603 | null ids -- Prevent eta expansion for both thunks
604 -- (would lose sharing) and variables (nothing gained).
605 -- To see why we ignore it for thunks, consider
606 -- let f = lookup env key in (f 1, f 2)
607 -- We'd better not eta expand f just because it is
610 -- Also if there isn't a lambda at the top we use
611 -- simplExprB so that we can do (more) let-floating
612 = simplExprB rhs Stop `thenSmpl` \ (binds, (in_scope, rhs')) ->
613 returnSmpl (binds, (in_scope, rhs', unknownArity))
615 | otherwise -- Consider eta expansion
616 = getSwitchChecker `thenSmpl` \ sw_chkr ->
617 getInScope `thenSmpl` \ in_scope ->
618 simplBinders tyvars $ \ tyvars' ->
619 simplBinders ids $ \ ids' ->
621 if switchIsOn sw_chkr SimplDoLambdaEtaExpansion
622 && not (null extra_arg_tys)
624 tick EtaExpansion `thenSmpl_`
625 setSubstEnv bndr_se (mapSmpl simplType extra_arg_tys)
626 `thenSmpl` \ extra_arg_tys' ->
627 newIds extra_arg_tys' $ \ extra_bndrs' ->
628 simplExpr body (mk_cont extra_bndrs') `thenSmpl` \ body' ->
630 expanded_rhs = mkLams tyvars'
632 $ mkLams extra_bndrs' body'
633 expanded_arity = atLeastArity (no_of_ids + no_of_extras)
635 returnSmpl ([], (in_scope, expanded_rhs, expanded_arity))
638 simplExpr body Stop `thenSmpl` \ body' ->
640 unexpanded_rhs = mkLams tyvars'
642 unexpanded_arity = atLeastArity no_of_ids
644 returnSmpl ([], (in_scope, unexpanded_rhs, unexpanded_arity))
647 (tyvars, ids, body) = collectTyAndValBinders rhs
648 no_of_ids = length ids
650 potential_extra_arg_tys :: [InType] -- NB: InType
651 potential_extra_arg_tys = case splitFunTys (applyTys (idType bndr) (mkTyVarTys tyvars)) of
652 (arg_tys, _) -> drop no_of_ids arg_tys
654 extra_arg_tys :: [InType]
655 extra_arg_tys = take no_extras_wanted potential_extra_arg_tys
656 no_of_extras = length extra_arg_tys
658 no_extras_wanted = -- Use information about how many args the fn is applied to
659 (arity - no_of_ids) `max`
661 -- See if the body could obviously do with more args
662 etaExpandCount body `max`
664 -- Finally, see if it's a state transformer, in which
665 -- case we eta-expand on principle! This can waste work,
666 -- but usually doesn't
667 case potential_extra_arg_tys of
668 [ty] | ty == realWorldStatePrimTy -> 1
671 arity = arityLowerBound (getIdArity bndr)
674 mk_cont (b:bs) = ApplyTo OkToDup (Var b) emptySubstEnv (mk_cont bs)
678 %************************************************************************
682 %************************************************************************
685 simplBeta :: InId -- Binder
686 -> InExpr -> SubstEnv -- Arg, with its subst-env
687 -> InExpr -> SimplCont -- Lambda body
688 -> SimplM OutExprStuff
690 simplBeta bndr rhs rhs_se body cont
692 = pprPanic "simplBeta" ((ppr bndr <+> ppr rhs) $$ ppr cont)
695 simplBeta bndr rhs rhs_se body cont
696 | isUnLiftedType bndr_ty
697 || (isStrict (getIdDemandInfo bndr) || is_dict bndr) && not (exprIsWHNF rhs)
698 = tick Let2Case `thenSmpl_`
699 getSubstEnv `thenSmpl` \ body_se ->
701 simplExprB rhs (Select NoDup bndr [(DEFAULT, [], body)] body_se cont)
703 | preInlineUnconditionally bndr && not opt_NoPreInlining
704 = tick PreInlineUnconditionally `thenSmpl_`
705 case rhs_se of { (ty_subst, id_subst) ->
706 extendIdSubst bndr (SubstMe rhs ty_subst id_subst) $
707 simplExprB body cont }
710 = getSubstEnv `thenSmpl` \ bndr_se ->
711 setSubstEnv rhs_se (simplRhs bndr bndr_se rhs)
712 `thenSmpl` \ (floats, in_scope, rhs', arity) ->
713 setInScope in_scope $
714 completeBindNonRec (bndr `setIdArity` arity) rhs' (
716 ) `thenSmpl` \ stuff ->
717 returnSmpl (addBinds floats stuff)
719 -- Return true only for dictionary types where the dictionary
720 -- has more than one component (else we risk poking on the component
721 -- of a newtype dictionary)
722 is_dict bndr = opt_DictsStrict && isDictTy bndr_ty && isDataType bndr_ty
723 bndr_ty = idType bndr
728 - deals only with Ids, not TyVars
729 - take an already-simplified RHS
730 - always produce let bindings
732 It does *not* attempt to do let-to-case. Why? Because they are used for
735 (when let-to-case is impossible)
737 - many situations where the "rhs" is known to be a WHNF
738 (so let-to-case is inappropriate).
741 completeBindNonRec :: InId -- Binder
742 -> OutExpr -- Simplified RHS
743 -> SimplM (OutStuff a) -- Thing inside
744 -> SimplM (OutStuff a)
745 completeBindNonRec bndr rhs thing_inside
746 | isDeadBinder bndr -- This happens; for example, the case_bndr during case of
747 -- known constructor: case (a,b) of x { (p,q) -> ... }
748 -- Here x isn't mentioned in the RHS, so we don't want to
749 -- create the (dead) let-binding let x = (a,b) in ...
752 | postInlineUnconditionally bndr etad_rhs
753 = tick PostInlineUnconditionally `thenSmpl_`
754 extendIdSubst bndr (Done etad_rhs)
757 | otherwise -- Note that we use etad_rhs here
758 -- This gives maximum chance for a remaining binding
759 -- to be zapped by the indirection zapper in OccurAnal
760 = simplBinder bndr $ \ bndr' ->
761 simplPrags bndr bndr' etad_rhs `thenSmpl` \ bndr'' ->
762 modifyInScope bndr'' $
763 thing_inside `thenSmpl` \ stuff ->
764 returnSmpl (addBind (NonRec bndr'' etad_rhs) stuff)
766 etad_rhs = etaCoreExpr rhs
768 -- (simplPrags old_bndr new_bndr new_rhs) does two things
769 -- (a) it attaches the new unfolding to new_bndr
770 -- (b) it grabs the SpecEnv from old_bndr, applies the current
771 -- substitution to it, and attaches it to new_bndr
772 -- The assumption is that new_bndr, which is produced by simplBinder
773 -- has no unfolding or specenv.
775 simplPrags old_bndr new_bndr new_rhs
776 | isEmptySpecEnv spec_env
777 = returnSmpl (bndr_w_unfolding)
780 = getSimplBinderStuff `thenSmpl` \ (ty_subst, id_subst, in_scope, us) ->
782 spec_env' = substSpecEnv ty_subst in_scope (subst_val id_subst) spec_env
783 final_bndr = bndr_w_unfolding `setIdSpecialisation` spec_env'
785 returnSmpl final_bndr
787 bndr_w_unfolding = new_bndr `setIdUnfolding` mkUnfolding new_rhs
789 spec_env = getIdSpecialisation old_bndr
790 subst_val id_subst ty_subst in_scope expr
791 = substExpr ty_subst id_subst in_scope expr
795 preInlineUnconditionally :: InId -> Bool
796 -- Examines a bndr to see if it is used just once in a
797 -- completely safe way, so that it is safe to discard the binding
798 -- inline its RHS at the (unique) usage site, REGARDLESS of how
799 -- big the RHS might be. If this is the case we don't simplify
800 -- the RHS first, but just inline it un-simplified.
802 -- This is much better than first simplifying a perhaps-huge RHS
803 -- and then inlining and re-simplifying it.
805 -- NB: we don't even look at the RHS to see if it's trivial
808 -- where x is used many times, but this is the unique occurrence
809 -- of y. We should NOT inline x at all its uses, because then
810 -- we'd do the same for y -- aargh! So we must base this
811 -- pre-rhs-simplification decision solely on x's occurrences, not
813 preInlineUnconditionally bndr
814 = case getInlinePragma bndr of
815 ICanSafelyBeINLINEd InsideLam _ -> False
816 ICanSafelyBeINLINEd not_in_lam True -> True -- Not inside a lambda,
817 -- one occurrence ==> safe!
821 postInlineUnconditionally :: InId -> OutExpr -> Bool
822 -- Examines a (bndr = rhs) binding, AFTER the rhs has been simplified
823 -- It returns True if it's ok to discard the binding and inline the
824 -- RHS at every use site.
826 -- NOTE: This isn't our last opportunity to inline.
827 -- We're at the binding site right now, and
828 -- we'll get another opportunity when we get to the ocurrence(s)
830 postInlineUnconditionally bndr rhs
834 = case getInlinePragma bndr of
835 IAmALoopBreaker -> False
836 IMustNotBeINLINEd -> False
837 IAmASpecPragmaId -> False -- Don't discard SpecPrag Ids
839 ICanSafelyBeINLINEd InsideLam one_branch -> exprIsTrivial rhs
840 -- Don't inline even WHNFs inside lambdas; this
841 -- isn't the last chance; see NOTE above.
843 ICanSafelyBeINLINEd not_in_lam one_branch -> one_branch || exprIsDupable rhs
845 other -> exprIsTrivial rhs -- Duplicating is *free*
846 -- NB: Even IWantToBeINLINEd and IMustBeINLINEd are ignored here
847 -- Why? Because we don't even want to inline them into the
848 -- RHS of constructor arguments. See NOTE above
850 inlineCase bndr scrut
851 = case getInlinePragma bndr of
852 -- Not expecting IAmALoopBreaker etc; this is a case binder!
854 ICanSafelyBeINLINEd StrictOcc one_branch
855 -> one_branch || exprIsDupable scrut
856 -- This case is the entire reason we distinguish StrictOcc from LazyOcc
857 -- We want eliminate the "case" only if we aren't going to
858 -- build a thunk instead, and that's what StrictOcc finds
860 -- case (f x) of y { DEFAULT -> g y }
861 -- Here we DO NOT WANT:
863 -- *even* if g is strict. We want to avoid constructing the
864 -- thunk for (f x)! So y gets a LazyOcc.
866 other -> exprIsTrivial scrut -- Duplication is free
867 && ( isUnLiftedType (idType bndr)
868 || scrut_is_evald_var -- So dropping the case won't change termination
869 || isStrict (getIdDemandInfo bndr)) -- It's going to get evaluated later, so again
870 -- termination doesn't change
872 -- Check whether or not scrut is known to be evaluted
873 -- It's not going to be a visible value (else the previous
874 -- blob would apply) so we just check the variable case
875 scrut_is_evald_var = case scrut of
876 Var v -> isEvaldUnfolding (getIdUnfolding v)
880 okToInline is used at call sites, so it is a bit more generous.
881 It's a very important function that embodies lots of heuristics.
884 okToInline :: SwitchChecker
887 -> FormSummary -- The thing is WHNF or bottom;
890 -> Bool -- True <=> inline it
892 -- A non-WHNF can be inlined if it doesn't occur inside a lambda,
893 -- and occurs exactly once or
894 -- occurs once in each branch of a case and is small
896 -- If the thing is in WHNF, there's no danger of duplicating work,
897 -- so we can inline if it occurs once, or is small
899 okToInline sw_chkr in_scope id form guidance cont
902 if opt_D_dump_inlinings then
903 pprTrace "Considering inlining"
904 (ppr id <+> vcat [text "inline prag:" <+> ppr inline_prag,
905 text "whnf" <+> ppr whnf,
906 text "small enough" <+> ppr small_enough,
907 text "some benefit" <+> ppr some_benefit,
908 text "arg evals" <+> ppr arg_evals,
909 text "result scrut" <+> ppr result_scrut,
910 text "ANSWER =" <+> if result then text "YES" else text "NO"])
918 IAmDead -> pprTrace "okToInline: dead" (ppr id) False
919 IAmASpecPragmaId -> False
920 IMustNotBeINLINEd -> False
921 IAmALoopBreaker -> False
922 IMustBeINLINEd -> True -- If "essential_unfoldings_only" is true we do no inlinings at all,
923 -- EXCEPT for things that absolutely have to be done
924 -- (see comments with idMustBeINLINEd)
925 IWantToBeINLINEd -> inlinings_enabled
926 ICanSafelyBeINLINEd inside_lam one_branch
927 -> inlinings_enabled && (unfold_always || consider_single inside_lam one_branch)
928 NoInlinePragInfo -> inlinings_enabled && (unfold_always || consider_multi)
930 inlinings_enabled = not (switchIsOn sw_chkr EssentialUnfoldingsOnly)
931 unfold_always = unfoldAlways guidance
933 -- Consider benefit for ICanSafelyBeINLINEd
934 consider_single inside_lam one_branch
935 = (small_enough || one_branch) && some_benefit && (whnf || not_inside_lam)
937 not_inside_lam = case inside_lam of {InsideLam -> False; other -> True}
939 -- Consider benefit for NoInlinePragInfo
940 consider_multi = whnf && small_enough && some_benefit
941 -- We could consider using exprIsCheap here,
942 -- as in postInlineUnconditionally, but unlike the latter we wouldn't
943 -- necessarily eliminate a thunk; and the "form" doesn't tell
946 inline_prag = getInlinePragma id
947 whnf = whnfOrBottom form
948 small_enough = smallEnoughToInline id arg_evals result_scrut guidance
949 (arg_evals, result_scrut) = get_evals cont
951 -- some_benefit checks that *something* interesting happens to
952 -- the variable after it's inlined.
953 some_benefit = contIsInteresting cont
955 -- Finding out whether the args are evaluated. This isn't completely easy
956 -- because the args are not yet simplified, so we have to peek into them.
957 get_evals (ApplyTo _ arg (te,ve) cont)
958 | isValArg arg = case get_evals cont of
959 (args, res) -> (get_arg_eval arg ve : args, res)
960 | otherwise = get_evals cont
962 get_evals (Select _ _ _ _ _) = ([], True)
963 get_evals other = ([], False)
965 get_arg_eval (Con con _) ve = isWHNFCon con
966 get_arg_eval (Var v) ve = case lookupVarEnv ve v of
967 Just (SubstMe e' _ ve') -> get_arg_eval e' ve'
968 Just (Done (Con con _)) -> isWHNFCon con
969 Just (Done (Var v')) -> get_var_eval v'
970 Just (Done other) -> False
971 Nothing -> get_var_eval v
972 get_arg_eval other ve = False
974 get_var_eval v = case lookupVarSet in_scope v of
975 Just v' -> isEvaldUnfolding (getIdUnfolding v')
976 Nothing -> isEvaldUnfolding (getIdUnfolding v)
979 contIsInteresting :: SimplCont -> Bool
980 contIsInteresting Stop = False
981 contIsInteresting (ArgOf _ _ _) = False
982 contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont
983 contIsInteresting (CoerceIt _ _ _ cont) = contIsInteresting cont
985 -- See notes below on why a case with only a DEFAULT case is not intersting
986 -- contIsInteresting (Select _ _ [(DEFAULT,_,_)] _ _) = False
988 contIsInteresting _ = True
991 Comment about some_benefit above
992 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
994 We want to avoid inlining an expression where there can't possibly be
995 any gain, such as in an argument position. Hence, if the continuation
996 is interesting (eg. a case scrutinee, application etc.) then we
997 inline, otherwise we don't.
999 Previously some_benefit used to return True only if the variable was
1000 applied to some value arguments. This didn't work:
1002 let x = _coerce_ (T Int) Int (I# 3) in
1003 case _coerce_ Int (T Int) x of
1006 we want to inline x, but can't see that it's a constructor in a case
1007 scrutinee position, and some_benefit is False.
1011 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
1013 .... case dMonadST _@_ x0 of (a,b,c) -> ....
1015 we'd really like to inline dMonadST here, but we *don't* want to
1016 inline if the case expression is just
1018 case x of y { DEFAULT -> ... }
1020 since we can just eliminate this case instead (x is in WHNF). Similar
1021 applies when x is bound to a lambda expression. Hence
1022 contIsInteresting looks for case expressions with just a single
1026 %************************************************************************
1028 \subsection{The main rebuilder}
1030 %************************************************************************
1033 -------------------------------------------------------------------
1034 rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff
1037 = tick LeavesExamined `thenSmpl_`
1039 Var v -> case getIdStrictness v of
1040 NoStrictnessInfo -> do_rebuild expr cont
1041 StrictnessInfo demands result_bot -> ASSERT( not (null demands) || result_bot )
1042 -- If this happened we'd get an infinite loop
1043 rebuild_strict demands result_bot expr (idType v) cont
1044 other -> do_rebuild expr cont
1047 = getInScope `thenSmpl` \ in_scope ->
1048 returnSmpl ([], (in_scope, expr))
1050 ---------------------------------------------------------
1051 -- Stop continuation
1053 do_rebuild expr Stop = rebuild_done expr
1056 ---------------------------------------------------------
1057 -- ArgOf continuation
1059 do_rebuild expr (ArgOf _ cont_fn _) = cont_fn expr
1061 ---------------------------------------------------------
1062 -- ApplyTo continuation
1064 do_rebuild expr cont@(ApplyTo _ arg se cont')
1065 = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
1066 do_rebuild (App expr arg') cont'
1069 ---------------------------------------------------------
1070 -- Coerce continuation
1072 do_rebuild expr (CoerceIt _ to_ty se cont)
1074 simplType to_ty `thenSmpl` \ to_ty' ->
1075 do_rebuild (mk_coerce to_ty' expr) cont
1078 ---------------------------------------------------------
1079 -- Case of known constructor or literal
1081 do_rebuild expr@(Con con args) cont@(Select _ _ _ _ _)
1082 | conOkForAlt con -- Knocks out PrimOps and NoRepLits
1083 = knownCon expr con args cont
1086 ---------------------------------------------------------
1088 -- Case of other value (e.g. a partial application or lambda)
1089 -- Turn it back into a let
1091 do_rebuild expr (Select _ bndr ((DEFAULT, bs, rhs):alts) se cont)
1092 | case mkFormSummary expr of { ValueForm -> True; other -> False }
1093 = ASSERT( null bs && null alts )
1094 tick Case2Let `thenSmpl_`
1096 completeBindNonRec bndr expr $
1101 ---------------------------------------------------------
1102 -- The other Select cases
1104 do_rebuild scrut (Select _ bndr alts se cont)
1105 = getSwitchChecker `thenSmpl` \ chkr ->
1107 if all (cheapEqExpr rhs1) other_rhss
1108 && inlineCase bndr scrut
1109 && all binders_unused alts
1110 && switchIsOn chkr SimplDoCaseElim
1112 -- Get rid of the case altogether
1113 -- See the extensive notes on case-elimination below
1114 -- Remember to bind the binder though!
1115 tick CaseElim `thenSmpl_`
1117 extendIdSubst bndr (Done scrut) $
1118 simplExprB rhs1 cont
1122 rebuild_case chkr scrut bndr alts se cont
1124 (rhs1:other_rhss) = [rhs | (_,_,rhs) <- alts]
1125 binders_unused (_, bndrs, _) = all isDeadBinder bndrs
1128 Case elimination [see the code above]
1130 Start with a simple situation:
1132 case x# of ===> e[x#/y#]
1135 (when x#, y# are of primitive type, of course). We can't (in general)
1136 do this for algebraic cases, because we might turn bottom into
1139 Actually, we generalise this idea to look for a case where we're
1140 scrutinising a variable, and we know that only the default case can
1145 other -> ...(case x of
1149 Here the inner case can be eliminated. This really only shows up in
1150 eliminating error-checking code.
1152 We also make sure that we deal with this very common case:
1157 Here we are using the case as a strict let; if x is used only once
1158 then we want to inline it. We have to be careful that this doesn't
1159 make the program terminate when it would have diverged before, so we
1161 - x is used strictly, or
1162 - e is already evaluated (it may so if e is a variable)
1164 Lastly, we generalise the transformation to handle this:
1170 We only do this for very cheaply compared r's (constructors, literals
1171 and variables). If pedantic bottoms is on, we only do it when the
1172 scrutinee is a PrimOp which can't fail.
1174 We do it *here*, looking at un-simplified alternatives, because we
1175 have to check that r doesn't mention the variables bound by the
1176 pattern in each alternative, so the binder-info is rather useful.
1178 So the case-elimination algorithm is:
1180 1. Eliminate alternatives which can't match
1182 2. Check whether all the remaining alternatives
1183 (a) do not mention in their rhs any of the variables bound in their pattern
1184 and (b) have equal rhss
1186 3. Check we can safely ditch the case:
1187 * PedanticBottoms is off,
1188 or * the scrutinee is an already-evaluated variable
1189 or * the scrutinee is a primop which is ok for speculation
1190 -- ie we want to preserve divide-by-zero errors, and
1191 -- calls to error itself!
1193 or * [Prim cases] the scrutinee is a primitive variable
1195 or * [Alg cases] the scrutinee is a variable and
1196 either * the rhs is the same variable
1197 (eg case x of C a b -> x ===> x)
1198 or * there is only one alternative, the default alternative,
1199 and the binder is used strictly in its scope.
1200 [NB this is helped by the "use default binder where
1201 possible" transformation; see below.]
1204 If so, then we can replace the case with one of the rhss.
1208 ---------------------------------------------------------
1209 -- Rebuiling a function with strictness info
1210 -- This just a version of do_rebuild, enhanced with info about
1211 -- the strictness of the thing being rebuilt.
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 (CoerceIt _ to_ty se cont)
1223 simplType to_ty `thenSmpl` \ to_ty' ->
1224 rebuild_strict ds result_bot (mk_coerce to_ty' fun) to_ty' cont
1226 rebuild_strict ds result_bot fun fun_ty (ApplyTo _ (Type ty_arg) se cont)
1227 -- Type arg; don't consume a demand
1228 = setSubstEnv se (simplType ty_arg) `thenSmpl` \ ty_arg' ->
1229 rebuild_strict ds result_bot (App fun (Type ty_arg'))
1230 (applyTy fun_ty ty_arg') cont
1232 rebuild_strict (d:ds) result_bot fun fun_ty (ApplyTo _ val_arg se cont)
1233 | isStrict d || isUnLiftedType arg_ty
1234 -- Strict value argument
1235 = getInScope `thenSmpl` \ in_scope ->
1237 cont_ty = contResultType in_scope res_ty cont
1239 setSubstEnv se (simplExprB val_arg (ArgOf NoDup cont_fn cont_ty))
1241 | otherwise -- Lazy value argument
1242 = setSubstEnv se (simplArg val_arg) `thenSmpl` \ val_arg' ->
1246 Just (arg_ty, res_ty) = splitFunTy_maybe fun_ty
1247 cont_fn arg' = rebuild_strict ds result_bot
1248 (App fun arg') res_ty
1251 rebuild_strict ds result_bot fun fun_ty cont = do_rebuild fun cont
1253 ---------------------------------------------------------
1255 -- * case (error "hello") of { ... }
1256 -- * (error "Hello") arg
1257 -- * f (error "Hello") where f is strict
1260 rebuild_bot expr expr_ty Stop -- No coerce needed
1263 rebuild_bot expr expr_ty (CoerceIt _ to_ty se Stop) -- Don't "tick" on this,
1264 -- else simplifier never stops
1266 simplType to_ty `thenSmpl` \ to_ty' ->
1267 rebuild_done (mkNote (Coerce to_ty' expr_ty) expr)
1269 rebuild_bot expr expr_ty cont -- Abandon the (strict) continuation,
1270 -- and just return expr
1271 = tick CaseOfError `thenSmpl_`
1272 getInScope `thenSmpl` \ in_scope ->
1274 result_ty = contResultType in_scope expr_ty cont
1276 rebuild_done (mkNote (Coerce result_ty expr_ty) expr)
1278 mk_coerce to_ty (Note (Coerce _ from_ty) expr) = Note (Coerce to_ty from_ty) expr
1279 mk_coerce to_ty expr = Note (Coerce to_ty (coreExprType expr)) expr
1282 Blob of helper functions for the "case-of-something-else" situation.
1285 ---------------------------------------------------------
1286 -- Case of something else
1288 rebuild_case sw_chkr scrut case_bndr alts se cont
1289 = -- Prepare case alternatives
1290 prepareCaseAlts (splitTyConApp_maybe (idType case_bndr))
1291 scrut_cons alts `thenSmpl` \ better_alts ->
1293 -- Set the new subst-env in place (before dealing with the case binder)
1296 -- Deal with the case binder, and prepare the continuation;
1297 -- The new subst_env is in place
1298 simplBinder case_bndr $ \ case_bndr' ->
1299 prepareCaseCont better_alts cont $ \ cont' ->
1302 -- Deal with variable scrutinee
1303 substForVarScrut scrut case_bndr' $ \ zap_occ_info ->
1305 case_bndr'' = zap_occ_info case_bndr'
1308 -- Deal with the case alternaatives
1309 simplAlts zap_occ_info scrut_cons
1310 case_bndr'' better_alts cont' `thenSmpl` \ alts' ->
1312 mkCase sw_chkr scrut case_bndr'' alts' `thenSmpl` \ case_expr ->
1313 rebuild_done case_expr
1315 -- scrut_cons tells what constructors the scrutinee can't possibly match
1316 scrut_cons = case scrut of
1317 Var v -> case getIdUnfolding v of
1318 OtherCon cons -> cons
1323 knownCon expr con args (Select _ bndr alts se cont)
1324 = tick KnownBranch `thenSmpl_`
1326 case findAlt con alts of
1327 (DEFAULT, bs, rhs) -> ASSERT( null bs )
1328 completeBindNonRec bndr expr $
1331 (Literal lit, bs, rhs) -> ASSERT( null bs )
1332 extendIdSubst bndr (Done expr) $
1333 -- Unconditionally substitute, because expr must
1334 -- be a variable or a literal. It can't be a
1335 -- NoRep literal because they don't occur in
1339 (DataCon dc, bs, rhs) -> completeBindNonRec bndr expr $
1340 extend bs real_args $
1343 real_args = drop (dataConNumInstArgs dc) args
1346 extend [] [] thing_inside = thing_inside
1347 extend (b:bs) (arg:args) thing_inside = extendIdSubst b (Done arg) $
1348 extend bs args thing_inside
1352 prepareCaseCont :: [InAlt] -> SimplCont
1353 -> (SimplCont -> SimplM (OutStuff a))
1354 -> SimplM (OutStuff a)
1355 -- Polymorphic recursion here!
1357 prepareCaseCont [alt] cont thing_inside = thing_inside cont
1358 prepareCaseCont alts cont thing_inside = mkDupableCont (coreAltsType alts) cont thing_inside
1361 substForVarScrut checks whether the scrutinee is a variable, v.
1362 If so, try to eliminate uses of v in the RHSs in favour of case_bndr;
1363 that way, there's a chance that v will now only be used once, and hence inlined.
1365 If we do this, then we have to nuke any occurrence info (eg IAmDead)
1366 in the case binder, because the case-binder now effectively occurs
1367 whenever v does. AND we have to do the same for the pattern-bound
1370 (case x of { (a,b) -> a }) (case x of { (p,q) -> q })
1372 Here, b and p are dead. But when we move the argment inside the first
1373 case RHS, and eliminate the second case, we get
1375 case x or { (a,b) -> a b
1377 Urk! b is alive! Reason: the scrutinee was a variable, and case elimination
1378 happened. Hence the zap_occ_info function returned by substForVarScrut
1381 substForVarScrut (Var v) case_bndr' thing_inside
1382 | isLocallyDefined v -- No point for imported things
1383 = modifyInScope (v `setIdUnfolding` mkUnfolding (Var case_bndr')
1384 `setInlinePragma` IMustBeINLINEd) $
1385 -- We could extend the substitution instead, but it would be
1386 -- a hack because then the substitution wouldn't be idempotent
1388 thing_inside (\ bndr -> bndr `setInlinePragma` NoInlinePragInfo)
1390 substForVarScrut other_scrut case_bndr' thing_inside
1391 = thing_inside (\ bndr -> bndr) -- NoOp on bndr
1394 prepareCaseAlts does two things:
1396 1. Remove impossible alternatives
1398 2. If the DEFAULT alternative can match only one possible constructor,
1399 then make that constructor explicit.
1401 case e of x { DEFAULT -> rhs }
1403 case e of x { (a,b) -> rhs }
1404 where the type is a single constructor type. This gives better code
1405 when rhs also scrutinises x or e.
1408 prepareCaseAlts (Just (tycon, inst_tys)) scrut_cons alts
1410 = case (findDefault filtered_alts, missing_cons) of
1412 ((alts_no_deflt, Just rhs), [data_con]) -- Just one missing constructor!
1413 -> tick FillInCaseDefault `thenSmpl_`
1415 (_,_,ex_tyvars,_,_,_) = dataConSig data_con
1417 getUniquesSmpl (length ex_tyvars) `thenSmpl` \ tv_uniqs ->
1419 ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars
1420 mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
1422 newIds (dataConArgTys
1424 (inst_tys ++ mkTyVarTys ex_tyvars')) $ \ bndrs ->
1425 returnSmpl ((DataCon data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt)
1427 other -> returnSmpl filtered_alts
1429 -- Filter out alternatives that can't possibly match
1430 filtered_alts = case scrut_cons of
1432 other -> [alt | alt@(con,_,_) <- alts, not (con `elem` scrut_cons)]
1434 missing_cons = [data_con | data_con <- tyConDataCons tycon,
1435 not (data_con `elem` handled_data_cons)]
1436 handled_data_cons = [data_con | DataCon data_con <- scrut_cons] ++
1437 [data_con | (DataCon data_con, _, _) <- filtered_alts]
1440 prepareCaseAlts _ scrut_cons alts
1441 = returnSmpl alts -- Functions
1444 ----------------------
1445 simplAlts zap_occ_info scrut_cons case_bndr'' alts cont'
1446 = mapSmpl simpl_alt alts
1448 inst_tys' = case splitTyConApp_maybe (idType case_bndr'') of
1449 Just (tycon, inst_tys) -> inst_tys
1451 -- handled_cons is all the constructors that are dealt
1452 -- with, either by being impossible, or by there being an alternative
1453 handled_cons = scrut_cons ++ [con | (con,_,_) <- alts, con /= DEFAULT]
1455 simpl_alt (DEFAULT, _, rhs)
1456 = -- In the default case we record the constructors that the
1457 -- case-binder *can't* be.
1458 -- We take advantage of any OtherCon info in the case scrutinee
1459 modifyInScope (case_bndr'' `setIdUnfolding` OtherCon handled_cons) $
1460 simplExpr rhs cont' `thenSmpl` \ rhs' ->
1461 returnSmpl (DEFAULT, [], rhs')
1463 simpl_alt (con, vs, rhs)
1464 = -- Deal with the pattern-bound variables
1465 -- Mark the ones that are in ! positions in the data constructor
1466 -- as certainly-evaluated
1467 simplBinders (add_evals con vs) $ \ vs' ->
1469 -- Bind the case-binder to (Con args)
1471 con_app = Con con (map Type inst_tys' ++ map varToCoreExpr vs')
1473 modifyInScope (case_bndr'' `setIdUnfolding` mkUnfolding con_app) $
1474 simplExpr rhs cont' `thenSmpl` \ rhs' ->
1475 returnSmpl (con, vs', rhs')
1478 -- add_evals records the evaluated-ness of the bound variables of
1479 -- a case pattern. This is *important*. Consider
1480 -- data T = T !Int !Int
1482 -- case x of { T a b -> T (a+1) b }
1484 -- We really must record that b is already evaluated so that we don't
1485 -- go and re-evaluate it when constructing the result.
1487 add_evals (DataCon dc) vs = cat_evals vs (dataConStrictMarks dc)
1488 add_evals other_con vs = vs
1490 cat_evals [] [] = []
1491 cat_evals (v:vs) (str:strs)
1492 | isTyVar v = cat_evals vs (str:strs)
1496 (zap_occ_info v `setIdUnfolding` OtherCon [])
1498 MarkedUnboxed con _ ->
1499 cat_evals (v:vs) (dataConStrictMarks con ++ strs)
1500 NotMarkedStrict -> zap_occ_info v : cat_evals vs strs
1505 %************************************************************************
1507 \subsection{Duplicating continuations}
1509 %************************************************************************
1512 mkDupableCont :: InType -- Type of the thing to be given to the continuation
1514 -> (SimplCont -> SimplM (OutStuff a))
1515 -> SimplM (OutStuff a)
1516 mkDupableCont ty cont thing_inside
1517 | contIsDupable cont
1520 mkDupableCont _ (CoerceIt _ ty se cont) thing_inside
1521 = mkDupableCont ty cont $ \ cont' ->
1522 thing_inside (CoerceIt OkToDup ty se cont')
1524 mkDupableCont join_arg_ty (ArgOf _ cont_fn res_ty) thing_inside
1525 = -- Build the RHS of the join point
1526 simplType join_arg_ty `thenSmpl` \ join_arg_ty' ->
1527 newId join_arg_ty' ( \ arg_id ->
1528 getSwitchChecker `thenSmpl` \ chkr ->
1529 cont_fn (Var arg_id) `thenSmpl` \ (binds, (_, rhs)) ->
1530 returnSmpl (Lam arg_id (mkLetBinds binds rhs))
1531 ) `thenSmpl` \ join_rhs ->
1533 -- Build the join Id and continuation
1534 newId (coreExprType join_rhs) $ \ join_id ->
1536 new_cont = ArgOf OkToDup
1537 (\arg' -> rebuild_done (App (Var join_id) arg'))
1541 -- Do the thing inside
1542 thing_inside new_cont `thenSmpl` \ res ->
1543 returnSmpl (addBind (NonRec join_id join_rhs) res)
1545 mkDupableCont ty (ApplyTo _ arg se cont) thing_inside
1546 = mkDupableCont (funResultTy ty) cont $ \ cont' ->
1547 setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
1548 if exprIsDupable arg' then
1549 thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont')
1551 newId (coreExprType arg') $ \ bndr ->
1552 thing_inside (ApplyTo OkToDup (Var bndr) emptySubstEnv cont') `thenSmpl` \ res ->
1553 returnSmpl (addBind (NonRec bndr arg') res)
1555 mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside
1556 = tick CaseOfCase `thenSmpl_` (
1558 simplBinder case_bndr $ \ case_bndr' ->
1559 prepareCaseCont alts cont $ \ cont' ->
1560 mapAndUnzipSmpl (mkDupableAlt case_bndr' cont') alts `thenSmpl` \ (alt_binds_s, alts') ->
1561 returnSmpl (concat alt_binds_s, (case_bndr', alts'))
1562 ) `thenSmpl` \ (alt_binds, (case_bndr', alts')) ->
1564 extendInScopes [b | NonRec b _ <- alt_binds] $
1565 thing_inside (Select OkToDup case_bndr' alts' emptySubstEnv Stop) `thenSmpl` \ res ->
1566 returnSmpl (addBinds alt_binds res)
1569 mkDupableAlt :: OutId -> SimplCont -> InAlt -> SimplM (OutStuff CoreAlt)
1570 mkDupableAlt case_bndr' cont alt@(con, bndrs, rhs)
1571 = simplBinders bndrs $ \ bndrs' ->
1572 simplExpr rhs cont `thenSmpl` \ rhs' ->
1573 if exprIsDupable rhs' then
1574 -- It's small, so don't bother to let-bind it
1575 returnSmpl ([], (con, bndrs', rhs'))
1577 -- It's big, so let-bind it
1579 rhs_ty' = coreExprType rhs'
1580 used_bndrs' = filter (not . isDeadBinder) (case_bndr' : bndrs')
1582 ( if null used_bndrs' && isUnLiftedType rhs_ty'
1583 then newId realWorldStatePrimTy $ \ rw_id ->
1584 returnSmpl ([rw_id], [varToCoreExpr realWorldPrimId])
1586 returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
1588 `thenSmpl` \ (final_bndrs', final_args) ->
1590 -- If we try to lift a primitive-typed something out
1591 -- for let-binding-purposes, we will *caseify* it (!),
1592 -- with potentially-disastrous strictness results. So
1593 -- instead we turn it into a function: \v -> e
1594 -- where v::State# RealWorld#. The value passed to this function
1595 -- is realworld#, which generates (almost) no code.
1597 -- There's a slight infelicity here: we pass the overall
1598 -- case_bndr to all the join points if it's used in *any* RHS,
1599 -- because we don't know its usage in each RHS separately
1601 newId (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr ->
1602 returnSmpl ([NonRec join_bndr (mkLams final_bndrs' rhs')],
1603 (con, bndrs', mkApps (Var join_bndr) final_args))