Commit 87a229b8 authored by simonpj's avatar simonpj
Browse files

[project @ 2002-02-15 09:32:18 by simonpj]

-------------------------------------------------
	Fix an interesting case-alternatives filtering bug
	-------------------------------------------------

This bug, shown up by Krasimir's ObjectIO suite, caused the
simplifier to encounter a case expression like
	case x of { x:xs -> True; [] -> False }
in a context where x could not possibly be either a (:) or []!
Case expressions in the enclosing scope dealt with it...
So the alternative-filtering removed all the alternatives, leaving
a case expression with no branches, which GHC didn't like one little
bit.

The actual bug was elsewhere; it was because we should sometimes
filter out the DEFAULT alternative, and we weren't doing that.
To fix it, I pulled the alternative-filtering code out of Simplify
and put it in SimplUtils.prepareAlts.  It's nice now.
parent 98694bb7
......@@ -7,7 +7,7 @@
module SimplUtils (
simplBinder, simplBinders, simplRecBndrs,
simplLetBndr, simplLamBndrs,
newId, mkLam, mkCase,
newId, mkLam, prepareAlts, mkCase,
-- The continuation type
SimplCont(..), DupFlag(..), LetRhsFlag(..),
......@@ -778,6 +778,122 @@ tryRhsTyLam env tyvars body -- Only does something if there's a let
-}
\end{code}
%************************************************************************
%* *
\subsection{Case alternative filtering
%* *
%************************************************************************
prepareAlts does two things:
1. Eliminate alternatives that cannot match, including the
DEFAULT alternative.
2. If the DEFAULT alternative can match only one possible constructor,
then make that constructor explicit.
e.g.
case e of x { DEFAULT -> rhs }
===>
case e of x { (a,b) -> rhs }
where the type is a single constructor type. This gives better code
when rhs also scrutinises x or e.
It's a good idea do do this stuff before simplifying the alternatives, to
avoid simplifying alternatives we know can't happen, and to come up with
the list of constructors that are handled, to put into the IdInfo of the
case binder, for use when simplifying the alternatives.
Eliminating the default alternative in (1) isn't so obvious, but it can
happen:
data Colour = Red | Green | Blue
f x = case x of
Red -> ..
Green -> ..
DEFAULT -> h x
h y = case y of
Blue -> ..
DEFAULT -> [ case y of ... ]
If we inline h into f, the default case of the inlined h can't happen.
If we don't notice this, we may end up filtering out *all* the cases
of the inner case y, which give us nowhere to go!
\begin{code}
prepareAlts :: OutExpr -- Scrutinee
-> InId -- Case binder
-> [InAlt]
-> SimplM ([InAlt], -- Better alternatives
[AltCon]) -- These cases are handled
prepareAlts scrut case_bndr alts
= let
(alts_wo_default, maybe_deflt) = findDefault alts
impossible_cons = case scrut of
Var v -> otherCons (idUnfolding v)
other -> []
-- Filter out alternatives that can't possibly match
better_alts | null impossible_cons = alts_wo_default
| otherwise = [alt | alt@(con,_,_) <- alts_wo_default,
not (con `elem` impossible_cons)]
-- "handled_cons" are handled either by the context,
-- or by a branch in this case expression
-- (Don't add DEFAULT to the handled_cons!!)
handled_cons = impossible_cons ++ [con | (con,_,_) <- better_alts]
in
-- Filter out the default, if it can't happen,
-- or replace it with "proper" alternative if there
-- is only one constructor left
prepareDefault case_bndr handled_cons maybe_deflt `thenSmpl` \ deflt_alt ->
returnSmpl (deflt_alt ++ better_alts, handled_cons)
prepareDefault case_bndr handled_cons (Just rhs)
| Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr),
isAlgTyCon tycon, -- It's a data type, tuple, or unboxed tuples.
not (isNewTyCon tycon), -- We can have a newtype, if we are just doing an eval:
-- case x of { DEFAULT -> e }
-- and we don't want to fill in a default for them!
Just all_cons <- tyConDataCons_maybe tycon,
let handled_data_cons = [data_con | DataAlt data_con <- handled_cons],
let missing_cons = [con | con <- all_cons,
not (con `elem` handled_data_cons)]
= case missing_cons of
[] -> returnSmpl [] -- Eliminate the default alternative
-- if it can't match
[con] -> -- It matches exactly one constructor, so fill it in
tick (FillInCaseDefault case_bndr) `thenSmpl_`
mk_args con inst_tys `thenSmpl` \ args ->
returnSmpl [(DataAlt con, args, rhs)]
two_or_more -> returnSmpl [(DEFAULT, [], rhs)]
| otherwise
= returnSmpl [(DEFAULT, [], rhs)]
prepareDefault case_bndr handled_cons Nothing
= returnSmpl []
mk_args missing_con inst_tys
= getUniquesSmpl `thenSmpl` \ tv_uniqs ->
getUniquesSmpl `thenSmpl` \ id_uniqs ->
let
(_,_,ex_tyvars,_,_,_) = dataConSig missing_con
ex_tyvars' = zipWith mk tv_uniqs ex_tyvars
mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
arg_tys = dataConArgTys missing_con (inst_tys ++ mkTyVarTys ex_tyvars')
arg_ids = zipWith (mkSysLocal SLIT("a")) id_uniqs arg_tys
in
returnSmpl (ex_tyvars' ++ arg_ids)
\end{code}
%************************************************************************
%* *
......@@ -788,10 +904,10 @@ tryRhsTyLam env tyvars body -- Only does something if there's a let
mkCase puts a case expression back together, trying various transformations first.
\begin{code}
mkCase :: OutExpr -> [AltCon] -> OutId -> [OutAlt] -> SimplM OutExpr
mkCase :: OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr
mkCase scrut handled_cons case_bndr alts
= mkAlts scrut handled_cons case_bndr alts `thenSmpl` \ better_alts ->
mkCase scrut case_bndr alts
= mkAlts scrut case_bndr alts `thenSmpl` \ better_alts ->
mkCase1 scrut case_bndr better_alts
\end{code}
......@@ -814,16 +930,7 @@ mkAlts tries these things:
a) all branches equal
b) some branches equal to the DEFAULT (which occurs first)
2. If the DEFAULT alternative can match only one possible constructor,
then make that constructor explicit.
e.g.
case e of x { DEFAULT -> rhs }
===>
case e of x { (a,b) -> rhs }
where the type is a single constructor type. This gives better code
when rhs also scrutinises x or e.
3. Case merging:
2. Case merging:
case e of b { ==> case e of b {
p1 -> rhs1 p1 -> rhs1
... ...
......@@ -866,7 +973,7 @@ and similarly in cascade for all the join points!
--------------------------------------------------
-- 1. Merge identical branches
--------------------------------------------------
mkAlts scrut handled_cons case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
mkAlts scrut case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
| all isDeadBinder bndrs1, -- Remember the default
length filtered_alts < length con_alts -- alternative comes first
= tick (AltMerge case_bndr) `thenSmpl_`
......@@ -878,43 +985,10 @@ mkAlts scrut handled_cons case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
--------------------------------------------------
-- 2. Fill in missing constructor
-- 2. Merge nested cases
--------------------------------------------------
mkAlts scrut handled_cons case_bndr alts
| (alts_no_deflt, Just rhs) <- findDefault alts,
-- There is a DEFAULT case
Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr),
isAlgTyCon tycon, -- It's a data type, tuple, or unboxed tuples.
not (isNewTyCon tycon), -- We can have a newtype, if we are just doing an eval:
-- case x of { DEFAULT -> e }
-- and we don't want to fill in a default for them!
Just all_cons <- tyConDataCons_maybe tycon,
[missing_con] <- [con | con <- all_cons, not (con `elem` handled_data_cons)]
-- There is just one missing constructor!
= tick (FillInCaseDefault case_bndr) `thenSmpl_`
getUniquesSmpl `thenSmpl` \ tv_uniqs ->
getUniquesSmpl `thenSmpl` \ id_uniqs ->
let
(_,_,ex_tyvars,_,_,_) = dataConSig missing_con
ex_tyvars' = zipWith mk tv_uniqs ex_tyvars
mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
arg_ids = zipWith (mkSysLocal SLIT("a")) id_uniqs arg_tys
arg_tys = dataConArgTys missing_con (inst_tys ++ mkTyVarTys ex_tyvars')
better_alts = (DataAlt missing_con, ex_tyvars' ++ arg_ids, rhs) : alts_no_deflt
in
returnSmpl better_alts
where
handled_data_cons = [data_con | DataAlt data_con <- handled_cons]
--------------------------------------------------
-- 3. Merge nested cases
--------------------------------------------------
mkAlts scrut handled_cons outer_bndr outer_alts
mkAlts scrut outer_bndr outer_alts
| opt_SimplCaseMerge,
(outer_alts_without_deflt, maybe_outer_deflt) <- findDefault outer_alts,
Just (Case (Var scrut_var) inner_bndr inner_alts) <- maybe_outer_deflt,
......@@ -958,7 +1032,7 @@ mkAlts scrut handled_cons outer_bndr outer_alts
-- Catch-all
--------------------------------------------------
mkAlts scrut handled_cons case_bndr other_alts = returnSmpl other_alts
mkAlts scrut case_bndr other_alts = returnSmpl other_alts
\end{code}
......@@ -1141,6 +1215,12 @@ mkCase1 scrut case_bndr [(con,bndrs,rhs)]
-- 2. Identity case
--------------------------------------------------
#ifdef DEBUG
mkCase1 scrut case_bndr []
= pprTrace "mkCase1: null alts" (ppr case_bndr <+> ppr scrut) $
returnSmpl scrut
#endif
mkCase1 scrut case_bndr alts -- Identity case
| all identity_alt alts
= tick (CaseIdentity case_bndr) `thenSmpl_`
......
......@@ -12,7 +12,7 @@ import CmdLineOpts ( dopt, DynFlag(Opt_D_dump_inlinings),
SimplifierSwitch(..)
)
import SimplMonad
import SimplUtils ( mkCase, mkLam, newId,
import SimplUtils ( mkCase, mkLam, newId, prepareAlts,
simplBinder, simplBinders, simplLamBndrs, simplRecBndrs, simplLetBndr,
SimplCont(..), DupFlag(..), LetRhsFlag(..),
mkStop, mkBoringStop, pushContArgs,
......@@ -22,7 +22,7 @@ import SimplUtils ( mkCase, mkLam, newId,
import Var ( mustHaveLocalBinding )
import VarEnv
import Id ( Id, idType, idInfo, idArity, isDataConId,
idUnfolding, setIdUnfolding, isDeadBinder,
setIdUnfolding, isDeadBinder,
idNewDemandInfo, setIdInfo,
setIdOccInfo, zapLamIdInfo, setOneShotLambda,
)
......@@ -35,11 +35,11 @@ import NewDemand ( isStrictDmd )
import DataCon ( dataConNumInstArgs, dataConRepStrictness )
import CoreSyn
import PprCore ( pprParendExpr, pprCoreExpr )
import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons, callSiteInline )
import CoreUnfold ( mkOtherCon, mkUnfolding, callSiteInline )
import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding,
exprIsConApp_maybe, mkPiTypes, findAlt,
exprType, exprIsValue,
exprOkForSpeculation, exprArity, findDefault,
exprOkForSpeculation, exprArity,
mkCoerce, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg
)
import Rules ( lookupRule )
......@@ -1230,38 +1230,22 @@ rebuildCase env scrut case_bndr alts cont
= knownCon env (LitAlt lit) [] case_bndr alts cont
| otherwise
= -- Prepare case alternatives
-- Filter out alternatives that can't possibly match
let
impossible_cons = case scrut of
Var v -> otherCons (idUnfolding v)
other -> []
better_alts = case impossible_cons of
[] -> alts
other -> [alt | alt@(con,_,_) <- alts,
not (con `elem` impossible_cons)]
-- "handled_cons" are handled either by the context,
-- or by a branch in this case expression
-- Don't add DEFAULT to the handled_cons!!
(alts_wo_default, _) = findDefault better_alts
handled_cons = impossible_cons ++ [con | (con,_,_) <- alts_wo_default]
in
= prepareAlts scrut case_bndr alts `thenSmpl` \ (better_alts, handled_cons) ->
-- Deal with the case binder, and prepare the continuation;
-- The new subst_env is in place
prepareCaseCont env better_alts cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
addFloats env floats $ \ env ->
prepareCaseCont env better_alts cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
addFloats env floats $ \ env ->
-- Deal with variable scrutinee
simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr', zap_occ_info) ->
simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr', zap_occ_info) ->
-- Deal with the case alternatives
simplAlts alt_env zap_occ_info handled_cons
case_bndr' better_alts dup_cont `thenSmpl` \ alts' ->
case_bndr' better_alts dup_cont `thenSmpl` \ alts' ->
-- Put the case back together
mkCase scrut handled_cons case_bndr' alts' `thenSmpl` \ case_expr ->
mkCase scrut case_bndr' alts' `thenSmpl` \ case_expr ->
-- Notice that rebuildDone returns the in-scope set from env, not alt_env
-- The case binder *not* scope over the whole returned case-expression
......
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