Skip to content

GitLab

Commit 4202879d authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc

parents 84a9c46b f7c26576
Hide whitespace changes
Inline Side-by-side
Showing with 226 additions and 122 deletions
compiler/cmm/PprC.hs
View file @ 4202879d
......@@ -203,9 +203,6 @@ pprStmt platform stmt = case stmt of
pprCFunType (pprCLabel platform lbl) cconv results args <>
noreturn_attr <> semi
fun_proto lbl = ptext (sLit ";EF_(") <>
pprCLabel platform lbl <> char ')' <> semi
noreturn_attr = case ret of
CmmNeverReturns -> text "__attribute__ ((noreturn))"
CmmMayReturn -> empty
......@@ -226,12 +223,7 @@ pprStmt platform stmt = case stmt of
let myCall = pprCall platform (pprCLabel platform lbl) cconv results args
in (real_fun_proto lbl, myCall)
| not (isMathFun lbl) ->
let myCall = braces (
pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
$$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
$$ pprCall platform (text "ghcFunPtr") cconv results args <> semi
)
in (fun_proto lbl, myCall)
pprForeignCall platform (pprCLabel platform lbl) cconv results args
_ ->
(empty {- no proto -},
pprCall platform cast_fn cconv results args <> semi)
......@@ -241,19 +233,36 @@ pprStmt platform stmt = case stmt of
vcat $ map (pprStmt platform) stmts
CmmCall (CmmPrim op _) results args _ret ->
pprCall platform ppr_fn CCallConv results args'
where
ppr_fn = pprCallishMachOp_for_C op
-- The mem primops carry an extra alignment arg, must drop it.
-- We could maybe emit an alignment directive using this info.
args' | op == MO_Memcpy || op == MO_Memset || op == MO_Memmove = init args
| otherwise = args
proto $$ fn_call
where
cconv = CCallConv
fn = pprCallishMachOp_for_C op
(proto, fn_call)
-- The mem primops carry an extra alignment arg, must drop it.
-- We could maybe emit an alignment directive using this info.
-- We also need to cast mem primops to prevent conflicts with GCC
-- builtins (see bug #5967).
| op `elem` [MO_Memcpy, MO_Memset, MO_Memmove]
= pprForeignCall platform fn cconv results (init args)
| otherwise
= (empty, pprCall platform fn cconv results args)
CmmBranch ident -> pprBranch ident
CmmCondBranch expr ident -> pprCondBranch platform expr ident
CmmJump lbl _ -> mkJMP_(pprExpr platform lbl) <> semi
CmmSwitch arg ids -> pprSwitch platform arg ids
pprForeignCall :: Platform -> SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> (SDoc, SDoc)
pprForeignCall platform fn cconv results args = (proto, fn_call)
where
fn_call = braces (
pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
$$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
$$ pprCall platform (text "ghcFunPtr") cconv results args <> semi
)
cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn)
proto = ptext (sLit ";EF_(") <> fn <> char ')' <> semi
pprCFunType :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc
pprCFunType ppr_fn cconv ress args
= res_type ress <+>
......
compiler/coreSyn/CoreArity.lhs
View file @ 4202879d
......@@ -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)
......
compiler/coreSyn/CoreFVs.lhs
View file @ 4202879d
......@@ -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))
......
compiler/coreSyn/CoreLint.lhs
View file @ 4202879d
......@@ -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")
......
compiler/coreSyn/CoreSyn.lhs
View file @ 4202879d
......@@ -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
......
compiler/coreSyn/CoreUnfold.lhs
View file @ 4202879d
......@@ -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
......
compiler/coreSyn/MkCore.lhs
View file @ 4202879d
......@@ -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
......
compiler/iface/BinIface.hs
View file @ 4202879d
......@@ -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
......
compiler/iface/IfaceSyn.lhs
View file @ 4202879d
......@@ -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
......
compiler/iface/MkIface.lhs
View file @ 4202879d
......@@ -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)
......
compiler/iface/TcIface.lhs
View file @ 4202879d
......@@ -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)
......
compiler/simplCore/OccurAnal.lhs
View file @ 4202879d
......@@ -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
......
compiler/simplCore/SimplCore.lhs
View file @ 4202879d
......@@ -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
......
compiler/simplCore/SimplUtils.lhs
View file @ 4202879d
......@@ -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]
......
compiler/simplCore/Simplify.lhs
View file @ 4202879d
......@@ -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