+ 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' ->
+ mkDupableAlts case_bndr case_bndr' cont' alts $ \ alts' ->
+ returnOutStuff alts'
+ ) `thenSmpl` \ (alt_binds, (in_scope, alts')) ->
+
+ addFloats alt_binds in_scope $
+
+ -- 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)))
+
+mkDupableAlts :: InId -> OutId -> SimplCont -> [InAlt]
+ -> ([InAlt] -> SimplM (OutStuff a))
+ -> SimplM (OutStuff a)
+mkDupableAlts case_bndr case_bndr' cont [] thing_inside
+ = thing_inside []
+mkDupableAlts case_bndr case_bndr' cont (alt:alts) thing_inside
+ = mkDupableAlt case_bndr case_bndr' cont alt $ \ alt' ->
+ mkDupableAlts case_bndr case_bndr' cont alts $ \ alts' ->
+ thing_inside (alt' : alts')
+
+mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs) thing_inside
+ = 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.
+ thing_inside 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) ->
+
+ -- See comment about "$j" name above
+ newId SLIT("$j") (foldr mkPiType rhs_ty' final_bndrs') $ \ 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
+ in
+ addLetBind (NonRec join_bndr (mkLams really_final_bndrs rhs')) $
+ thing_inside (con, bndrs, mkApps (Var join_bndr) final_args)
+\end{code}