Commit ac230c5e authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Allow cases with empty alterantives

This patch allows, for the first time, case expressions with an empty
list of alternatives. Max suggested the idea, and Trac #6067 showed
that it is really quite important.

So I've implemented the idea, fixing #6067. Main changes

 * See Note [Empty case alternatives] in CoreSyn

 * Various foldr1's become foldrs

 * IfaceCase does not record the type of the alternatives.
   I added IfaceECase for empty-alternative cases.

 * Core Lint does not complain about empty cases

 * MkCore.castBottomExpr constructs an empty-alternative case
   expression   (case e of ty {})

 * CoreToStg converts '(case e of {})' to just 'e'
parent b04c0beb
......@@ -663,7 +663,7 @@ arityType env (App fun arg )
-- The difference is observable using 'seq'
--
arityType env (Case scrut _ _ alts)
| exprIsBottom scrut
| exprIsBottom scrut || null alts
= ABot 0 -- Do not eta expand
-- See Note [Dealing with bottom (1)]
| otherwise
......@@ -829,14 +829,18 @@ etaInfoApp subst (Cast e co1) eis
where
co' = CoreSubst.substCo subst co1
etaInfoApp subst (Case e b _ alts) eis
= Case (subst_expr subst e) b1 (coreAltsType alts') alts'
etaInfoApp subst (Case e b ty alts) eis
= Case (subst_expr subst e) b1 (mk_alts_ty (CoreSubst.substTy subst ty) eis) alts'
where
(subst1, b1) = substBndr subst b
alts' = map subst_alt alts
subst_alt (con, bs, rhs) = (con, bs', etaInfoApp subst2 rhs eis)
where
(subst2,bs') = substBndrs subst1 bs
mk_alts_ty ty [] = ty
mk_alts_ty ty (EtaVar v : eis) = mk_alts_ty (applyTypeToArg ty (varToCoreExpr v)) eis
mk_alts_ty _ (EtaCo co : eis) = mk_alts_ty (pSnd (coercionKind co)) eis
etaInfoApp subst (Let b e) eis
= Let b' (etaInfoApp subst' e eis)
......
......@@ -486,7 +486,7 @@ freeVars (Case scrut bndr ty alts)
scrut2 = freeVars scrut
(alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
alts_fvs = foldr1 unionFVs alts_fvs_s
alts_fvs = foldr unionFVs noFVs alts_fvs_s
fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
(con, args, rhs2))
......
......@@ -498,9 +498,6 @@ checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
-- the simplifer correctly eliminates case that can't
-- possibly match.
checkCaseAlts e _ []
= addErrL (mkNullAltsMsg e)
checkCaseAlts e ty alts =
do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
......@@ -1116,11 +1113,6 @@ pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
------------------------------------------------------
-- Messages for case expressions
mkNullAltsMsg :: CoreExpr -> MsgDoc
mkNullAltsMsg e
= hang (text "Case expression with no alternatives:")
4 (ppr e)
mkDefaultArgsMsg :: [Var] -> MsgDoc
mkDefaultArgsMsg args
= hang (text "DEFAULT case with binders")
......
......@@ -221,7 +221,8 @@ These data types are the heart of the compiler
-- This is one of the more complicated elements of the Core language,
-- and comes with a number of restrictions:
--
-- 1. The list of alternatives is non-empty
-- 1. The list of alternatives may be empty;
-- See Note [Empty case alternatives]
--
-- 2. The 'DEFAULT' case alternative must be first in the list,
-- if it occurs at all.
......@@ -338,11 +339,59 @@ Note [CoreSyn let goal]
application, its arguments are trivial, so that the constructor can be
inlined vigorously.
Note [Type let]
~~~~~~~~~~~~~~~
See #type_let#
Note [Empty case alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The alternatives of a case expression should be exhaustive. A case expression
can have empty alternatives if (and only if) the scrutinee is bound to raise
an exception or diverge. So:
Case (error Int "Hello") b Bool []
is fine, and has type Bool. This is one reason we need a type on
the case expression: if the alternatives are empty we can't get the type
from the alternatives! I'll write this
case (error Int "Hello") of Bool {}
with the return type just before the alterantives.
Here's another example:
data T
f :: T -> Bool
f = \(x:t). case x of Bool {}
Since T has no data constructors, the case alterantives are of course
empty. However note that 'x' is not bound to a visbily-bottom value;
it's the *type* that tells us it's going to diverge. Its a bit of a
degnerate situation but we do NOT want to replace
case x of Bool {} --> error Bool "Inaccessible case"
because x might raise an exception, and *that*'s what we want to see!
(Trac #6067 is an example.) To preserve semantics we'd have to say
x `seq` error Bool "Inaccessible case"
but the 'seq' is just a case, so we are back to square 1. Or I suppose
we could say
x |> UnsafeCoerce T Bool
but that loses all trace of the fact that this originated with an empty
set of alternatives.
We can use the empty-alternative construct to coerce error values from
one type to another. For example
f :: Int -> Int
f n = error "urk"
g :: Int -> (# Char, Bool #)
g x = case f x of { 0 -> ..., n -> ... }
Then if we inline f in g's RHS we get
case (error Int "urk") of (# Char, Bool #) { ... }
and we can discard the alternatives since the scrutinee is bottom to give
case (error Int "urk") of (# Char, Bool #) {}
This is nicer than using an unsafe coerce between Int ~ (# Char,Bool #),
if for no other reason that we don't need to instantiate the (~) at an
unboxed type.
%************************************************************************
%* *
Ticks
......
......@@ -391,8 +391,8 @@ sizeExpr bOMB_OUT_SIZE top_args expr
size_up (Case (Var v) _ _ alts)
| v `elem` top_args -- We are scrutinising an argument variable
= alts_size (foldr1 addAltSize alt_sizes)
(foldr1 maxSize alt_sizes)
= alts_size (foldr addAltSize sizeZero alt_sizes)
(foldr maxSize sizeZero alt_sizes)
-- Good to inline if an arg is scrutinised, because
-- that may eliminate allocation in the caller
-- And it eliminates the case itself
......
......@@ -13,7 +13,7 @@ module MkCore (
mkCoreApp, mkCoreApps, mkCoreConApps,
mkCoreLams, mkWildCase, mkIfThenElse,
mkWildValBinder, mkWildEvBinder,
sortQuantVars,
sortQuantVars, castBottomExpr,
-- * Constructing boxed literals
mkWordExpr, mkWordExprWord,
......@@ -209,6 +209,16 @@ mkIfThenElse guard then_expr else_expr
= mkWildCase guard boolTy (exprType then_expr)
[ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag!
(DataAlt trueDataCon, [], then_expr) ]
castBottomExpr :: CoreExpr -> Type -> CoreExpr
-- (castBottomExpr e ty), assuming that 'e' diverges,
-- return an expression of type 'ty'
-- See Note [Empty case alternatives] in CoreSyn
castBottomExpr e res_ty
| e_ty `eqType` res_ty = e
| otherwise = Case e (mkWildValBinder e_ty) res_ty []
where
e_ty = exprType e
\end{code}
The functions from this point don't really do anything cleverer than
......
......@@ -1124,6 +1124,10 @@ instance Binary IfaceExpr where
putByte bh 12
put_ bh ie
put_ bh ico
put_ bh (IfaceECase a b) = do
putByte bh 13
put_ bh a
put_ bh b
get bh = do
h <- getByte bh
case h of
......@@ -1162,6 +1166,9 @@ instance Binary IfaceExpr where
12 -> do ie <- get bh
ico <- get bh
return (IfaceCast ie ico)
13 -> do a <- get bh
b <- get bh
return (IfaceECase a b)
_ -> panic ("get IfaceExpr " ++ show h)
instance Binary IfaceConAlt where
......
......@@ -249,6 +249,7 @@ data IfaceExpr
| IfaceLam IfaceBndr IfaceExpr
| IfaceApp IfaceExpr IfaceExpr
| IfaceCase IfaceExpr IfLclName [IfaceAlt]
| IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives]
| IfaceLet IfaceBinding IfaceExpr
| IfaceCast IfaceExpr IfaceCoercion
| IfaceLit Literal
......@@ -279,6 +280,12 @@ data IfaceBinding
data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo
\end{code}
Note [Empty case alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In IfaceSyn an IfaceCase does not record the types of the alternatives,
unlike CorSyn Case. But we need this type if the alternatives are empty.
Hence IfaceECase. See Note [Empty case alternatives] in CoreSyn.
Note [Expose recursive functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For supercompilation we want to put *all* unfoldings in the interface
......@@ -621,6 +628,11 @@ pprIfaceExpr add_par i@(IfaceLam _ _)
collect bs (IfaceLam b e) = collect (b:bs) e
collect bs e = (reverse bs, e)
pprIfaceExpr add_par (IfaceECase scrut ty)
= add_par (sep [ ptext (sLit "case") <+> pprIfaceExpr noParens scrut
, ptext (sLit "ret_ty") <+> pprParendIfaceType ty
, ptext (sLit "of {}") ])
pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)])
= add_par (sep [ptext (sLit "case")
<+> pprIfaceExpr noParens scrut <+> ptext (sLit "of")
......@@ -856,7 +868,7 @@ freeNamesIfExpr (IfaceLam b body) = freeNamesIfBndr b &&& freeNamesIfExpr body
freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a
freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfType co
freeNamesIfExpr (IfaceTick _ e) = freeNamesIfExpr e
freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty
freeNamesIfExpr (IfaceCase s _ alts)
= freeNamesIfExpr s
&&& fnList fn_alt alts &&& fn_cons alts
......
......@@ -1767,7 +1767,9 @@ toIfaceExpr (Type ty) = IfaceType (toIfaceType ty)
toIfaceExpr (Coercion co) = IfaceCo (coToIfaceType co)
toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x) (toIfaceExpr b)
toIfaceExpr (App f a) = toIfaceApp f [a]
toIfaceExpr (Case s x _ as) = IfaceCase (toIfaceExpr s) (getFS x) (map toIfaceAlt as)
toIfaceExpr (Case s x ty as)
| null as = IfaceECase (toIfaceExpr s) (toIfaceType ty)
| otherwise = IfaceCase (toIfaceExpr s) (getFS x) (map toIfaceAlt as)
toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e)
toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (coToIfaceType co)
toIfaceExpr (Tick t e) = IfaceTick (toIfaceTickish t) (toIfaceExpr e)
......
......@@ -32,6 +32,7 @@ import CoreUtils
import CoreUnfold
import CoreLint
import WorkWrap
import MkCore( castBottomExpr )
import Id
import MkId
import IdInfo
......@@ -1019,6 +1020,11 @@ tcIfaceExpr (IfaceLam bndr body)
tcIfaceExpr (IfaceApp fun arg)
= App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
tcIfaceExpr (IfaceECase scrut ty)
= do { scrut' <- tcIfaceExpr scrut
; ty' <- tcIfaceType ty
; return (castBottomExpr scrut' ty') }
tcIfaceExpr (IfaceCase scrut case_bndr alts) = do
scrut' <- tcIfaceExpr scrut
case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
......
......@@ -1252,7 +1252,7 @@ occAnal env (Case scrut bndr ty alts)
= case occ_anal_scrut scrut alts of { (scrut_usage, scrut') ->
case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts') ->
let
alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
alts_usage = foldr combineAltsUsageDetails emptyDetails alts_usage_s
(alts_usage1, tagged_bndr) = tag_case_bndr alts_usage bndr
total_usage = scrut_usage +++ alts_usage1
in
......
......@@ -581,11 +581,11 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
-- about to begin, with '1' for the first
| iteration_no > max_iterations -- Stop if we've run out of iterations
= WARN( debugIsOn && (max_iterations > 2)
, ptext (sLit "Simplifier baling out after") <+> int max_iterations
<+> ptext (sLit "iterations")
<+> (brackets $ hsep $ punctuate comma $
map (int . simplCountN) (reverse counts_so_far))
<+> ptext (sLit "Size =") <+> ppr (coreBindsStats binds) )
, hang (ptext (sLit "Simplifier baling out after") <+> int max_iterations
<+> ptext (sLit "iterations")
<+> (brackets $ hsep $ punctuate comma $
map (int . simplCountN) (reverse counts_so_far)))
2 (ptext (sLit "Size =") <+> ppr (coreBindsStats binds)))
-- Subtract 1 from iteration_no to get the
-- number of iterations we actually completed
......
......@@ -115,8 +115,8 @@ data SimplCont
SimplCont
| Select -- case C of alts
DupFlag -- See Note [DupFlag invariants]
InId [InAlt] StaticEnv -- The case binder, alts, and subst-env
DupFlag -- See Note [DupFlag invariants]
InId InType [InAlt] StaticEnv -- The case binder, alts type, alts, and subst-env
SimplCont
-- The two strict forms have no DupFlag, because we never duplicate them
......@@ -157,15 +157,15 @@ addArgTo :: ArgInfo -> OutExpr -> ArgInfo
addArgTo ai arg = ai { ai_args = arg : ai_args ai }
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)
{- $$ 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 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 (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) $$
(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
data DupFlag = NoDup -- Unsimplified, might be big
| Simplified -- Simplified
......@@ -211,11 +211,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
......@@ -237,7 +237,7 @@ contResultType env ty cont
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 _ _ alts se cont) _ = go cont (subst_ty se (coreAltsType alts))
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
......@@ -328,7 +328,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
......@@ -1589,14 +1589,14 @@ and similarly in cascade for all the join points!
mkCase, mkCase1, mkCase2
:: DynFlags
-> OutExpr -> OutId
-> [OutAlt] -- Alternatives in standard (increasing) order
-> OutType -> [OutAlt] -- Alternatives in standard (increasing) order
-> SimplM OutExpr
--------------------------------------------------
-- 1. Merge Nested Cases
--------------------------------------------------
mkCase dflags scrut outer_bndr ((DEFAULT, _, deflt_rhs) : outer_alts)
mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts)
| dopt Opt_CaseMerge dflags
, Case (Var inner_scrut_var) inner_bndr _ inner_alts <- deflt_rhs
, inner_scrut_var == outer_bndr
......@@ -1622,7 +1622,7 @@ mkCase dflags scrut outer_bndr ((DEFAULT, _, deflt_rhs) : outer_alts)
-- When we merge, we must ensure that e1 takes
-- precedence over e2 as the value for A!
; mkCase1 dflags scrut outer_bndr merged_alts
; mkCase1 dflags scrut outer_bndr alts_ty merged_alts
}
-- Warning: don't call mkCase recursively!
-- Firstly, there's no point, because inner alts have already had
......@@ -1630,13 +1630,13 @@ mkCase dflags scrut outer_bndr ((DEFAULT, _, deflt_rhs) : outer_alts)
-- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
-- in munge_rhs may put a case into the DEFAULT branch!
mkCase dflags scrut bndr alts = mkCase1 dflags scrut bndr alts
mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts
--------------------------------------------------
-- 2. Eliminate Identity Case
--------------------------------------------------
mkCase1 _dflags scrut case_bndr alts -- Identity case
mkCase1 _dflags scrut case_bndr _ alts -- Identity case
| all identity_alt alts
= do { tick (CaseIdentity case_bndr)
; return (re_cast scrut rhs1) }
......@@ -1673,24 +1673,24 @@ mkCase1 _dflags scrut case_bndr alts -- Identity case
--------------------------------------------------
-- 3. Merge Identical Alternatives
--------------------------------------------------
mkCase1 dflags scrut case_bndr ((_con1,bndrs1,rhs1) : con_alts)
mkCase1 dflags scrut case_bndr alts_ty ((_con1,bndrs1,rhs1) : con_alts)
| all isDeadBinder bndrs1 -- Remember the default
, length filtered_alts < length con_alts -- alternative comes first
-- Also Note [Dead binders]
= do { tick (AltMerge case_bndr)
; mkCase2 dflags scrut case_bndr alts' }
; mkCase2 dflags scrut case_bndr alts_ty alts' }
where
alts' = (DEFAULT, [], rhs1) : filtered_alts
filtered_alts = filter keep con_alts
keep (_con,bndrs,rhs) = not (all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1)
mkCase1 dflags scrut bndr alts = mkCase2 dflags scrut bndr alts
mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts
--------------------------------------------------
-- Catch-all
--------------------------------------------------
mkCase2 _dflags scrut bndr alts
= return (Case scrut bndr (coreAltsType alts) alts)
mkCase2 _dflags scrut bndr alts_ty alts
= return (Case scrut bndr alts_ty alts)
\end{code}
Note [Dead binders]
......
......@@ -24,7 +24,7 @@ import FamInstEnv ( FamInstEnv )
import Literal ( litIsLifted )
import Id
import MkId ( seqId, realWorldPrimId )
import MkCore ( mkImpossibleExpr )
import MkCore ( mkImpossibleExpr, castBottomExpr )
import IdInfo
import Name ( mkSystemVarName, isExternalName )
import Coercion hiding ( substCo, substTy, substCoVar, extendTvSubst )
......@@ -941,16 +941,16 @@ simplExprF1 env expr@(Lam {}) cont
zap b | isTyVar b = b
| otherwise = zapLamIdInfo b
simplExprF1 env (Case scrut bndr _ alts) cont
simplExprF1 env (Case scrut bndr ty alts) cont
| sm_case_case (getMode env)
= -- Simplify the scrutinee with a Select continuation
simplExprF env scrut (Select NoDup bndr alts env cont)
simplExprF env scrut (Select NoDup bndr ty 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 alts env mkBoringStop)
(Select NoDup bndr ty alts env mkBoringStop)
; rebuild env case_expr' cont }
simplExprF1 env (Let (Rec pairs) body) cont
......@@ -1035,7 +1035,7 @@ simplTick env tickish expr cont
where
interesting_cont = case cont of
Select _ _ _ _ _ -> True
Select {} -> True
_ -> False
push_tick_inside t expr0
......@@ -1157,18 +1157,18 @@ rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
-- only the in-scope set and floats should matter
rebuild env expr cont
= case cont of
Stop {} -> return (env, expr)
CoerceIt co cont -> rebuild env (mkCast expr co) cont
-- NB: mkCast implements the (Coercion co |> g) optimisation
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 }
ApplyTo dup_flag arg se cont -- See Note [Avoid redundant simplification]
| isSimplified dup_flag -> rebuild env (App expr arg) cont
| otherwise -> do { arg' <- simplExpr (se `setInScope` env) arg
; rebuild env (App expr arg') cont }
TickIt t cont -> rebuild env (mkTick t 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
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 }
ApplyTo dup_flag arg se cont -- See Note [Avoid redundant simplification]
| isSimplified dup_flag -> rebuild env (App expr arg) cont
| otherwise -> do { arg' <- simplExpr (se `setInScope` env) arg
; rebuild env (App expr arg') cont }
TickIt t cont -> rebuild env (mkTick t expr) cont
\end{code}
......@@ -1437,14 +1437,10 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) con
-- the continuation, leaving just the bottoming expression. But the
-- type might not be right, so we may have to add a coerce.
| not (contIsTrivial cont) -- Only do this if there is a non-trivial
= return (env, mk_coerce res) -- contination to discard, else we do it
where -- again and again!
= return (env, castBottomExpr res cont_ty) -- contination to discard, else we do it
where -- again and again!
res = mkApps (Var fun) (reverse rev_args)
res_ty = exprType res
cont_ty = contResultType env res_ty cont
co = mkUnsafeCo res_ty cont_ty
mk_coerce expr | cont_ty `eqType` res_ty = expr
| otherwise = mkCast expr co
cont_ty = contResultType env (exprType res) cont
rebuildCall env info (ApplyTo dup_flag (Type arg_ty) se cont)
= do { arg_ty' <- if isSimplified dup_flag then return arg_ty
......@@ -1732,6 +1728,7 @@ rebuildCase, reallyRebuildCase
:: SimplEnv
-> OutExpr -- Scrutinee
-> InId -- Case binder
-> InType -- Type of alternatives
-> [InAlt] -- Alternatives (inceasing order)
-> SimplCont
-> SimplM (SimplEnv, OutExpr)
......@@ -1740,7 +1737,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)
......@@ -1769,7 +1766,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,
......@@ -1819,7 +1816,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@[(_, bndrs, rhs)] cont
rebuildCase env scrut case_bndr alts_ty 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)),
......@@ -1832,33 +1829,30 @@ rebuildCase env scrut case_bndr 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 cont }
Nothing -> reallyRebuildCase env scrut case_bndr alts_ty alts cont }
rebuildCase env scrut case_bndr alts cont
= 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
--------------------------------------------------
-- 3. Catch-all case
--------------------------------------------------
reallyRebuildCase env scrut case_bndr alts cont
reallyRebuildCase env scrut case_bndr alts_ty 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') <- simplAlts env' scrut case_bndr alts dup_cont
; (scrut', case_bndr', alts_ty', alts') <- simplAlts env' scrut case_bndr alts_ty alts dup_cont
-- Check for empty alternatives
; if null alts' then missingAlt env case_bndr alts cont
else do
{ dflags <- getDynFlags
; case_expr <- mkCase dflags scrut' case_bndr' alts'
; dflags <- getDynFlags
; case_expr <- mkCase dflags scrut' case_bndr' alts_ty' alts'
-- Notice that rebuild gets the in-scope set from env', not alt_env
-- (which in any case is only build in simplAlts)
-- The case binder *not* scope over the whole returned case-expression
; rebuild env' case_expr nodup_cont } }
; rebuild env' case_expr nodup_cont }
\end{code}
simplCaseBinder checks whether the scrutinee is a variable, v. If so,
......@@ -1941,16 +1935,19 @@ 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, [OutAlt]) -- Includes the continuation
-> SimplM (OutExpr, OutId, OutType, [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 cont'
= -- pprTrace "simplAlts" (ppr alts $$ ppr (seTvSubst env)) $
do { let env0 = zapFloats env
simplAlts env scrut case_bndr alts_ty 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
......@@ -1965,7 +1962,8 @@ simplAlts env scrut case_bndr alts cont'
; 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') }
; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $
return (scrut', case_bndr', alts_ty', alts') }
------------------------------------
......@@ -2276,7 +2274,7 @@ 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)
......@@ -2285,7 +2283,7 @@ mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _)
-- Note [Single-alternative-unlifted]
= return (env, mkBoringStop, cont)
mkDupableCont env (Select _ case_bndr alts se cont)
mkDupableCont env (Select _ case_bndr alts_ty alts se cont)