+ 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
+ addLetBind (NonRec join_id join_rhs) $
+ thing_inside new_cont
+
+mkDupableCont ty (ApplyTo _ arg se cont) thing_inside
+ = mkDupableCont (funResultTy ty) cont $ \ cont' ->
+ setSubstEnv se (simplExpr arg) `thenSmpl` \ arg' ->
+ if exprIsDupable arg' then
+ thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont')
+ else
+ newId SLIT("a") (exprType arg') $ \ bndr ->
+
+ tick (CaseOfCase bndr) `thenSmpl_`
+ -- Want to tick here so that we go round again,
+ -- and maybe copy or inline the code;
+ -- not strictly CaseOf Case
+
+ addLetBind (NonRec bndr arg') $
+ -- But what if the arg should be case-bound? We can't use
+ -- addNonRecBind here because its type is too specific.
+ -- This has been this way for a long time, so I'll leave it,
+ -- but I can't convince myself that it's right.
+
+ thing_inside (ApplyTo OkToDup (Var bndr) emptySubstEnv cont')
+
+
+mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside
+ = tick (CaseOfCase case_bndr) `thenSmpl_`
+ setSubstEnv se (
+ simplBinder case_bndr $ \ case_bndr' ->
+ prepareCaseCont alts cont $ \ cont' ->
+ mapAndUnzipSmpl (mkDupableAlt case_bndr case_bndr' cont') alts `thenSmpl` \ (alt_binds_s, alts') ->
+ returnSmpl (concat alt_binds_s, alts')
+ ) `thenSmpl` \ (alt_binds, alts') ->
+
+ addAuxiliaryBinds alt_binds $
+
+ -- NB that the new alternatives, alts', are still InAlts, using the original
+ -- binders. That means we can keep the case_bndr intact. This is important
+ -- because another case-of-case might strike, and so we want to keep the
+ -- info that the case_bndr is dead (if it is, which is often the case).
+ -- This is VITAL when the type of case_bndr is an unboxed pair (often the
+ -- case in I/O rich code. We aren't allowed a lambda bound
+ -- arg of unboxed tuple type, and indeed such a case_bndr is always dead
+ thing_inside (Select OkToDup case_bndr alts' se (mkStop (contResultType cont)))
+
+mkDupableAlt :: InId -> OutId -> SimplCont -> InAlt -> SimplM (OutStuff InAlt)
+mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs)
+ = simplBinders bndrs $ \ bndrs' ->
+ simplExprC rhs cont `thenSmpl` \ rhs' ->
+
+ if (case cont of { Stop _ _ -> exprIsDupable rhs'; other -> False}) then
+ -- 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.
+ --
+ -- But since the continuation is absorbed into the rhs, we only do this
+ -- for a Stop continuation.
+ --
+ -- 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.
+ -- (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.
+ returnSmpl ([], alt)
+
+ else
+ let
+ rhs_ty' = exprType rhs'
+ (used_bndrs, used_bndrs')
+ = unzip [pr | pr@(bndr,bndr') <- zip (case_bndr : bndrs)
+ (case_bndr' : bndrs'),
+ not (isDeadBinder bndr)]
+ -- The new binders have lost their occurrence info,
+ -- so we have to extract it from the old ones
+ in
+ ( if null used_bndrs'
+ -- 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 should not 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
+
+ then newId SLIT("w") realWorldStatePrimTy $ \ rw_id ->
+ returnSmpl ([rw_id], [Var realWorldPrimId])
+ else
+ returnSmpl (used_bndrs', map varToCoreExpr used_bndrs)
+ )
+ `thenSmpl` \ (final_bndrs', final_args) ->