import CoreSyn
import Demand ( isStrictDmd )
import PprCore ( pprParendExpr, pprCoreExpr )
-import CoreUnfold ( mkUnfolding, mkCoreUnfolding
- , mkInlineUnfolding, mkSimpleUnfolding
- , exprIsConApp_maybe, callSiteInline, CallCtxt(..) )
+import CoreUnfold
import CoreUtils
import qualified CoreSubst
import CoreArity
import TysPrim ( realWorldStatePrimTy )
import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
import MonadUtils ( foldlM, mapAccumLM )
-import Maybes ( orElse )
+import Maybes ( orElse, isNothing )
import Data.List ( mapAccumL )
import Outputable
import FastString
; (new_arity, final_rhs) <- tryEtaExpand env new_bndr new_rhs
-- Simplify the unfolding
- ; new_unfolding <- simplUnfolding env top_lvl old_bndr occ_info final_rhs old_unf
+ ; new_unfolding <- simplUnfolding env top_lvl old_bndr final_rhs old_unf
; if postInlineUnconditionally env top_lvl new_bndr occ_info final_rhs new_unfolding
-- Inline and discard the binding
-- opportunity to inline 'y' too.
addPolyBind top_lvl env (NonRec poly_id rhs)
- = do { unfolding <- simplUnfolding env top_lvl poly_id NoOccInfo rhs noUnfolding
+ = do { unfolding <- simplUnfolding env top_lvl poly_id rhs noUnfolding
-- Assumes that poly_id did not have an INLINE prag
-- which is perhaps wrong. ToDo: think about this
; let final_id = setIdInfo poly_id $
------------------------------
simplUnfolding :: SimplEnv-> TopLevelFlag
- -> Id
- -> OccInfo -> OutExpr
+ -> InId
+ -> OutExpr
-> Unfolding -> SimplM Unfolding
-- Note [Setting the new unfolding]
-simplUnfolding env _ _ _ _ (DFunUnfolding ar con ops)
+simplUnfolding env _ _ _ (DFunUnfolding ar con ops)
= return (DFunUnfolding ar con ops')
where
- ops' = map (substExpr (text "simplUnfolding") env) ops
+ ops' = map (fmap (substExpr (text "simplUnfolding") env)) ops
-simplUnfolding env top_lvl id _ _
+simplUnfolding env top_lvl id _
(CoreUnfolding { uf_tmpl = expr, uf_arity = arity
, uf_src = src, uf_guidance = guide })
| isStableSource src
; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src
is_top_lvl = isTopLevel top_lvl
; case guide of
- UnfIfGoodArgs{} ->
- -- We need to force bottoming, or the new unfolding holds
- -- on to the old unfolding (which is part of the id).
- let bottoming = isBottomingId id
- in bottoming `seq` return (mkUnfolding src' is_top_lvl bottoming expr')
+ UnfWhen sat_ok _ -- Happens for INLINE things
+ -> let guide' = UnfWhen sat_ok (inlineBoringOk expr')
+ -- Refresh the boring-ok flag, in case expr'
+ -- has got small. This happens, notably in the inlinings
+ -- for dfuns for single-method classes; see
+ -- Note [Single-method classes] in TcInstDcls.
+ -- A test case is Trac #4138
+ in return (mkCoreUnfolding src' is_top_lvl expr' arity guide')
+ -- See Note [Top-level flag on inline rules] in CoreUnfold
+
+ _other -- Happens for INLINABLE things
+ -> let bottoming = isBottomingId id
+ in bottoming `seq` -- See Note [Force bottoming field]
+ return (mkUnfolding src' is_top_lvl bottoming expr')
-- If the guidance is UnfIfGoodArgs, this is an INLINABLE
-- unfolding, and we need to make sure the guidance is kept up
-- to date with respect to any changes in the unfolding.
- _other ->
- return (mkCoreUnfolding src' is_top_lvl expr' arity guide)
- -- See Note [Top-level flag on inline rules] in CoreUnfold
}
where
act = idInlineActivation id
rule_env = updMode (updModeForInlineRules act) env
-- See Note [Simplifying inside InlineRules] in SimplUtils
-simplUnfolding _ top_lvl id _occ_info new_rhs _
- = -- We need to force bottoming, or the new unfolding holds
- -- on to the old unfolding (which is part of the id).
- let bottoming = isBottomingId id
- in bottoming `seq` return (mkUnfolding InlineRhs (isTopLevel top_lvl) bottoming new_rhs)
- -- We make an unfolding *even for loop-breakers*.
- -- Reason: (a) It might be useful to know that they are WHNF
- -- (b) In TidyPgm we currently assume that, if we want to
- -- expose the unfolding then indeed we *have* an unfolding
- -- to expose. (We could instead use the RHS, but currently
- -- we don't.) The simple thing is always to have one.
+simplUnfolding _ top_lvl id new_rhs _
+ = let bottoming = isBottomingId id
+ in bottoming `seq` -- See Note [Force bottoming field]
+ return (mkUnfolding InlineRhs (isTopLevel top_lvl) bottoming new_rhs)
+ -- We make an unfolding *even for loop-breakers*.
+ -- Reason: (a) It might be useful to know that they are WHNF
+ -- (b) In TidyPgm we currently assume that, if we want to
+ -- expose the unfolding then indeed we *have* an unfolding
+ -- to expose. (We could instead use the RHS, but currently
+ -- we don't.) The simple thing is always to have one.
\end{code}
+Note [Force bottoming field]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to force bottoming, or the new unfolding holds
+on to the old unfolding (which is part of the id).
+
Note [Arity decrease]
~~~~~~~~~~~~~~~~~~~~~
Generally speaking the arity of a binding should not decrease. But it *can*
%* *
%************************************************************************
+Note [Zap unfolding when beta-reducing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Lambda-bound variables can have stable unfoldings, such as
+ $j = \x. \b{Unf=Just x}. e
+See Note [Case binders and join points] below; the unfolding for lets
+us optimise e better. However when we beta-reduce it we want to
+revert to using the actual value, otherwise we can end up in the
+stupid situation of
+ let x = blah in
+ let b{Unf=Just x} = y
+ in ...b...
+Here it'd be far better to drop the unfolding and use the actual RHS.
+
\begin{code}
simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont
-> SimplM (SimplEnv, OutExpr)
-- Beta reduction
simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont)
= do { tick (BetaReduction bndr)
- ; simplNonRecE env bndr (arg, arg_se) (bndrs, body) cont }
+ ; simplNonRecE env (zap_unfolding bndr) (arg, arg_se) (bndrs, body) cont }
+ where
+ zap_unfolding bndr -- See Note [Zap unfolding when beta-reducing]
+ | isId bndr, isStableUnfolding (realIdUnfolding bndr)
+ = setIdUnfolding bndr NoUnfolding
+ | otherwise = bndr
-- Not enough args, so there are real lambdas left to put in the result
simplLam env bndrs body cont
| not (dopt Opt_D_dump_inlinings dflags) = stuff
| not (dopt Opt_D_verbose_core2core dflags)
= if isExternalName (idName var) then
- pprTrace "Inlining done:" (ppr var) stuff
+ pprDefiniteTrace "Inlining done:" (ppr var) stuff
else stuff
| otherwise
- = pprTrace ("Inlining done: " ++ showSDoc (ppr var))
+ = pprDefiniteTrace ("Inlining done: " ++ showSDoc (ppr var))
(vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),
text "Cont: " <+> ppr cont])
stuff
trace_dump dflags rule rule_rhs stuff
| not (dopt Opt_D_dump_rule_firings dflags)
, not (dopt Opt_D_dump_rule_rewrites dflags) = stuff
+
| not (dopt Opt_D_dump_rule_rewrites dflags)
+ = pprDefiniteTrace "Rule fired:" (ftext (ru_name rule)) stuff
- = pprTrace "Rule fired:" (ftext (ru_name rule)) stuff
| otherwise
- = pprTrace "Rule fired"
+ = pprDefiniteTrace "Rule fired"
(vcat [text "Rule:" <+> ftext (ru_name rule),
text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args)),
text "After: " <+> pprCoreExpr rule_rhs,
%************************************************************************
%* *
- Rebuilding a cse expression
+ Rebuilding a case expression
%* *
%************************************************************************
The case-elimination transformation discards redundant case expressions.
Start with a simple situation:
- case x# of ===> e[x#/y#]
+ case x# of ===> let y# = x# in e
y# -> e
(when x#, y# are of primitive type, of course). We can't (in general)
DEFAULT, after which it's an instance of the previous case. This
really only shows up in eliminating error-checking code.
-We also make sure that we deal with this very common case:
-
- case e of
- x -> ...x...
-
-Here we are using the case as a strict let; if x is used only once
-then we want to inline it. We have to be careful that this doesn't
-make the program terminate when it would have diverged before, so we
-check that
- - e is already evaluated (it may so if e is a variable)
- - x is used strictly, or
-
-Lastly, the code in SimplUtils.mkCase combines identical RHSs. So
+Note that SimplUtils.mkCase combines identical RHSs. So
case e of ===> case e of DEFAULT -> r
True -> r
False -> r
Now again the case may be elminated by the CaseElim transformation.
+This includes things like (==# a# b#)::Bool so that we simplify
+ case ==# a# b# of { True -> x; False -> x }
+to just
+ x
+This particular example shows up in default methods for
+comparision operations (e.g. in (>=) for Int.Int32)
Note [CaseElimination: lifted case]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We do not use exprOkForSpeculation in the lifted case. Consider
+We also make sure that we deal with this very common case,
+where x has a lifted type:
+
+ case e of
+ x -> ...x...
+
+Here we are using the case as a strict let; if x is used only once
+then we want to inline it. We have to be careful that this doesn't
+make the program terminate when it would have diverged before, so we
+check that
+ (a) 'e' is already evaluated (it may so if e is a variable)
+ Specifically we check (exprIsHNF e)
+or
+ (b) the scrutinee is a variable and 'x' is used strictly
+or
+ (c) 'x' is not used at all and e is ok-for-speculation
+
+For the (c), consider
case (case a ># b of { True -> (p,q); False -> (q,p) }) of
r -> blah
The scrutinee is ok-for-speculation (it looks inside cases), but we do
-- then there is now only one (DEFAULT) rhs
| all isDeadBinder bndrs -- bndrs are [InId]
- -- Check that the scrutinee can be let-bound instead of case-bound
, if isUnLiftedType (idType case_bndr)
- then exprOkForSpeculation scrut
- -- Satisfy the let-binding invariant
- -- This includes things like (==# a# b#)::Bool
- -- so that we simplify
- -- case ==# a# b# of { True -> x; False -> x }
- -- to just
- -- x
- -- This particular example shows up in default methods for
- -- comparision operations (e.g. in (>=) for Int.Int32)
-
- else exprIsHNF scrut || var_demanded_later scrut
- -- It's already evaluated, or will be demanded later
- -- See Note [Case elimination: lifted case]
+ then ok_for_spec -- Satisfy the let-binding invariant
+ else elim_lifted
= do { tick (CaseElim case_bndr)
; env' <- simplNonRecX env case_bndr scrut
-- If case_bndr is deads, simplNonRecX will discard
; simplExprF env' rhs cont }
where
- -- The case binder is going to be evaluated later,
- -- and the scrutinee is a simple variable
- var_demanded_later (Var v) = isStrictDmd (idDemandInfo case_bndr)
- && not (isTickBoxOp v)
+ elim_lifted -- See Note [Case elimination: lifted case]
+ = exprIsHNF scrut
+ || (strict_case_bndr && scrut_is_var scrut)
+ -- The case binder is going to be evaluated later,
+ -- and the scrutinee is a simple variable
+
+ || (is_plain_seq && ok_for_spec)
+ -- Note: not the same as exprIsHNF
+
+ ok_for_spec = exprOkForSpeculation scrut
+ is_plain_seq = isDeadBinder case_bndr -- Evaluation *only* for effect
+ strict_case_bndr = isStrictDmd (idDemandInfo case_bndr)
+
+ scrut_is_var (Cast s _) = scrut_is_var s
+ scrut_is_var (Var v) = not (isTickBoxOp v)
-- ugly hack; covering this case is what
-- exprOkForSpeculation was intended for.
- var_demanded_later _ = False
+ scrut_is_var _ = False
+
--------------------------------------------------
-- 3. Try seq rules; see Note [User-defined RULES for seq] in MkId
In practice, the scrutinee is almost always a variable, so we pretty
much always zap the OccInfo of the binders. It doesn't matter much though.
-
-Note [Case of cast]
-~~~~~~~~~~~~~~~~~~~
-Consider case (v `cast` co) of x { I# y ->
- ... (case (v `cast` co) of {...}) ...
-We'd like to eliminate the inner case. We can get this neatly by
-arranging that inside the outer case we add the unfolding
- v |-> x `cast` (sym co)
-to v. Then we should inline v at the inner case, cancel the casts, and away we go
-
Note [Improving seq]
~~~~~~~~~~~~~~~~~~~
Consider
so that 'rhs' can take advantage of the form of x'.
-Notice that Note [Case of cast] may then apply to the result.
+Notice that Note [Case of cast] (in OccurAnal) may then apply to the result.
Nota Bene: We only do the [Improving seq] transformation if the
case binder 'x' is actually used in the rhs; that is, if the case
; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts
- ; alts' <- mapM (simplAlt alt_env' imposs_deflt_cons case_bndr' cont') in_alts
+ ; let mb_var_scrut = case scrut' of { Var v -> Just v; _ -> Nothing }
+ ; alts' <- mapM (simplAlt alt_env' mb_var_scrut
+ imposs_deflt_cons case_bndr' cont') in_alts
; return (scrut', case_bndr', alts') }
-> SimplM (SimplEnv, OutExpr, OutId)
-- Note [Improving seq]
improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
- | not (isDeadBinder case_bndr) -- Not a pure seq! See the Note!
+ | not (isDeadBinder case_bndr) -- Not a pure seq! See Note [Improving seq]
, Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
= do { case_bndr2 <- newId (fsLit "nt") ty2
; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co)
------------------------------------
simplAlt :: SimplEnv
- -> [AltCon] -- These constructors can't be present when
- -- matching the DEFAULT alternative
- -> OutId -- The case binder
+ -> Maybe OutId -- Scrutinee
+ -> [AltCon] -- These constructors can't be present when
+ -- matching the DEFAULT alternative
+ -> OutId -- The case binder
-> SimplCont
-> InAlt
-> SimplM OutAlt
-simplAlt env imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
+simplAlt env scrut imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
= ASSERT( null bndrs )
- do { let env' = addBinderOtherCon env case_bndr' imposs_deflt_cons
+ do { let env' = addBinderUnfolding env scrut case_bndr'
+ (mkOtherCon imposs_deflt_cons)
-- Record the constructors that the case-binder *can't* be.
; rhs' <- simplExprC env' rhs cont'
; return (DEFAULT, [], rhs') }
-simplAlt env _ case_bndr' cont' (LitAlt lit, bndrs, rhs)
+simplAlt env scrut _ case_bndr' cont' (LitAlt lit, bndrs, rhs)
= ASSERT( null bndrs )
- do { let env' = addBinderUnfolding env case_bndr' (Lit lit)
+ do { let env' = addBinderUnfolding env scrut case_bndr'
+ (mkSimpleUnfolding (Lit lit))
; rhs' <- simplExprC env' rhs cont'
; return (LitAlt lit, [], rhs') }
-simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs)
+simplAlt env scrut _ case_bndr' cont' (DataAlt con, vs, rhs)
= do { -- Deal with the pattern-bound variables
-- Mark the ones that are in ! positions in the
-- data constructor as certainly-evaluated.
-- Bind the case-binder to (con args)
; let inst_tys' = tyConAppArgs (idType case_bndr')
con_args = map Type inst_tys' ++ varsToCoreExprs vs'
- env'' = addBinderUnfolding env' case_bndr'
- (mkConApp con con_args)
+ unf = mkSimpleUnfolding (mkConApp con con_args)
+ env'' = addBinderUnfolding env' scrut case_bndr' unf
; rhs' <- simplExprC env'' rhs cont'
; return (DataAlt con, vs', rhs') }
| isMarkedStrict str = evald_v : go vs' strs
| otherwise = zapped_v : go vs' strs
where
- zapped_v = zap_occ_info v
+ zapped_v = zapBndrOccInfo keep_occ_info v
evald_v = zapped_v `setIdUnfolding` evaldUnfolding
go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr the_strs)
-- case e of t { (a,b) -> ...(case t of (p,q) -> p)... }
-- ==> case e of t { (a,b) -> ...(a)... }
-- Look, Ma, a is alive now.
- zap_occ_info = zapCasePatIdOcc case_bndr'
-
-addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
-addBinderUnfolding env bndr rhs
- = modifyInScope env (bndr `setIdUnfolding` mkSimpleUnfolding rhs)
+ keep_occ_info = isDeadBinder case_bndr' && isNothing scrut
-addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
-addBinderOtherCon env bndr cons
- = modifyInScope env (bndr `setIdUnfolding` mkOtherCon cons)
+addBinderUnfolding :: SimplEnv -> Maybe OutId -> Id -> Unfolding -> SimplEnv
+addBinderUnfolding env scrut bndr unf
+ = case scrut of
+ Just v -> modifyInScope env1 (v `setIdUnfolding` unf)
+ _ -> env1
+ where
+ env1 = modifyInScope env bndr_w_unf
+ bndr_w_unf = bndr `setIdUnfolding` unf
-zapCasePatIdOcc :: Id -> Id -> Id
+zapBndrOccInfo :: Bool -> Id -> Id
-- Consider case e of b { (a,b) -> ... }
-- Then if we bind b to (a,b) in "...", and b is not dead,
-- then we must zap the deadness info on a,b
-zapCasePatIdOcc case_bndr
- | isDeadBinder case_bndr = \ pat_id -> pat_id
- | otherwise = \ pat_id -> zapIdOccInfo pat_id
+zapBndrOccInfo keep_occ_info pat_id
+ | keep_occ_info = pat_id
+ | otherwise = zapIdOccInfo pat_id
\end{code}
+Note [Add unfolding for scrutinee]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general it's unlikely that a variable scrutinee will appear
+in the case alternatives case x of { ...x unlikely to appear... }
+because the binder-swap in OccAnal has got rid of all such occcurrences
+See Note [Binder swap] in OccAnal.
+
+BUT it is still VERY IMPORTANT to add a suitable unfolding for a
+variable scrutinee, in simplAlt. Here's why
+ case x of y
+ (a,b) -> case b of c
+ I# v -> ...(f y)...
+There is no occurrence of 'b' in the (...(f y)...). But y gets
+the unfolding (a,b), and *that* mentions b. If f has a RULE
+ RULE f (p, I# q) = ...
+we want that rule to match, so we must extend the in-scope env with a
+suitable unfolding for 'y'. It's *essential* for rule matching; but
+it's also good for case-elimintation -- suppose that 'f' was inlined
+and did multi-level case analysis, then we'd solve it in one
+simplifier sweep instead of two.
+
+Exactly the same issue arises in SpecConstr;
+see Note [Add scrutinee to ValueEnv too] in SpecConstr
%************************************************************************
%* *
; env'' <- bind_case_bndr env'
; simplExprF env'' rhs cont }
where
- zap_occ = zapCasePatIdOcc bndr -- bndr is an InId
+ zap_occ = zapBndrOccInfo (isDeadBinder bndr) -- bndr is an InId
-- Ugh!
bind_args env' [] _ = return env'
\begin{code}
prepareCaseCont :: SimplEnv
-> [InAlt] -> SimplCont
- -> SimplM (SimplEnv, SimplCont,SimplCont)
- -- Return a duplicatable continuation, a non-duplicable part
- -- plus some extra bindings (that scope over the entire
- -- continunation)
-
- -- No need to make it duplicatable if there's only one alternative
-prepareCaseCont env [_] cont = return (env, cont, mkBoringStop)
-prepareCaseCont env _ cont = mkDupableCont env cont
+ -> SimplM (SimplEnv, SimplCont, SimplCont)
+-- We are considering
+-- K[case _ of { p1 -> r1; ...; pn -> rn }]
+-- where K is some enclosing continuation for the case
+-- Goal: split K into two pieces Kdup,Knodup so that
+-- a) Kdup can be duplicated
+-- b) Knodup[Kdup[e]] = K[e]
+-- The idea is that we'll transform thus:
+-- Knodup[ (case _ of { p1 -> Kdup[r1]; ...; pn -> Kdup[rn] }
+--
+-- We also return some extra bindings in SimplEnv (that scope over
+-- the entire continuation)
+
+prepareCaseCont env alts cont
+ | many_alts alts = mkDupableCont env cont
+ | otherwise = return (env, cont, mkBoringStop)
+ where
+ many_alts :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative
+ many_alts [] = False -- See Note [Bottom alternatives]
+ many_alts [_] = False
+ many_alts (alt:alts)
+ | is_bot_alt alt = many_alts alts
+ | otherwise = not (all is_bot_alt alts)
+
+ is_bot_alt (_,_,rhs) = exprIsBottom rhs
\end{code}
+Note [Bottom alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we have
+ case (case x of { A -> error .. ; B -> e; C -> error ..)
+ of alts
+then we can just duplicate those alts because the A and C cases
+will disappear immediately. This is more direct than creating
+join points and inlining them away; and in some cases we would
+not even create the join points (see Note [Single-alternative case])
+and we would keep the case-of-case which is silly. See Trac #4930.
+
\begin{code}
mkDupableCont :: SimplEnv -> SimplCont
-> SimplM (SimplEnv, SimplCont, SimplCont)
-- let ji = \xij -> ei
-- in case [...hole...] of { pi -> ji xij }
do { tick (CaseOfCase case_bndr)
- ; (env', dup_cont, nodup_cont) <- mkDupableCont env cont
- -- NB: call mkDupableCont here, *not* prepareCaseCont
- -- We must make a duplicable continuation, whereas prepareCaseCont
- -- doesn't when there is a single case branch
+ ; (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont
+ -- NB: We call prepareCaseCont here. If there is only one
+ -- alternative, then dup_cont may be big, but that's ok
+ -- becuase we push it into the single alternative, and then
+ -- use mkDupableAlt to turn that simplified alternative into
+ -- a join point if it's too big to duplicate.
+ -- And this is important: see Note [Fusing case continuations]
; let alt_env = se `setInScope` env'
; (alt_env', case_bndr') <- simplBinder alt_env case_bndr
- ; alts' <- mapM (simplAlt alt_env' [] case_bndr' dup_cont) alts
+ ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' dup_cont) alts
-- Safe to say that there are no handled-cons for the DEFAULT case
-- NB: simplBinder does not zap deadness occ-info, so
-- a dead case_bndr' will still advertise its deadness
-- See Note [Duplicated env]
\end{code}
+Note [Fusing case continuations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's important to fuse two successive case continuations when the
+first has one alternative. That's why we call prepareCaseCont here.
+Consider this, which arises from thunk splitting (see Note [Thunk
+splitting] in WorkWrap):
+
+ let
+ x* = case (case v of {pn -> rn}) of
+ I# a -> I# a
+ in body
+
+The simplifier will find
+ (Var v) with continuation
+ Select (pn -> rn) (
+ Select [I# a -> I# a] (
+ StrictBind body Stop
+
+So we'll call mkDupableCont on
+ Select [I# a -> I# a] (StrictBind body Stop)
+There is just one alternative in the first Select, so we want to
+simplify the rhs (I# a) with continuation (StricgtBind body Stop)
+Supposing that body is big, we end up with
+ let $j a = <let x = I# a in body>
+ in case v of { pn -> case rn of
+ I# a -> $j a }
+This is just what we want because the rn produces a box that
+the case rn cancels with.
+
+See Trac #4957 a fuller example.
+
Note [Case binders and join points]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this
Unlike StrictArg, there doesn't seem anything to gain from
duplicating a StrictBind continuation, so we don't.
-The desire not to duplicate is the entire reason that
-mkDupableCont returns a pair of continuations.
-
Note [Single-alternative cases]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Here's another single-alternative where we really want to do case-of-case:
-data Mk1 = Mk1 Int#
-data Mk1 = Mk2 Int#
+data Mk1 = Mk1 Int# | Mk2 Int#
M1.f =
\r [x_s74 y_s6X]
So the outer case is doing *nothing at all*, other than serving as a
join-point. In this case we really want to do case-of-case and decide
-whether to use a real join point or just duplicate the continuation.
+whether to use a real join point or just duplicate the continuation:
+
+ let $j s7c = case x of
+ Mk1 ipv77 -> (==) s7c ipv77
+ Mk1 ipv79 -> (==) s7c ipv79
+ in
+ case y of
+ Mk1 ipv70 -> $j ipv70
+ Mk2 ipv72 -> $j ipv72
Hence: check whether the case binder's type is unlifted, because then
the outer case is *not* a seq.
projects / ghc-hetmet.git / blobdiff