import ForeignCall ( ForeignCall )
import DataCon ( DataCon, DataConIds(..), dataConTyVars,
dataConFieldLabels, dataConRepArity,
- dataConRepArgTys, dataConRepType,
- dataConStupidTheta, dataConOrigArgTys,
+ dataConRepArgTys, dataConRepType, dataConStupidTheta,
dataConSig, dataConStrictMarks, dataConExStricts,
splitProductType, isVanillaDataCon
)
MarkedStrict
| isUnLiftedType (idType arg) -> body i (arg:rep_args)
| otherwise ->
--- gaw 2004
Case (Var arg) arg result_ty [(DEFAULT,[], body i (arg:rep_args))]
MarkedUnboxed
-> case splitProductType "do_unbox" (idType arg) of
(tycon, tycon_args, con, tys) ->
--- gaw 2004
- Case (Var arg) arg result_ty [(DataAlt con, con_args,
- body i' (reverse con_args ++ rep_args))]
+ Case (Var arg) arg result_ty
+ [(DataAlt con,
+ con_args,
+ body i' (reverse con_args ++ rep_args))]
where
(con_args, i') = mkLocals i tys
arg_base = dict_id_base + 1
alts = map mk_maybe_alt data_cons
- the_alts = catMaybes alts
+ the_alts = catMaybes alts -- Already sorted by data-con
no_default = all isJust alts -- No default needed
default_alt | no_default = []
\begin{code}
checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
-- a) Check that the alts are non-empty
--- b) Check that the DEFAULT comes first, if it exists
+-- b1) Check that the DEFAULT comes first, if it exists
+-- b2) Check that the others are in increasing order
-- c) Check that there's a default for infinite types
-- NB: Algebraic cases are not necessarily exhaustive, because
-- the simplifer correctly eliminates case that can't
checkCaseAlts e ty alts =
do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
+ ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
; checkL (isJust maybe_deflt || not is_infinite_ty)
(nonExhaustiveAltsMsg e) }
where
(con_alts, maybe_deflt) = findDefault alts
+ -- Check that successive alternatives have increasing tags
+ increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
+ increasing_tag other = True
+
non_deflt (DEFAULT, _, _) = False
non_deflt alt = True
mkNonDefltMsg e
= hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
+mkNonIncreasingAltsMsg e
+ = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
nonExhaustiveAltsMsg :: CoreExpr -> Message
nonExhaustiveAltsMsg e
where
(bndrs,body) = collectBinders expr
--- gaw 2004
corePrepExprFloat env (Case scrut bndr ty alts)
= corePrepExprFloat env scrut `thenUs` \ (floats1, scrut1) ->
deLamFloat scrut1 `thenUs` \ (floats2, scrut2) ->
cloneBndr env bndr `thenUs` \ (env', bndr') ->
mapUs (sat_alt env') alts `thenUs` \ alts' ->
--- gaw 2004
returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr' ty alts')
where
sat_alt env (con, bs, rhs)
| otherwise = deLam body `thenUs` \ body' ->
returnUs (foldrOL mk_bind body' binds)
where
--- gaw 2004
mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
mk_bind (FloatLet bind) body = Let bind body
mkConApp,
varToCoreExpr,
- isTyVar, isId,
+ isTyVar, isId, cmpAltCon, cmpAlt, ltAlt,
bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
collectArgs,
import Var ( Var, Id, TyVar, isTyVar, isId )
import Type ( Type, mkTyVarTy, seqType )
import Literal ( Literal, mkMachInt )
-import DataCon ( DataCon, dataConWorkId )
+import DataCon ( DataCon, dataConWorkId, dataConTag )
import BasicTypes ( Activation )
import VarSet
import FastString
| App (Expr b) (Arg b)
| Lam b (Expr b)
| Let (Bind b) (Expr b)
- -- gaw 2004, added Type field
| Case (Expr b) b Type [Alt b] -- Binder gets bound to value of scrutinee
-- Invariant: The list of alternatives is ALWAYS EXHAUSTIVE,
-- meaning that it covers all cases that can occur
-- See the example below
--
-- Invariant: The DEFAULT case must be *first*, if it occurs at all
+ -- Invariant: The remaining cases are in order of increasing
+ -- tag (for DataAlts)
+ -- lit (for LitAlts)
+ -- This makes finding the relevant constructor easy,
+ -- and makes comparison easier too
| Note Note (Expr b)
| Type Type -- This should only show up at the top
-- level of an Arg
| DEFAULT
deriving (Eq, Ord)
+
data Bind b = NonRec b (Expr b)
| Rec [(b, (Expr b))]
instance Show AltCon where
showsPrec p con = showsPrecSDoc p (ppr con)
+
+cmpAlt :: Alt b -> Alt b -> Ordering
+cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
+
+ltAlt :: Alt b -> Alt b -> Bool
+ltAlt a1 a2 = case a1 `cmpAlt` a2 of { LT -> True; other -> False }
+
+cmpAltCon :: AltCon -> AltCon -> Ordering
+-- Compares AltCons within a single list of alternatives
+cmpAltCon DEFAULT DEFAULT = EQ
+cmpAltCon DEFAULT con = LT
+
+cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
+cmpAltCon (DataAlt _) DEFAULT = GT
+cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2
+cmpAltCon (LitAlt _) DEFAULT = GT
+
+cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
+ ppr con1 <+> ppr con2 )
+ LT
\end{code}
= tidyBind env b =: \ (env', b') ->
Let b' (tidyExpr env' e)
--- gaw 2004
tidyExpr env (Case e b ty alts)
= tidyBndr env b =: \ (env', b) ->
--- gaw 2004
Case (tidyExpr env e) b (tidyType env ty) (map (tidyAlt env') alts)
tidyExpr env (Lam b e)
where
rhs_size = foldr (addSize . size_up . snd) sizeZero pairs
--- gaw 2004
size_up (Case (Var v) _ _ alts)
| v `elem` top_args -- We are scrutinising an argument variable
=
exprType (Var var) = idType var
exprType (Lit lit) = literalType lit
exprType (Let _ body) = exprType body
--- gaw 2004
exprType (Case _ _ ty alts) = ty
exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
exprType (Note other_note e) = exprType e
-- deals with them perfectly well.
bindNonRec bndr rhs body
--- gaw 2004
| needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
| otherwise = Let (NonRec bndr rhs) body
mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
mkIfThenElse guard then_expr else_expr
--- gaw 2004
-- Not going to be refining, so okay to take the type of the "then" clause
= Case guard (mkWildId boolTy) (exprType then_expr)
- [ (DataAlt trueDataCon, [], then_expr),
- (DataAlt falseDataCon, [], else_expr) ]
+ [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag!
+ (DataAlt trueDataCon, [], then_expr) ]
\end{code}
= case alts of
(deflt@(DEFAULT,_,_):alts) -> go alts deflt
other -> go alts panic_deflt
-
where
panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
- go [] deflt = deflt
- go (alt@(con1,_,_) : alts) deflt | con == con1 = alt
- | otherwise = ASSERT( not (con1 == DEFAULT) )
- go alts deflt
+ go [] deflt = deflt
+ go (alt@(con1,_,_) : alts) deflt
+ = case con `cmpAltCon` con1 of
+ LT -> deflt -- Missed it already; the alts are in increasing order
+ EQ -> alt
+ GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
\end{code}
exprIsCheap (Note InlineMe e) = True
exprIsCheap (Note _ e) = exprIsCheap e
exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
--- gaw 2004
exprIsCheap (Case e _ _ alts) = exprIsCheap e &&
and [exprIsCheap rhs | (_,_,rhs) <- alts]
-- Experimentally, treat (case x of ...) as cheap
-- n is the number of args
go n (Note _ e) = go n e
go n (Let _ e) = go n e
--- gaw 2004
go n (Case e _ _ _) = go 0 e -- Just check the scrut
go n (App e _) = go (n+1) e
go n (Var v) = idAppIsBottom v n
go n (Lit _) = False
go n (Lam _ _) = False
+ go n (Type _) = False
idAppIsBottom :: Id -> Int -> Bool
idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
-- ===>
-- f x y = case x of { (a,b) -> e }
-- The difference is observable using 'seq'
--- gaw 2004
arityType (Case scrut _ _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
xs@(AFun one_shot _) | one_shot -> xs
xs | exprIsCheap scrut -> xs
exprSize (App f a) = exprSize f + exprSize a
exprSize (Lam b e) = varSize b + exprSize e
exprSize (Let b e) = bindSize b + exprSize e
--- gaw 2004
exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
exprSize (Note n e) = noteSize n + exprSize e
exprSize (Type t) = seqType t `seq` 1
hash_expr (Note _ e) = hash_expr e
hash_expr (Let (NonRec b r) e) = hashId b
hash_expr (Let (Rec ((b,r):_)) e) = hashId b
--- gaw 2004
hash_expr (Case _ b _ _) = hashId b
hash_expr (App f e) = hash_expr f * fast_hash_expr e
hash_expr (Var v) = hashId v
other -> add_par (hang (pprParendExpr fun) 2 pp_args)
}
--- gaw 2004
ppr_expr add_par (Case expr var ty [(con,args,rhs)])
= add_par $
sep [sep [ptext SLIT("case") <+> parens (ppr ty) <+> pprCoreExpr expr,
where
ppr_bndr = pprBndr CaseBind
--- gaw 2004
ppr_expr add_par (Case expr var ty alts)
= add_par $
sep [sep [ptext SLIT("case") <+> parens (ppr ty) <+> pprCoreExpr expr,
pexp (Lam b e) = char '\\' <+> plamexp [b] e
pexp (Let vd e) = (text "%let" <+> pvdefg vd) $$ (text "%in" <+> pexp e)
--- gaw 2004
pexp (Case e vb ty alts) = sep [text "%case" <+> parens (paty ty) <+> paexp e,
text "%of" <+> pvbind vb]
$$ (indent (braces (vcat (punctuate (char ';') (map palt alts)))))
cprAnalCaseAlts :: CPREnv -> [CoreAlt] -> ([CoreAlt], AbsVal)
cprAnalCaseAlts rho alts
- = foldl anal_alt ([], Bot) alts
+ = foldr anal_alt ([], Bot) alts
where
- anal_alt :: ([CoreAlt], AbsVal) -> CoreAlt -> ([CoreAlt], AbsVal)
- anal_alt (done, aval) (con, binds, exp)
- = (done ++ [(con,binds,exp_cpr)], aval `lub` exp_aval)
+ anal_alt :: CoreAlt -> ([CoreAlt], AbsVal) -> ([CoreAlt], AbsVal)
+ anal_alt (con, binds, exp) (done, aval)
+ = ((con,binds,exp_cpr) : done, exp_aval `lub` aval)
where (exp_cpr, exp_aval) = cprAnalExpr rho' exp
rho' = rho `extendVarEnvList` (zip binds (repeat Top))
coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
coreCasePair scrut_var var1 var2 body
--- gaw 2004
= Case (Var scrut_var) scrut_var (exprType body)
[(DataAlt (tupleCon Boxed 2), [var1, var2], body)]
\end{code}
tc `hasKey` boolTyConKey
= newSysLocalDs intPrimTy `thenDs` \ prim_arg ->
returnDs (Var prim_arg,
--- gaw 2004
\ body -> Case (Case arg (mkWildId arg_ty) intPrimTy
[(DataAlt falseDataCon,[],mkIntLit 0),
(DataAlt trueDataCon, [],mkIntLit 1)])
+ -- In increasing tag order!
prim_arg
--- gaw 2004
(exprType body)
[(DEFAULT,[],body)])
newSysLocalDs arg_ty `thenDs` \ case_bndr ->
newSysLocalDs data_con_arg_ty1 `thenDs` \ prim_arg ->
returnDs (Var prim_arg,
--- gaw 2004
\ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
)
= newSysLocalDs arg_ty `thenDs` \ case_bndr ->
newSysLocalsDs data_con_arg_tys `thenDs` \ vars@[l_var, r_var, arr_cts_var] ->
returnDs (Var arr_cts_var,
--- gaw 2004
\ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
)
Lam state_id $
Case (App the_call (Var state_id))
(mkWildId ccall_res_ty)
--- gaw 2004
(coreAltType the_alt)
[the_alt]
]
let
wrap = \ the_call -> Case (App the_call (Var realWorldPrimId))
(mkWildId ccall_res_ty)
--- gaw 2004
(coreAltType the_alt)
[the_alt]
in
| Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
= returnDs
(Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
--- gaw 2004
boolTy
[(DEFAULT ,[],Var trueDataConId ),
(LitAlt (mkMachInt 0),[],Var falseDataConId)])
rest_expr core_fail `thenDs` \ core_match ->
let
rhs = Lam u1 $
--- gaw 2004
Case (Var u1) u1 res_ty
[(DataAlt nilDataCon, [], core_list2),
(DataAlt consDataCon, [u2, u3], core_match)]
+ -- Increasing order of tag
in
returnDs (Let (Rec [(h, rhs)]) letrec_body)
\end{code}
zip_fn_ty = mkFunTys list_tys list_ret_ty
mk_case (as, a', as') rest
--- gaw 2004
= Case (Var as) as list_ret_ty
[(DataAlt nilDataCon, [], mkNilExpr ret_elt_ty),
(DataAlt consDataCon, [a', as'], rest)]
-
+ -- Increasing order of tag
-- Helper functions that makes an HsTuple only for non-1-sized tuples
mk_hs_tuple_expr :: [Id] -> LHsExpr Id
mk_hs_tuple_expr [] = nlHsVar unitDataConId
import Name ( Name )
import Literal ( Literal(..), mkStringLit, inIntRange, tARGET_MAX_INT )
import TyCon ( isNewTyCon, tyConDataCons )
-import DataCon ( DataCon, dataConSourceArity, dataConTyCon )
+import DataCon ( DataCon, dataConSourceArity, dataConTyCon, dataConTag )
import Type ( mkFunTy, isUnLiftedType, Type, splitTyConApp, mkTyVarTy )
-import TcType ( tcTyConAppTyCon, tcEqType )
+import TcType ( tcEqType )
import TysPrim ( intPrimTy )
import TysWiredIn ( nilDataCon, consDataCon,
tupleCon, mkTupleTy,
lengthPName, indexPName )
import Outputable
import UnicodeUtil ( intsToUtf8 )
-import SrcLoc ( Located(..), unLoc, noLoc )
-import Util ( isSingleton, notNull, zipEqual )
+import SrcLoc ( Located(..), unLoc )
+import Util ( isSingleton, notNull, zipEqual, sortWith )
import ListSetOps ( assocDefault )
import FastString
\end{code}
= MatchResult CanFail mk_case
where
mk_case fail
- = mappM (mk_alt fail) match_alts `thenDs` \ alts ->
+ = mappM (mk_alt fail) sorted_alts `thenDs` \ alts ->
returnDs (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
+ sorted_alts = sortWith fst match_alts -- Right order for a Case
mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body ->
returnDs (LitAlt lit, [], body)
= CanFail
wild_var = mkWildId (idType var)
- mk_case fail = mappM (mk_alt fail) match_alts `thenDs` \ alts ->
+ sorted_alts = sortWith get_tag match_alts
+ get_tag (con, _, _) = dataConTag con
+ mk_case fail = mappM (mk_alt fail) sorted_alts `thenDs` \ alts ->
returnDs (Case (Var var) wild_var ty (mk_default fail ++ alts))
mk_alt fail (con, args, MatchResult _ body_fn)
--
unboxAlt =
newSysLocalDs intPrimTy `thenDs` \l ->
- dsLookupGlobalId indexPName `thenDs` \indexP ->
- mappM (mkAlt indexP) match_alts `thenDs` \alts ->
+ dsLookupGlobalId indexPName `thenDs` \indexP ->
+ mappM (mkAlt indexP) sorted_alts `thenDs` \alts ->
returnDs (DataAlt intDataCon, [l], (Case (Var l) wild ty (dft : alts)))
where
wild = mkWildId intPrimTy
mkSmallTupleCase [var] body _scrut_var scrut
= bindNonRec var scrut body
mkSmallTupleCase vars body scrut_var scrut
--- gaw 2004
-- One branch no refinement?
= Case scrut scrut_var (exprType body) [(DataAlt (tupleCon Boxed (length vars)), vars, body)]
\end{code}
mkCoreSel vars the_var scrut_var scrut
= ASSERT( notNull vars )
--- gaw 2004
Case scrut scrut_var (idType the_var)
[(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
\end{code}
import TysWiredIn ( stringTy, consDataCon, intDataCon, floatDataCon, doubleDataCon )
import Unique ( hasKey )
import Literal ( mkMachInt, Literal(..) )
-import SrcLoc ( noLoc, unLoc )
+import SrcLoc ( noLoc )
import ListSetOps ( equivClasses, runs )
import Ratio ( numerator, denominator )
import SrcLoc ( Located(..) )
tcIfaceExpr arg `thenM` \ arg' ->
returnM (App fun' arg')
--- gaw 2004
tcIfaceExpr (IfaceCase scrut case_bndr ty alts)
= tcIfaceExpr scrut `thenM` \ scrut' ->
newIfaceName case_bndr `thenM` \ case_bndr_name ->
Just id' -> fastBool (mayHaveCafRefs (idCafInfo id'))
Nothing -> fastBool False
-cafRefs p (Lit l) = fastBool False
-cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a
-cafRefs p (Lam x e) = cafRefs p e
-cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
--- gaw 2004
+cafRefs p (Lit l) = fastBool False
+cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a
+cafRefs p (Lam x e) = cafRefs p e
+cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
cafRefs p (Case e bndr _ alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts)
-cafRefs p (Note n e) = cafRefs p e
-cafRefs p (Type t) = fastBool False
+cafRefs p (Note n e) = cafRefs p e
+cafRefs p (Type t) = fastBool False
cafRefss p [] = fastBool False
cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es
(vbody, vbodyTy) <- vectorise body
return ((Let vbind vbody), vbodyTy)
--- gaw 2004
vectorise (Case expr b ty alts) =
do
(vexpr, vexprTy) <- vectorise expr
newExpr = substIdEnv newEnv expr
substBnd (b,e) = (b, substIdEnv newEnv e)
in Let (Rec (map substBnd bnds)) newExpr
--- gaw 2004
substIdEnv env (Case expr b ty alts) =
Case (substIdEnv newEnv expr) b ty (map substAlt alts)
where
t2 = arrUsage expr
in if isArrayUsage t1 then Array else t2
--- gaw 2004
arrUsage (Case expr b _ alts) =
let
t1 = arrUsage expr
litEq is_eq other = Nothing
do_lit_eq is_eq lit expr
--- gaw 2004
= Just (Case expr (mkWildId (literalType lit)) boolTy
[(DEFAULT, [], val_if_neq),
(LitAlt lit, [], val_if_eq)])
alternatives/default [default FVs always {\em first}!].
\begin{code}
--- gaw 2004
fiExpr to_drop (_, AnnCase scrut case_bndr ty alts)
= mkCoLets' drop_here1 $
mkCoLets' drop_here2 $
where
bind_lvl = getBindLevel bind
--- gaw 2004
floatExpr lvl (Case scrut (TB case_bndr case_lvl) ty alts)
= case floatExpr lvl scrut of { (fse, fde, scrut') ->
case floatList float_alt alts of { (fsa, fda, alts') ->
where
(env_body, bind') = libCaseBind env bind
--- gaw 2004
libCase env (Case scrut bndr ty alts)
= Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts)
where
env2 = env1 `addNewCands` binders -- Add in-scope binders
env_body = vanillaCtxt env2 -- Body is (no longer) an RhsContext
--- gaw 2004
occAnal env (Case scrut bndr ty alts)
= case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts') ->
- case occAnal (vanillaCtxt env) scrut of { (scrut_usage, scrut') ->
+ case occAnal (vanillaCtxt env) scrut of { (scrut_usage, scrut') ->
-- No need for rhsCtxt
let
alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
(alts_usage1, tagged_bndr) = tagBinder alts_usage' bndr
total_usage = scrut_usage `combineUsageDetails` alts_usage1
in
--- gaw 2004
total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
where
alt_env = env `addNewCand` bndr
lvlExpr ctxt_lvl new_env body `thenLvl` \ body' ->
returnLvl (Let bind' body')
--- gaw 2004
lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr ty alts)
= lvlMFE True ctxt_lvl env expr `thenLvl` \ expr' ->
let
\begin{code}
prepareAlts :: OutExpr -- Scrutinee
-> InId -- Case binder
- -> [InAlt]
- -> SimplM ([InAlt], -- Better alternatives
+ -> [InAlt] -- Increasing order
+ -> SimplM ([InAlt], -- Better alternatives, still incresaing order
[AltCon]) -- These cases are handled
prepareAlts scrut case_bndr alts
-- is only one constructor left
prepareDefault case_bndr handled_cons maybe_deflt `thenSmpl` \ deflt_alt ->
- returnSmpl (deflt_alt ++ better_alts, handled_cons)
+ returnSmpl (mergeAlts better_alts deflt_alt, handled_cons)
+ -- We need the mergeAlts in case the new default_alt
+ -- has turned into a constructor alternative.
prepareDefault case_bndr handled_cons (Just rhs)
| Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr),
mkCase puts a case expression back together, trying various transformations first.
\begin{code}
-mkCase :: OutExpr -> OutId -> OutType -> [OutAlt] -> SimplM OutExpr
+mkCase :: OutExpr -> OutId -> OutType
+ -> [OutAlt] -- Increasing order
+ -> SimplM OutExpr
mkCase scrut case_bndr ty alts
- = mkAlts scrut case_bndr alts `thenSmpl` \ better_alts ->
+ = getDOptsSmpl `thenSmpl` \dflags ->
+ mkAlts dflags scrut case_bndr alts `thenSmpl` \ better_alts ->
mkCase1 scrut case_bndr ty better_alts
\end{code}
--------------------------------------------------
-- 1. Merge identical branches
--------------------------------------------------
-mkAlts scrut case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
+mkAlts dflags 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_`
-- 2. Merge nested cases
--------------------------------------------------
-mkAlts scrut outer_bndr outer_alts
- = getDOptsSmpl `thenSmpl` \dflags ->
- mkAlts' dflags scrut outer_bndr outer_alts
- where
- mkAlts' dflags scrut outer_bndr outer_alts
- | dopt Opt_CaseMerge dflags,
- (outer_alts_without_deflt, maybe_outer_deflt) <- findDefault outer_alts,
--- gaw 2004
- Just (Case (Var scrut_var) inner_bndr _ inner_alts) <- maybe_outer_deflt,
- scruting_same_var scrut_var
-
- = let -- Eliminate any inner alts which are shadowed by the outer ones
- outer_cons = [con | (con,_,_) <- outer_alts_without_deflt]
-
- munged_inner_alts = [ (con, args, munge_rhs rhs)
- | (con, args, rhs) <- inner_alts,
- not (con `elem` outer_cons) -- Eliminate shadowed inner alts
- ]
- munge_rhs rhs = bindCaseBndr inner_bndr (Var outer_bndr) rhs
-
- (inner_con_alts, maybe_inner_default) = findDefault munged_inner_alts
-
- new_alts = add_default maybe_inner_default
- (outer_alts_without_deflt ++ inner_con_alts)
+mkAlts dflags scrut outer_bndr outer_alts
+ | dopt Opt_CaseMerge dflags,
+ (outer_alts_without_deflt, maybe_outer_deflt) <- findDefault outer_alts,
+ Just (Case (Var scrut_var) inner_bndr _ inner_alts) <- maybe_outer_deflt,
+ scruting_same_var scrut_var
+ = let
+ munged_inner_alts = [(con, args, munge_rhs rhs) | (con, args, rhs) <- inner_alts]
+ munge_rhs rhs = bindCaseBndr inner_bndr (Var outer_bndr) rhs
+
+ new_alts = mergeAlts outer_alts_without_deflt munged_inner_alts
+ -- The merge keeps the inner DEFAULT at the front, if there is one
+ -- and eliminates any inner_alts that are shadowed by the outer_alts
in
tick (CaseMerge outer_bndr) `thenSmpl_`
returnSmpl new_alts
- -- Warning: don't call mkAlts recursively!
- -- Firstly, there's no point, because inner alts have already had
- -- mkCase applied to them, so they won't have a case in their default
- -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
- -- in munge_rhs may put a case into the DEFAULT branch!
- where
- -- We are scrutinising the same variable if it's
- -- the outer case-binder, or if the outer case scrutinises a variable
- -- (and it's the same). Testing both allows us not to replace the
- -- outer scrut-var with the outer case-binder (Simplify.simplCaseBinder).
- scruting_same_var = case scrut of
+ -- Warning: don't call mkAlts recursively!
+ -- Firstly, there's no point, because inner alts have already had
+ -- mkCase applied to them, so they won't have a case in their default
+ -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
+ -- in munge_rhs may put a case into the DEFAULT branch!
+ where
+ -- We are scrutinising the same variable if it's
+ -- the outer case-binder, or if the outer case scrutinises a variable
+ -- (and it's the same). Testing both allows us not to replace the
+ -- outer scrut-var with the outer case-binder (Simplify.simplCaseBinder).
+ scruting_same_var = case scrut of
Var outer_scrut -> \ v -> v == outer_bndr || v == outer_scrut
other -> \ v -> v == outer_bndr
- add_default (Just rhs) alts = (DEFAULT,[],rhs) : alts
- add_default Nothing alts = alts
-
-
---------------------------------------------------
+------------------------------------------------
-- Catch-all
---------------------------------------------------
-
- mkAlts' dflags scrut case_bndr other_alts = returnSmpl other_alts
+------------------------------------------------
+
+mkAlts dflags scrut case_bndr other_alts = returnSmpl other_alts
+
+
+---------------------------------
+mergeAlts :: [OutAlt] -> [OutAlt] -> [OutAlt]
+-- Merge preserving order; alternatives in the first arg
+-- shadow ones in the second
+mergeAlts [] as2 = as2
+mergeAlts as1 [] = as1
+mergeAlts (a1:as1) (a2:as2)
+ = case a1 `cmpAlt` a2 of
+ LT -> a1 : mergeAlts as1 (a2:as2)
+ EQ -> a1 : mergeAlts as1 as2 -- Discard a2
+ GT -> a2 : mergeAlts (a1:as1) as2
\end{code}
--------------------------------------------------
-- Catch-all
--------------------------------------------------
--- gaw 2004
mkCase1 scrut bndr ty alts = returnSmpl (Case scrut bndr ty alts)
\end{code}
import BasicTypes ( isMarkedStrict )
import CostCentre ( currentCCS )
import Type ( TvSubstEnv, isUnLiftedType, seqType, tyConAppArgs, funArgTy,
- splitFunTy_maybe, splitFunTy, coreEqType, substTy,
- mkTyVarTys, mkTyConApp
+ splitFunTy_maybe, splitFunTy, coreEqType, substTy, mkTyVarTys
)
import VarEnv ( elemVarEnv )
import Subst ( SubstResult(..), emptySubst, substExpr,
import Maybe ( Maybe )
import Maybes ( orElse )
import Outputable
-import Util ( notNull, equalLength )
+import Util ( notNull )
\end{code}
-- because quotInt# can fail.
= simplBinder env bndr `thenSmpl` \ (env, bndr') ->
thing_inside env `thenSmpl` \ (floats, body) ->
--- gaw 2004
let body' = wrapFloats floats body in
returnSmpl (emptyFloats env, Case new_rhs bndr' (exprType body') [(DEFAULT, [], body')])
simplType env ty `thenSmpl` \ ty' ->
rebuild env (Type ty') cont
--- gaw 2004
simplExprF env (Case scrut bndr case_ty alts) cont
| not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
= -- Simplify the scrutinee with a Select continuation
rebuildCase :: SimplEnv
-> OutExpr -- Scrutinee
-> InId -- Case binder
- -> [InAlt] -- Alternatives
+ -> [InAlt] -- Alternatives (inceasing order)
-> SimplCont
-> SimplM FloatsWithExpr
import Outputable
import FastString
import Maybe ( isJust, fromMaybe )
-import Util ( sortLe )
import Bag
import List ( isPrefixOf )
\end{code}
= do { subst1 <- match_ty menv subst ty1 ty2
; subst2 <- match menv subst1 e1 e2
; let menv' = menv { me_env = rnBndr2 (me_env menv) x2 x2 }
- ; match_alts menv' subst2 (sortLe le_alt alts1) (sortLe le_alt alts2)
+ ; match_alts menv' subst2 alts1 alts2 -- Alts are both sorted
}
match menv subst (Type ty1) (Type ty2)
match_alts menv subst alts1 alts2
= Nothing
-
-le_alt (con1, _, _) (con2, _, _) = con1 <= con2
\end{code}
Matching Core types: use the matcher in TcType.
ruleCheck env (Note n e) = ruleCheck env e
ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e
ruleCheck env (Lam b e) = ruleCheck env e
--- gaw 2004
ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`
unionManyBags [ruleCheck env r | (_,_,r) <- as]
scExpr env (Lam b e) = scExpr (extendBndr env b) e `thenUs` \ (usg,e') ->
returnUs (usg, Lam b e')
--- gaw 2004
scExpr env (Case scrut b ty alts)
= sc_scrut scrut `thenUs` \ (scrut_usg, scrut') ->
mapAndUnzipUs sc_alt alts `thenUs` \ (alts_usgs, alts') ->
--- gaw 2004
returnUs (combineUsages alts_usgs `combineUsage` scrut_usg,
Case scrut' b ty alts')
where
-- More efficient to collect a group of binders together all at once
-- and we don't want to split a lambda group with dumped bindings
--- gaw 2004
specExpr subst (Case scrut case_bndr ty alts)
- = specExpr subst scrut `thenSM` \ (scrut', uds_scrut) ->
+ = specExpr subst scrut `thenSM` \ (scrut', uds_scrut) ->
mapAndCombineSM spec_alt alts `thenSM` \ (alts', uds_alts) ->
returnSM (Case scrut' case_bndr' (substTy subst ty) alts', uds_scrut `plusUDs` uds_alts)
where
-- Cases require a little more real work.
--- gaw 2004
coreToStgExpr (Case scrut bndr _ alts)
= extendVarEnvLne [(bndr, LambdaBound)] (
mapAndUnzip3Lne vars_alt alts `thenLne` \ (alts2, fvs_s, escs_s) ->
in
(deferType lam_ty, Lam var' body')
--- gaw 2004
dmdAnal sigs dmd (Case scrut case_bndr ty [alt@(DataAlt dc,bndrs,rhs)])
| let tycon = dataConTyCon dc,
isProductTyCon tycon,
(scrut_ty, scrut') = dmdAnal sigs scrut_dmd scrut
in
--- gaw 2004
(alt_ty1 `bothType` scrut_ty, Case scrut' case_bndr' ty [alt'])
--- gaw 2004
dmdAnal sigs dmd (Case scrut case_bndr ty alts)
= let
(alt_tys, alts') = mapAndUnzip (dmdAnalAlt sigs dmd) alts
(alt_ty, case_bndr') = annotateBndr (foldr1 lubType alt_tys) case_bndr
in
-- pprTrace "dmdAnal:Case" (ppr alts $$ ppr alt_tys)
--- gaw 2004
(alt_ty `bothType` scrut_ty, Case scrut' case_bndr' ty alts')
dmdAnal sigs dmd (Let (NonRec id rhs) body)
wwExpr expr `thenUs` \ new_expr ->
returnUs (mkLets intermediate_bind new_expr)
--- gaw 2004
wwExpr (Case expr binder ty alts)
= wwExpr expr `thenUs` \ new_expr ->
mapUs ww_alt alts `thenUs` \ new_alts ->
--- gaw 2004
returnUs (Case new_expr binder ty new_alts)
where
ww_alt (con, binders, rhs)
arg = mk_ww_local arg_uniq con_arg_ty1
con_app = mkConApp data_con (map Type tycon_arg_tys ++ [Var arg])
in
--- gaw 2004
returnUs (\ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)],
\ body -> workerCase body work_wild con_arg_ty1 [(DataAlt data_con, [arg], Var arg)],
con_arg_ty1)
ubx_tup_app = mkConApp ubx_tup_con (map Type con_arg_tys ++ arg_vars)
con_app = mkConApp data_con (map Type tycon_arg_tys ++ arg_vars)
in
--- gaw 2004
returnUs (\ wkr_call -> Case wkr_call wrap_wild (exprType con_app) [(DataAlt ubx_tup_con, args, con_app)],
\ body -> workerCase body work_wild ubx_tup_ty [(DataAlt data_con, args, ubx_tup_app)],
ubx_tup_ty)
-- This transform doesn't move work or allocation
-- from one cost centre to another
--- gaw 2004
workerCase (Note (SCC cc) e) arg ty alts = Note (SCC cc) (Case e arg ty alts)
--- gaw 2004
workerCase e arg ty alts = Case e arg ty alts
\end{code}
-- A data type
= Case (Var arg)
(sanitiseCaseBndr arg)
--- gaw 2004
(exprType body)
[(DataAlt boxing_con, unpk_args, body)]
--- gaw 2004
mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)]
sanitiseCaseBndr :: Id -> Id
-- e.g. data T a where { ... }
[DataCon] -- The constructors; can be empty if the user declares
-- the type to have no constructors
+ -- INVARIANT: Kept in order of increasing tag
+ -- (see the tag assignment in DataCon.mkDataCon)
Bool -- Cached: True <=> an enumeration type
| NewTyCon -- Newtypes always have exactly one constructor
nTimes,
-- sorting
- sortLe,
+ sortLe, sortWith,
-- transitive closures
transitiveClosure,
sortLe :: (a->a->Bool) -> [a] -> [a]
sortLe le = generalNaturalMergeSort le
+
+sortWith :: Ord b => (a->b) -> [a] -> [a]
+sortWith get_key xs = sortLe le xs
+ where
+ x `le` y = get_key x < get_key y
\end{code}
%************************************************************************
projects / ghc-hetmet.git / commitdiff