Commit 4bbd6bae authored by Simon Peyton Jones's avatar Simon Peyton Jones

Simplify the SimplCont data type

* Put the result type in the Stop continuation
* No need for the alts type in Select

The result is a modest but useful simplification
parent f7e246b5
......@@ -24,7 +24,8 @@ module SimplUtils (
-- The continuation type
SimplCont(..), DupFlag(..), ArgInfo(..),
isSimplified,
contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs,
contIsDupable, contResultType, contInputType,
contIsTrivial, contArgs, dropArgs,
pushSimplifiedArgs, countValArgs, countArgs, addArgTo,
mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg,
interestingCallContext,
......@@ -54,7 +55,7 @@ import Var
import Demand
import SimplMonad
import Type hiding( substTy )
import Coercion hiding( substCo )
import Coercion hiding( substCo, substTy )
import DataCon ( dataConWorkId )
import VarSet
import BasicTypes
......@@ -96,7 +97,8 @@ Key points:
\begin{code}
data SimplCont
= Stop -- An empty context, or hole, []
= Stop -- An empty context, or <hole>
OutType -- Type of the <hole>
CallCtxt -- True <=> There is something interesting about
-- the context, and hence the inliner
-- should be a bit keener (see interestingCallContext)
......@@ -104,41 +106,43 @@ data SimplCont
-- This is an argument of a function that has RULES
-- Inlining the call might allow the rule to fire
| CoerceIt -- C `cast` co
| CoerceIt -- <hole> `cast` co
OutCoercion -- The coercion simplified
-- Invariant: never an identity coercion
SimplCont
| ApplyTo -- C arg
| ApplyTo -- <hole> arg
DupFlag -- See Note [DupFlag invariants]
InExpr StaticEnv -- The argument and its static env
SimplCont
| Select -- case C of alts
DupFlag -- See Note [DupFlag invariants]
InId InType [InAlt] StaticEnv -- The case binder, alts type, alts, and subst-env
| Select -- case <hole> of alts
DupFlag -- See Note [DupFlag invariants]
InId [InAlt] StaticEnv -- The case binder, alts type, alts, and subst-env
SimplCont
-- The two strict forms have no DupFlag, because we never duplicate them
| StrictBind -- (\x* \xs. e) C
InId [InBndr] -- let x* = [] in e
| StrictBind -- (\x* \xs. e) <hole>
InId [InBndr] -- let x* = <hole> in e
InExpr StaticEnv -- is a special case
SimplCont
| StrictArg -- f e1 ..en C
| StrictArg -- f e1 ..en <hole>
ArgInfo -- Specifies f, e1..en, Whether f has rules, etc
-- plus strictness flags for *further* args
CallCtxt -- Whether *this* argument position is interesting
SimplCont
| TickIt
(Tickish Id) -- Tick tickish []
(Tickish Id) -- Tick tickish <hole>
SimplCont
data ArgInfo
= ArgInfo {
ai_fun :: Id, -- The function
ai_fun :: OutId, -- The function
ai_args :: [OutExpr], -- ...applied to these args (which are in *reverse* order)
ai_type :: OutType, -- Type of (f a1 ... an)
ai_rules :: [CoreRule], -- Rules for this function
ai_encl :: Bool, -- Flag saying whether this function
......@@ -154,18 +158,19 @@ data ArgInfo
}
addArgTo :: ArgInfo -> OutExpr -> ArgInfo
addArgTo ai arg = ai { ai_args = arg : ai_args ai }
addArgTo ai arg = ai { ai_args = arg : ai_args ai
, ai_type = applyTypeToArg (ai_type ai) arg }
instance Outputable SimplCont where
ppr (Stop interesting) = ptext (sLit "Stop") <> brackets (ppr interesting)
ppr (ApplyTo dup arg _ cont) = ((ptext (sLit "ApplyTo") <+> ppr dup <+> pprParendExpr arg)
ppr (Stop _ interesting) = ptext (sLit "Stop") <> brackets (ppr interesting)
ppr (ApplyTo dup arg _ cont) = ((ptext (sLit "ApplyTo") <+> ppr dup <+> pprParendExpr arg)
{- $$ nest 2 (pprSimplEnv se) -}) $$ ppr cont
ppr (StrictBind b _ _ _ cont) = (ptext (sLit "StrictBind") <+> ppr b) $$ ppr cont
ppr (StrictArg ai _ cont) = (ptext (sLit "StrictArg") <+> ppr (ai_fun ai)) $$ ppr cont
ppr (Select dup bndr ty alts se cont) = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr <+> ppr ty) $$
ppr (StrictBind b _ _ _ cont) = (ptext (sLit "StrictBind") <+> ppr b) $$ ppr cont
ppr (StrictArg ai _ cont) = (ptext (sLit "StrictArg") <+> ppr (ai_fun ai)) $$ ppr cont
ppr (Select dup bndr alts se cont) = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr) $$
(nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont
ppr (CoerceIt co cont) = (ptext (sLit "CoerceIt") <+> ppr co) $$ ppr cont
ppr (TickIt t cont) = (ptext (sLit "TickIt") <+> ppr t) $$ ppr cont
ppr (CoerceIt co cont) = (ptext (sLit "CoerceIt") <+> ppr co) $$ ppr cont
ppr (TickIt t cont) = (ptext (sLit "TickIt") <+> ppr t) $$ ppr cont
data DupFlag = NoDup -- Unsimplified, might be big
| Simplified -- Simplified
......@@ -193,14 +198,14 @@ the following invariants hold
\begin{code}
-------------------
mkBoringStop :: SimplCont
mkBoringStop = Stop BoringCtxt
mkBoringStop :: OutType -> SimplCont
mkBoringStop ty = Stop ty BoringCtxt
mkRhsStop :: SimplCont -- See Note [RHS of lets] in CoreUnfold
mkRhsStop = Stop (ArgCtxt False)
mkRhsStop :: OutType -> SimplCont -- See Note [RHS of lets] in CoreUnfold
mkRhsStop ty = Stop ty (ArgCtxt False)
mkLazyArgStop :: CallCtxt -> SimplCont
mkLazyArgStop cci = Stop cci
mkLazyArgStop :: OutType -> CallCtxt -> SimplCont
mkLazyArgStop ty cci = Stop ty cci
-------------------
contIsRhsOrArg :: SimplCont -> Bool
......@@ -211,11 +216,11 @@ contIsRhsOrArg _ = False
-------------------
contIsDupable :: SimplCont -> Bool
contIsDupable (Stop {}) = True
contIsDupable (ApplyTo OkToDup _ _ _) = True -- See Note [DupFlag invariants]
contIsDupable (Select OkToDup _ _ _ _ _) = True -- ...ditto...
contIsDupable (CoerceIt _ cont) = contIsDupable cont
contIsDupable _ = False
contIsDupable (Stop {}) = True
contIsDupable (ApplyTo OkToDup _ _ _) = True -- See Note [DupFlag invariants]
contIsDupable (Select OkToDup _ _ _ _) = True -- ...ditto...
contIsDupable (CoerceIt _ cont) = contIsDupable cont
contIsDupable _ = False
-------------------
contIsTrivial :: SimplCont -> Bool
......@@ -226,28 +231,28 @@ contIsTrivial (CoerceIt _ cont) = contIsTrivial cont
contIsTrivial _ = False
-------------------
contResultType :: SimplEnv -> OutType -> SimplCont -> OutType
contResultType env ty cont
= go cont ty
where
subst_ty se ty = SimplEnv.substTy (se `setInScope` env) ty
subst_co se co = SimplEnv.substCo (se `setInScope` env) co
go (Stop {}) ty = ty
go (CoerceIt co cont) _ = go cont (pSnd (coercionKind co))
go (StrictBind _ bs body se cont) _ = go cont (subst_ty se (exprType (mkLams bs body)))
go (StrictArg ai _ cont) _ = go cont (funResultTy (argInfoResultTy ai))
go (Select _ _ ty _ se cont) _ = go cont (subst_ty se ty)
go (ApplyTo _ arg se cont) ty = go cont (apply_to_arg ty arg se)
go (TickIt _ cont) ty = go cont ty
apply_to_arg ty (Type ty_arg) se = applyTy ty (subst_ty se ty_arg)
apply_to_arg ty (Coercion co_arg) se = applyCo ty (subst_co se co_arg)
apply_to_arg ty _ _ = funResultTy ty
argInfoResultTy :: ArgInfo -> OutType
argInfoResultTy (ArgInfo { ai_fun = fun, ai_args = args })
= foldr (\arg fn_ty -> applyTypeToArg fn_ty arg) (idType fun) args
contResultType :: SimplCont -> OutType
contResultType (Stop ty _) = ty
contResultType (CoerceIt _ k) = contResultType k
contResultType (StrictBind _ _ _ _ k) = contResultType k
contResultType (StrictArg _ _ k) = contResultType k
contResultType (Select _ _ _ _ k) = contResultType k
contResultType (ApplyTo _ _ _ k) = contResultType k
contResultType (TickIt _ k) = contResultType k
contInputType :: SimplCont -> OutType
contInputType (Stop ty _) = ty
contInputType (CoerceIt co _) = pFst (coercionKind co)
contInputType (Select d b _ se _) = perhapsSubstTy d se (idType b)
contInputType (StrictBind b _ _ se _) = substTy se (idType b)
contInputType (StrictArg ai _ _) = funArgTy (ai_type ai)
contInputType (ApplyTo d e se k) = mkFunTy (perhapsSubstTy d se (exprType e)) (contInputType k)
contInputType (TickIt _ k) = contInputType k
perhapsSubstTy :: DupFlag -> SimplEnv -> InType -> OutType
perhapsSubstTy dup_flag se ty
| isSimplified dup_flag = ty
| otherwise = substTy se ty
-------------------
countValArgs :: SimplCont -> Int
......@@ -328,7 +333,7 @@ interestingCallContext :: SimplCont -> CallCtxt
interestingCallContext cont
= interesting cont
where
interesting (Select _ bndr _ _ _ _)
interesting (Select _ bndr _ _ _)
| isDeadBinder bndr = CaseCtxt
| otherwise = ArgCtxt False -- If the binder is used, this
-- is like a strict let
......@@ -343,7 +348,7 @@ interestingCallContext cont
interesting (StrictArg _ cci _) = cci
interesting (StrictBind {}) = BoringCtxt
interesting (Stop cci) = cci
interesting (Stop _ cci) = cci
interesting (TickIt _ cci) = interesting cci
interesting (CoerceIt _ cont) = interesting cont
-- If this call is the arg of a strict function, the context
......@@ -371,16 +376,19 @@ mkArgInfo :: Id
mkArgInfo fun rules n_val_args call_cont
| n_val_args < idArity fun -- Note [Unsaturated functions]
= ArgInfo { ai_fun = fun, ai_args = [], ai_rules = rules
, ai_encl = False
= ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty
, ai_rules = rules, ai_encl = False
, ai_strs = vanilla_stricts
, ai_discs = vanilla_discounts }
| otherwise
= ArgInfo { ai_fun = fun, ai_args = [], ai_rules = rules
= ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty
, ai_rules = rules
, ai_encl = interestingArgContext rules call_cont
, ai_strs = add_type_str (idType fun) arg_stricts
, ai_strs = add_type_str fun_ty arg_stricts
, ai_discs = arg_discounts }
where
fun_ty = idType fun
vanilla_discounts, arg_discounts :: [Int]
vanilla_discounts = repeat 0
arg_discounts = case idUnfolding fun of
......@@ -466,7 +474,7 @@ interestingArgContext rules call_cont
go (StrictArg _ cci _) = interesting cci
go (StrictBind {}) = False -- ??
go (CoerceIt _ c) = go c
go (Stop cci) = interesting cci
go (Stop _ cci) = interesting cci
go (TickIt _ c) = go c
interesting (ArgCtxt rules) = rules
......
......@@ -339,11 +339,14 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
-- f = /\a. \x. g a x
-- should eta-reduce
body_out_ty :: OutType
body_out_ty = substTy env (exprType body)
; (body_env, tvs') <- simplBinders rhs_env tvs
-- See Note [Floating and type abstraction] in SimplUtils
-- Simplify the RHS
; (body_env1, body1) <- simplExprF body_env body mkRhsStop
; (body_env1, body1) <- simplExprF body_env body (mkRhsStop body_out_ty)
-- ANF-ise a constructor or PAP rhs
; (body_env2, body2) <- prepareRhs top_lvl body_env1 bndr1 body1
......@@ -879,7 +882,10 @@ might do the same again.
\begin{code}
simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
simplExpr env expr = simplExprC env expr mkBoringStop
simplExpr env expr = simplExprC env expr (mkBoringStop expr_out_ty)
where
expr_out_ty :: OutType
expr_out_ty = substTy env (exprType expr)
simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
-- Simplify an expression, given a continuation
......@@ -941,17 +947,19 @@ simplExprF1 env expr@(Lam {}) cont
zap b | isTyVar b = b
| otherwise = zapLamIdInfo b
simplExprF1 env (Case scrut bndr ty alts) cont
simplExprF1 env (Case scrut bndr alts_ty alts) cont
| sm_case_case (getMode env)
= -- Simplify the scrutinee with a Select continuation
simplExprF env scrut (Select NoDup bndr ty alts env cont)
simplExprF env scrut (Select NoDup bndr alts env cont)
| otherwise
= -- If case-of-case is off, simply simplify the case expression
-- in a vanilla Stop context, and rebuild the result around it
do { case_expr' <- simplExprC env scrut
(Select NoDup bndr ty alts env mkBoringStop)
do { case_expr' <- simplExprC env scrut
(Select NoDup bndr alts env (mkBoringStop alts_out_ty))
; rebuild env case_expr' cont }
where
alts_out_ty = substTy env alts_ty
simplExprF1 env (Let (Rec pairs) body) cont
= do { env' <- simplRecBndrs env (map fst pairs)
......@@ -1105,7 +1113,7 @@ simplTick env tickish expr cont
where (inc,outc) = splitCont c
splitCont (CoerceIt co c) = (CoerceIt co inc, outc)
where (inc,outc) = splitCont c
splitCont other = (mkBoringStop, other)
splitCont other = (mkBoringStop (contInputType other), other)
getDoneId (DoneId id) = id
getDoneId (DoneEx e) = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst
......@@ -1160,7 +1168,7 @@ rebuild env expr cont
Stop {} -> return (env, expr)
CoerceIt co cont -> rebuild env (mkCast expr co) cont
-- NB: mkCast implements the (Coercion co |> g) optimisation
Select _ bndr ty alts se cont -> rebuildCase (se `setFloats` env) expr bndr ty alts cont
Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont
StrictArg info _ cont -> rebuildCall env (info `addArgTo` expr) cont
StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
; simplLam env' bs body cont }
......@@ -1380,7 +1388,7 @@ simplIdF env var cont
---------------------------------------------------------
-- Dealing with a call site
completeCall :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr)
completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplEnv, OutExpr)
completeCall env var cont
= do { ------------- Try inlining ----------------
dflags <- getDynFlags
......@@ -1440,14 +1448,14 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) con
= return (env, castBottomExpr res cont_ty) -- contination to discard, else we do it
where -- again and again!
res = mkApps (Var fun) (reverse rev_args)
cont_ty = contResultType env (exprType res) cont
cont_ty = contResultType cont
rebuildCall env info (ApplyTo dup_flag (Type arg_ty) se cont)
= do { arg_ty' <- if isSimplified dup_flag then return arg_ty
else simplType (se `setInScope` env) arg_ty
; rebuildCall env (info `addArgTo` Type arg_ty') cont }
rebuildCall env info@(ArgInfo { ai_encl = encl_rules
rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty
, ai_strs = str:strs, ai_discs = disc:discs })
(ApplyTo dup_flag arg arg_se cont)
| isSimplified dup_flag -- See Note [Avoid redundant simplification]
......@@ -1465,7 +1473,7 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules
-- have to be very careful about bogus strictness through
-- floating a demanded let.
= do { arg' <- simplExprC (arg_se `setInScope` env) arg
(mkLazyArgStop cci)
(mkLazyArgStop (funArgTy fun_ty) cci)
; rebuildCall env (addArgTo info' arg') cont }
where
info' = info { ai_strs = strs, ai_discs = discs }
......@@ -1728,7 +1736,6 @@ rebuildCase, reallyRebuildCase
:: SimplEnv
-> OutExpr -- Scrutinee
-> InId -- Case binder
-> InType -- Type of alternatives
-> [InAlt] -- Alternatives (inceasing order)
-> SimplCont
-> SimplM (SimplEnv, OutExpr)
......@@ -1737,7 +1744,7 @@ rebuildCase, reallyRebuildCase
-- 1. Eliminate the case if there's a known constructor
--------------------------------------------------
rebuildCase env scrut case_bndr _ alts cont
rebuildCase env scrut case_bndr alts cont
| Lit lit <- scrut -- No need for same treatment as constructors
-- because literals are inlined more vigorously
, not (litIsLifted lit)
......@@ -1766,7 +1773,7 @@ rebuildCase env scrut case_bndr _ alts cont
-- 2. Eliminate the case if scrutinee is evaluated
--------------------------------------------------
rebuildCase env scrut case_bndr _ [(_, bndrs, rhs)] cont
rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
-- See if we can get rid of the case altogether
-- See Note [Case elimination]
-- mkCase made sure that if all the alternatives are equal,
......@@ -1816,7 +1823,7 @@ rebuildCase env scrut case_bndr _ [(_, bndrs, rhs)] cont
-- 3. Try seq rules; see Note [User-defined RULES for seq] in MkId
--------------------------------------------------
rebuildCase env scrut case_bndr alts_ty alts@[(_, bndrs, rhs)] cont
rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
| all isDeadBinder (case_bndr : bndrs) -- So this is just 'seq'
= do { let rhs' = substExpr (text "rebuild-case") env rhs
out_args = [Type (substTy env (idType case_bndr)),
......@@ -1829,24 +1836,25 @@ rebuildCase env scrut case_bndr alts_ty alts@[(_, bndrs, rhs)] cont
Just (n_args, res) -> simplExprF (zapSubstEnv env)
(mkApps res (drop n_args out_args))
cont
Nothing -> reallyRebuildCase env scrut case_bndr alts_ty alts cont }
Nothing -> reallyRebuildCase env scrut case_bndr alts cont }
rebuildCase env scrut case_bndr alts_ty alts cont
= reallyRebuildCase env scrut case_bndr alts_ty alts cont
rebuildCase env scrut case_bndr alts cont
= reallyRebuildCase env scrut case_bndr alts cont
--------------------------------------------------
-- 3. Catch-all case
--------------------------------------------------
reallyRebuildCase env scrut case_bndr alts_ty alts cont
reallyRebuildCase env scrut case_bndr alts cont
= do { -- Prepare the continuation;
-- The new subst_env is in place
(env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont
-- Simplify the alternatives
; (scrut', case_bndr', alts_ty', alts') <- simplAlts env' scrut case_bndr alts_ty alts dup_cont
; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_cont
; dflags <- getDynFlags
; let alts_ty' = contResultType dup_cont
; case_expr <- mkCase dflags scrut' case_bndr' alts_ty' alts'
-- Notice that rebuild gets the in-scope set from env', not alt_env
......@@ -1935,20 +1943,16 @@ robust here. (Otherwise, there's a danger that we'll simply drop the
simplAlts :: SimplEnv
-> OutExpr
-> InId -- Case binder
-> InType
-> [InAlt] -- Non-empty
-> SimplCont
-> SimplM (OutExpr, OutId, OutType, [OutAlt]) -- Includes the continuation
-> SimplM (OutExpr, OutId, [OutAlt]) -- Includes the continuation
-- Like simplExpr, this just returns the simplified alternatives;
-- it does not return an environment
-- The returned alternatives can be empty, none are possible
simplAlts env scrut case_bndr alts_ty alts cont'
simplAlts env scrut case_bndr alts cont'
= do { let env0 = zapFloats env
; basic_alts_ty' <- simplType env0 alts_ty
; let alts_ty' = contResultType env0 basic_alts_ty' cont'
; (env1, case_bndr1) <- simplBinder env0 case_bndr
; fam_envs <- getFamEnvs
......@@ -1963,7 +1967,7 @@ simplAlts env scrut case_bndr alts_ty alts cont'
; alts' <- mapM (simplAlt alt_env' mb_var_scrut
imposs_deflt_cons case_bndr' cont') in_alts
; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $
return (scrut', case_bndr', alts_ty', alts') }
return (scrut', case_bndr', alts') }
------------------------------------
......@@ -2180,11 +2184,9 @@ missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExp
-- an inner case has no accessible alternatives before
-- it "sees" that the entire branch of an outer case is
-- inaccessible. So we simply put an error case here instead.
missingAlt env case_bndr alts cont
missingAlt env case_bndr _ cont
= WARN( True, ptext (sLit "missingAlt") <+> ppr case_bndr )
return (env, mkImpossibleExpr res_ty)
where
res_ty = contResultType env (substTy env (coreAltsType alts)) cont
return (env, mkImpossibleExpr (contResultType cont))
\end{code}
......@@ -2212,7 +2214,7 @@ prepareCaseCont :: SimplEnv
prepareCaseCont env alts cont
| many_alts alts = mkDupableCont env cont
| otherwise = return (env, cont, mkBoringStop)
| otherwise = return (env, cont, mkBoringStop (contResultType cont))
where
many_alts :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative
many_alts [] = False -- See Note [Bottom alternatives]
......@@ -2241,7 +2243,7 @@ mkDupableCont :: SimplEnv -> SimplCont
mkDupableCont env cont
| contIsDupable cont
= return (env, cont, mkBoringStop)
= return (env, cont, mkBoringStop (contResultType cont))
mkDupableCont _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn
......@@ -2251,10 +2253,10 @@ mkDupableCont env (CoerceIt ty cont)
-- Duplicating ticks for now, not sure if this is good or not
mkDupableCont env cont@(TickIt{})
= return (env, mkBoringStop, cont)
= return (env, mkBoringStop (contInputType cont), cont)
mkDupableCont env cont@(StrictBind {})
= return (env, mkBoringStop, cont)
= return (env, mkBoringStop (contInputType cont), cont)
-- See Note [Duplicating StrictBind]
mkDupableCont env (StrictArg info cci cont)
......@@ -2274,16 +2276,16 @@ mkDupableCont env (ApplyTo _ arg se cont)
; let app_cont = ApplyTo OkToDup arg'' (zapSubstEnv env'') dup_cont
; return (env'', app_cont, nodup_cont) }
mkDupableCont env cont@(Select _ case_bndr _ [(_, bs, _rhs)] _ _)
mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _)
-- See Note [Single-alternative case]
-- | not (exprIsDupable rhs && contIsDupable case_cont)
-- | not (isDeadBinder case_bndr)
| all isDeadBinder bs -- InIds
&& not (isUnLiftedType (idType case_bndr))
-- Note [Single-alternative-unlifted]
= return (env, mkBoringStop, cont)
= return (env, mkBoringStop (contInputType cont), cont)
mkDupableCont env (Select _ case_bndr alts_ty alts se cont)
mkDupableCont env (Select _ case_bndr alts se cont)
= -- e.g. (case [...hole...] of { pi -> ei })
-- ===>
-- let ji = \xij -> ei
......@@ -2299,8 +2301,6 @@ mkDupableCont env (Select _ case_bndr alts_ty alts se cont)
; let alt_env = se `setInScope` env'
; basic_alts_ty' <- simplType alt_env alts_ty
; let alts_ty' = contResultType alt_env basic_alts_ty' dup_cont
; (alt_env', case_bndr') <- simplBinder alt_env case_bndr
; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' dup_cont) alts
-- Safe to say that there are no handled-cons for the DEFAULT case
......@@ -2317,7 +2317,8 @@ mkDupableCont env (Select _ case_bndr alts_ty alts se cont)
; (env'', alts'') <- mkDupableAlts env' case_bndr' alts'
; return (env'', -- Note [Duplicated env]
Select OkToDup case_bndr' alts_ty' alts'' (zapSubstEnv env'') mkBoringStop,
Select OkToDup case_bndr' alts'' (zapSubstEnv env'')
(mkBoringStop (contInputType nodup_cont)),
nodup_cont) }
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment