+ tick (CaseOfCase join_id) `thenSmpl_`
+ -- Want to tick here so that we go round again,
+ -- and maybe copy or inline the code;
+ -- not strictly CaseOf Case
+
+ returnSmpl (unitFloat env join_id join_rhs,
+ ArgOf OkToDup is_rhs cont_ty cont_fn)
+
+mkDupableCont env ty (ApplyTo _ arg se cont)
+ = -- e.g. [...hole...] (...arg...)
+ -- ==>
+ -- let a = ...arg...
+ -- in [...hole...] a
+ mkDupableCont env (funResultTy ty) cont `thenSmpl` \ (floats, cont') ->
+ addFloats env floats $ \ env ->
+
+ simplExpr (setInScope se env) arg `thenSmpl` \ arg' ->
+ if exprIsDupable arg' then
+ returnSmpl (emptyFloats env, ApplyTo OkToDup arg' (zapSubstEnv se) cont')
+ else
+ newId SLIT("a") (exprType arg') `thenSmpl` \ arg_id ->
+
+ tick (CaseOfCase arg_id) `thenSmpl_`
+ -- Want to tick here so that we go round again,
+ -- and maybe copy or inline the code.
+ -- Not strictly CaseOfCase, but never mind
+
+ returnSmpl (unitFloat env arg_id arg',
+ ApplyTo OkToDup (Var arg_id) (zapSubstEnv se) cont')
+ -- But what if the arg should be case-bound?
+ -- This has been this way for a long time, so I'll leave it,
+ -- but I can't convince myself that it's right.
+
+
+mkDupableCont env ty (Select _ case_bndr alts se cont)
+ = -- e.g. (case [...hole...] of { pi -> ei })
+ -- ===>
+ -- let ji = \xij -> ei
+ -- in case [...hole...] of { pi -> ji xij }
+ tick (CaseOfCase case_bndr) `thenSmpl_`
+ let
+ alt_env = setInScope se env
+ in
+ prepareCaseCont alt_env alts cont `thenSmpl` \ (floats1, dupable_cont) ->
+ addFloats alt_env floats1 $ \ alt_env ->
+
+ simplBinder alt_env case_bndr `thenSmpl` \ (alt_env, case_bndr') ->
+ -- NB: simplBinder does not zap deadness occ-info, so
+ -- a dead case_bndr' will still advertise its deadness
+ -- This is really important because in
+ -- case e of b { (# a,b #) -> ... }
+ -- b is always dead, and indeed we are not allowed to bind b to (# a,b #),
+ -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
+ -- In the new alts we build, we have the new case binder, so it must retain
+ -- its deadness.
+
+ mkDupableAlts alt_env case_bndr' alts dupable_cont `thenSmpl` \ (floats2, alts') ->
+ addFloats alt_env floats2 $ \ alt_env ->
+ returnSmpl (emptyFloats alt_env, Select OkToDup case_bndr' alts' (zapSubstEnv se)
+ (mkBoringStop (contResultType cont)))
+
+mkDupableAlts :: SimplEnv -> OutId -> [InAlt] -> SimplCont
+ -> SimplM (FloatsWith [InAlt])
+-- Absorbs the continuation into the new alternatives
+
+mkDupableAlts env case_bndr' alts dupable_cont
+ = go env alts
+ where
+ go env [] = returnSmpl (emptyFloats env, [])
+ go env (alt:alts)
+ = mkDupableAlt env case_bndr' dupable_cont alt `thenSmpl` \ (floats1, alt') ->
+ addFloats env floats1 $ \ env ->
+ go env alts `thenSmpl` \ (floats2, alts') ->
+ returnSmpl (floats2, alt' : alts')
+
+mkDupableAlt env case_bndr' cont alt@(con, bndrs, rhs)
+ = simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
+ simplExprC env rhs cont `thenSmpl` \ rhs' ->
+
+ if exprIsDupable rhs' then
+ returnSmpl (emptyFloats env, (con, bndrs', rhs'))
+ -- It is worth checking for a small RHS because otherwise we
+ -- get extra let bindings that may cause an extra iteration of the simplifier to
+ -- inline back in place. Quite often the rhs is just a variable or constructor.
+ -- The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
+ -- iterations because the version with the let bindings looked big, and so wasn't
+ -- inlined, but after the join points had been inlined it looked smaller, and so
+ -- was inlined.
+ --
+ -- NB: we have to check the size of rhs', not rhs.
+ -- Duplicating a small InAlt might invalidate occurrence information
+ -- However, if it *is* dupable, we return the *un* simplified alternative,
+ -- because otherwise we'd need to pair it up with an empty subst-env....
+ -- but we only have one env shared between all the alts.
+ -- (Remember we must zap the subst-env before re-simplifying something).
+ -- Rather than do this we simply agree to re-simplify the original (small) thing later.
+
+ else
+ let
+ rhs_ty' = exprType rhs'
+ used_bndrs' = filter (not . isDeadBinder) (case_bndr' : bndrs')
+ -- The deadness info on the new binders is unscathed
+ in
+ -- If we try to lift a primitive-typed something out
+ -- for let-binding-purposes, we will *caseify* it (!),
+ -- with potentially-disastrous strictness results. So
+ -- instead we turn it into a function: \v -> e
+ -- where v::State# RealWorld#. The value passed to this function
+ -- is realworld#, which generates (almost) no code.
+
+ -- There's a slight infelicity here: we pass the overall
+ -- case_bndr to all the join points if it's used in *any* RHS,
+ -- because we don't know its usage in each RHS separately
+
+ -- We used to say "&& isUnLiftedType rhs_ty'" here, but now
+ -- we make the join point into a function whenever used_bndrs'
+ -- is empty. This makes the join-point more CPR friendly.
+ -- Consider: let j = if .. then I# 3 else I# 4
+ -- in case .. of { A -> j; B -> j; C -> ... }
+ --
+ -- Now CPR doesn't w/w j because it's a thunk, so
+ -- that means that the enclosing function can't w/w either,
+ -- which is a lose. Here's the example that happened in practice:
+ -- kgmod :: Int -> Int -> Int
+ -- kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
+ -- then 78
+ -- else 5
+ --
+ -- I have seen a case alternative like this:
+ -- True -> \v -> ...
+ -- It's a bit silly to add the realWorld dummy arg in this case, making
+ -- $j = \s v -> ...
+ -- True -> $j s
+ -- (the \v alone is enough to make CPR happy) but I think it's rare
+
+ ( if null used_bndrs'
+ then newId SLIT("w") realWorldStatePrimTy `thenSmpl` \ rw_id ->
+ returnSmpl ([rw_id], [Var realWorldPrimId])
+ else
+ returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
+ ) `thenSmpl` \ (final_bndrs', final_args) ->
+
+ -- See comment about "$j" name above
+ newId SLIT("$j") (foldr mkPiType rhs_ty' final_bndrs') `thenSmpl` \ join_bndr ->
+ -- Notice the funky mkPiType. If the contructor has existentials
+ -- it's possible that the join point will be abstracted over
+ -- type varaibles as well as term variables.
+ -- Example: Suppose we have
+ -- data T = forall t. C [t]
+ -- Then faced with
+ -- case (case e of ...) of
+ -- C t xs::[t] -> rhs
+ -- We get the join point
+ -- let j :: forall t. [t] -> ...
+ -- j = /\t \xs::[t] -> rhs
+ -- in
+ -- case (case e of ...) of
+ -- C t xs::[t] -> j t xs
+
+ let
+ -- We make the lambdas into one-shot-lambdas. The
+ -- join point is sure to be applied at most once, and doing so
+ -- prevents the body of the join point being floated out by
+ -- the full laziness pass
+ really_final_bndrs = map one_shot final_bndrs'
+ one_shot v | isId v = setOneShotLambda v
+ | otherwise = v
+ join_rhs = mkLams really_final_bndrs rhs'
+ join_call = mkApps (Var join_bndr) final_args
+ in
+ returnSmpl (unitFloat env join_bndr join_rhs, (con, bndrs', join_call))