Commit d7c402a3 authored by simonpj's avatar simonpj
Browse files

[project @ 2004-12-22 12:06:13 by simonpj]

----------------------------------------
     New Core invariant: keep case alternatives in sorted order
	----------------------------------------

We now keep the alternatives of a Case in the Core language in sorted
order.  Sorted, that is,
	by constructor tag	for DataAlt
	by literal		for LitAlt

The main reason is that it makes matching and equality testing more robust.
But in fact some lines of code vanished from SimplUtils.mkAlts.


WARNING: no change to interface file formats, but you'll need to recompile
your libraries so that they generate interface files that respect the
invariant.
parent 1f3a9ff8
......@@ -64,8 +64,7 @@ import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag )
import ForeignCall ( ForeignCall )
import DataCon ( DataCon, DataConIds(..), dataConTyVars,
dataConFieldLabels, dataConRepArity,
dataConRepArgTys, dataConRepType,
dataConStupidTheta, dataConOrigArgTys,
dataConRepArgTys, dataConRepType, dataConStupidTheta,
dataConSig, dataConStrictMarks, dataConExStricts,
splitProductType, isVanillaDataCon
)
......@@ -305,15 +304,15 @@ mkDataConIds wrap_name wkr_name data_con
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
......@@ -454,7 +453,7 @@ mkRecordSelId tycon field_label field_ty
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 = []
......
......@@ -382,7 +382,8 @@ checkKinds tyvar arg_ty
\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
......@@ -393,11 +394,16 @@ checkCaseAlts e ty []
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
......@@ -683,6 +689,8 @@ mkScrutMsg var scrut_ty
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
......
......@@ -407,13 +407,11 @@ corePrepExprFloat env expr@(Lam _ _)
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)
......@@ -587,7 +585,6 @@ mkBinds (Floats _ binds) body
| 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
......
......@@ -15,7 +15,7 @@ module CoreSyn (
mkConApp,
varToCoreExpr,
isTyVar, isId,
isTyVar, isId, cmpAltCon, cmpAlt, ltAlt,
bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
collectArgs,
......@@ -54,7 +54,7 @@ import CostCentre ( CostCentre, noCostCentre )
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
......@@ -78,13 +78,17 @@ data Expr b -- "b" for the type of binders,
| 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
......@@ -110,6 +114,7 @@ data AltCon = DataAlt DataCon
| DEFAULT
deriving (Eq, Ord)
data Bind b = NonRec b (Expr b)
| Rec [(b, (Expr b))]
......@@ -345,6 +350,26 @@ instance Outputable AltCon where
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}
......
......@@ -71,10 +71,8 @@ tidyExpr env (Let b e)
= 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)
......
......@@ -218,7 +218,6 @@ sizeExpr bOMB_OUT_SIZE top_args expr
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
=
......
......@@ -90,7 +90,6 @@ exprType :: CoreExpr -> Type
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
......@@ -247,7 +246,6 @@ bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
-- 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
......@@ -268,11 +266,10 @@ mkAltExpr (LitAlt lit) [] []
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}
......@@ -295,14 +292,15 @@ findAlt con alts
= 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}
......@@ -414,7 +412,6 @@ exprIsCheap (Var _) = True
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
......@@ -546,12 +543,12 @@ exprIsBottom e = go 0 e
-- 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
......@@ -818,7 +815,6 @@ arityType (App f a) = case arityType f of
-- ===>
-- 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
......@@ -1087,7 +1083,6 @@ exprSize (Lit lit) = lit `seq` 1
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
......@@ -1131,7 +1126,6 @@ hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
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
......
......@@ -153,7 +153,6 @@ ppr_expr add_par expr@(App fun arg)
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,
......@@ -168,7 +167,6 @@ ppr_expr add_par (Case expr var ty [(con,args,rhs)])
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,
......
......@@ -125,7 +125,6 @@ pappexp e as = fsep (paexp e : map pa as)
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)))))
......
......@@ -252,11 +252,11 @@ cprAnalExpr rho (Type t)
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))
......
......@@ -139,7 +139,6 @@ coreCaseTuple uniqs scrut_var vars body
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}
......
......@@ -169,12 +169,11 @@ unboxArg arg
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)])
......@@ -186,7 +185,6 @@ unboxArg arg
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)]
)
......@@ -203,7 +201,6 @@ unboxArg arg
= 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)]
)
......@@ -309,7 +306,6 @@ boxResult arg_ids augment mbTopCon result_ty
Lam state_id $
Case (App the_call (Var state_id))
(mkWildId ccall_res_ty)
-- gaw 2004
(coreAltType the_alt)
[the_alt]
]
......@@ -327,7 +323,6 @@ boxResult arg_ids augment mbTopCon result_ty
let
wrap = \ the_call -> Case (App the_call (Var realWorldPrimId))
(mkWildId ccall_res_ty)
-- gaw 2004
(coreAltType the_alt)
[the_alt]
in
......@@ -397,7 +392,6 @@ resultWrapper result_ty
| 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)])
......
......@@ -212,10 +212,10 @@ deBindComp pat core_list1 quals core_list2
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}
......@@ -250,11 +250,10 @@ mkZipBind elt_tys
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
......
......@@ -52,9 +52,9 @@ import Var ( Var )
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,
......@@ -70,8 +70,8 @@ import PrelNames ( unpackCStringName, unpackCStringUtf8Name,
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}
......@@ -302,9 +302,10 @@ mkCoPrimCaseMatchResult var ty match_alts
= 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)
......@@ -343,7 +344,9 @@ mkCoAlgCaseMatchResult var ty match_alts
= 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)
......@@ -401,8 +404,8 @@ mkCoAlgCaseMatchResult var ty match_alts
--
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
......@@ -772,7 +775,6 @@ mkSmallTupleCase
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}
......@@ -824,7 +826,6 @@ mkCoreSel [var] should_be_the_same_var scrut_var scrut
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}
......
......@@ -25,7 +25,7 @@ import PrelNames ( ratioTyConKey )
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(..) )
......
......@@ -642,7 +642,6 @@ tcIfaceExpr (IfaceApp fun arg)
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 ->
......
......@@ -644,14 +644,13 @@ cafRefs p (Var id)
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
......
......@@ -285,7 +285,6 @@ vectorise (Let bind body) =
(vbody, vbodyTy) <- vectorise body
return ((Let vbind vbody), vbodyTy)
-- gaw 2004
vectorise (Case expr b ty alts) =
do
(vexpr, vexprTy) <- vectorise expr
......
......@@ -163,7 +163,6 @@ substIdEnv env (Let (Rec bnds) 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
......
......@@ -75,7 +75,6 @@ arrUsage (Let (Rec bnds) expr) =
t2 = arrUsage expr
in if isArrayUsage t1 then Array else t2
-- gaw 2004
arrUsage (Case expr b _ alts) =
let
t1 = arrUsage expr
......
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