Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Alex D
GHC
Commits
4202879d
Commit
4202879d
authored
May 02, 2012
by
Ian Lynagh
Browse files
Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc
parents
84a9c46b
f7c26576
Changes
19
Hide whitespace changes
Inline
Side-by-side
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 = foldr
1
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 (foldr
1
addAltSize alt_sizes)
(foldr
1
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 = foldr
1
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
--------------------------------------------------