From: simonpj Date: Wed, 22 Dec 2004 12:07:41 +0000 (+0000) Subject: [project @ 2004-12-22 12:06:13 by simonpj] X-Git-Tag: Initial_conversion_from_CVS_complete~1318 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=d7c402a3cedbe49345a34f2e58a3f3050638dcb4;p=ghc-hetmet.git [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. --- diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 7dabf46..e7084ca 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -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 = [] diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index df2f323..a3ea531 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -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 diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index 925a51f..169b86e 100644 --- a/ghc/compiler/coreSyn/CorePrep.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -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 diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 28c913d..3e91276 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -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} diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index 76d1bd3..131d8a7 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -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) diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index d3c1679..cc664f1 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -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 = diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 77f2156..b07d917 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -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 diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 10ad00c..1c20f51 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -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, diff --git a/ghc/compiler/coreSyn/PprExternalCore.lhs b/ghc/compiler/coreSyn/PprExternalCore.lhs index dbcc86d..ba592a9 100644 --- a/ghc/compiler/coreSyn/PprExternalCore.lhs +++ b/ghc/compiler/coreSyn/PprExternalCore.lhs @@ -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))))) diff --git a/ghc/compiler/cprAnalysis/CprAnalyse.lhs b/ghc/compiler/cprAnalysis/CprAnalyse.lhs index cbc2844..a41e62f 100644 --- a/ghc/compiler/cprAnalysis/CprAnalyse.lhs +++ b/ghc/compiler/cprAnalysis/CprAnalyse.lhs @@ -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)) diff --git a/ghc/compiler/deSugar/DsArrows.lhs b/ghc/compiler/deSugar/DsArrows.lhs index 30531ea..4db17ea 100644 --- a/ghc/compiler/deSugar/DsArrows.lhs +++ b/ghc/compiler/deSugar/DsArrows.lhs @@ -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} diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index a2af48e..576c721 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -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)]) diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 8491613..9f19dd1 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -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 diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 931bcc9..10fd4ab 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -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} diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index ea307ac..75a0a62 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -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(..) ) diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index 7f4e83e..63be22c 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -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 -> diff --git a/ghc/compiler/main/TidyPgm.lhs b/ghc/compiler/main/TidyPgm.lhs index bcafd65..a4fb275 100644 --- a/ghc/compiler/main/TidyPgm.lhs +++ b/ghc/compiler/main/TidyPgm.lhs @@ -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 diff --git a/ghc/compiler/ndpFlatten/Flattening.hs b/ghc/compiler/ndpFlatten/Flattening.hs index 393762f..cd4bdd4 100644 --- a/ghc/compiler/ndpFlatten/Flattening.hs +++ b/ghc/compiler/ndpFlatten/Flattening.hs @@ -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 diff --git a/ghc/compiler/ndpFlatten/NDPCoreUtils.hs b/ghc/compiler/ndpFlatten/NDPCoreUtils.hs index 193f602..85b0110 100644 --- a/ghc/compiler/ndpFlatten/NDPCoreUtils.hs +++ b/ghc/compiler/ndpFlatten/NDPCoreUtils.hs @@ -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 diff --git a/ghc/compiler/ndpFlatten/PArrAnal.hs b/ghc/compiler/ndpFlatten/PArrAnal.hs index b4d0843..2db5622 100644 --- a/ghc/compiler/ndpFlatten/PArrAnal.hs +++ b/ghc/compiler/ndpFlatten/PArrAnal.hs @@ -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 diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs index 4fdec53..3ab8d6e 100644 --- a/ghc/compiler/prelude/PrelRules.lhs +++ b/ghc/compiler/prelude/PrelRules.lhs @@ -289,7 +289,6 @@ litEq is_eq [expr, Lit lit] = do_lit_eq is_eq lit 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)]) diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index 061cd4b..0ca2257 100644 --- a/ghc/compiler/simplCore/FloatIn.lhs +++ b/ghc/compiler/simplCore/FloatIn.lhs @@ -323,7 +323,6 @@ bindings are: (a)~inside the scrutinee, (b)~inside one of the 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 $ diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs index b14f042..e3b877e 100644 --- a/ghc/compiler/simplCore/FloatOut.lhs +++ b/ghc/compiler/simplCore/FloatOut.lhs @@ -330,7 +330,6 @@ floatExpr lvl (Let bind body) 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') -> diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs index 8df30e1..a1a4131 100644 --- a/ghc/compiler/simplCore/LiberateCase.lhs +++ b/ghc/compiler/simplCore/LiberateCase.lhs @@ -220,7 +220,6 @@ libCase env (Let bind body) 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 diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 5ea95a2..bc45bef 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -648,10 +648,9 @@ occAnal env expr@(Lam _ _) 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 @@ -659,7 +658,6 @@ occAnal env (Case scrut bndr ty alts) (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 diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index 08f3d84..d0f043b 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -332,7 +332,6 @@ lvlExpr ctxt_lvl env (_, AnnLet bind body) 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 diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 6089277..960ab45 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -834,8 +834,8 @@ of the inner case y, which give us nowhere to go! \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 @@ -861,7 +861,9 @@ 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), @@ -929,10 +931,13 @@ mk_tv_bndrs missing_con inst_tys 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} @@ -998,7 +1003,7 @@ and similarly in cascade for all the join points! -------------------------------------------------- -- 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_` @@ -1013,56 +1018,53 @@ mkAlts scrut case_bndr alts@((con1,bndrs1,rhs1) : con_alts) -- 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} @@ -1285,7 +1287,6 @@ mkCase1 scrut case_bndr ty alts -- Identity case -------------------------------------------------- -- Catch-all -------------------------------------------------- --- gaw 2004 mkCase1 scrut bndr ty alts = returnSmpl (Case scrut bndr ty alts) \end{code} diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 15bd612..0f0616e 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -49,8 +49,7 @@ import Rules ( lookupRule ) 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, @@ -64,7 +63,7 @@ import OrdList import Maybe ( Maybe ) import Maybes ( orElse ) import Outputable -import Util ( notNull, equalLength ) +import Util ( notNull ) \end{code} @@ -350,7 +349,6 @@ simplNonRecX env bndr new_rhs thing_inside -- 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')]) @@ -733,7 +731,6 @@ simplExprF env (Type ty) cont 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 @@ -1290,7 +1287,7 @@ Blob of helper functions for the "case-of-something-else" situation. rebuildCase :: SimplEnv -> OutExpr -- Scrutinee -> InId -- Case binder - -> [InAlt] -- Alternatives + -> [InAlt] -- Alternatives (inceasing order) -> SimplCont -> SimplM FloatsWithExpr diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index e09dc22..095a0a5 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -32,7 +32,6 @@ import BasicTypes ( Activation, CompilerPhase, isActive ) import Outputable import FastString import Maybe ( isJust, fromMaybe ) -import Util ( sortLe ) import Bag import List ( isPrefixOf ) \end{code} @@ -263,7 +262,7 @@ match menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) = 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) @@ -311,8 +310,6 @@ match_alts menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) match_alts menv subst alts1 alts2 = Nothing - -le_alt (con1, _, _) (con2, _, _) = con1 <= con2 \end{code} Matching Core types: use the matcher in TcType. @@ -450,7 +447,6 @@ ruleCheck env (App f a) = ruleCheckApp env (App f a) [] 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] diff --git a/ghc/compiler/specialise/SpecConstr.lhs b/ghc/compiler/specialise/SpecConstr.lhs index e07470b..eb51686 100644 --- a/ghc/compiler/specialise/SpecConstr.lhs +++ b/ghc/compiler/specialise/SpecConstr.lhs @@ -335,11 +335,9 @@ scExpr env (Note n e) = scExpr env e `thenUs` \ (usg,e') -> 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 diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 1813d7e..2863348 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -659,9 +659,8 @@ specExpr subst e@(Lam _ _) -- 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 diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 9397af6..e351ea4 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -333,7 +333,6 @@ coreToStgExpr (Note other_note expr) -- 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) -> diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs index 903cff2..8928b20 100644 --- a/ghc/compiler/stranal/DmdAnal.lhs +++ b/ghc/compiler/stranal/DmdAnal.lhs @@ -204,7 +204,6 @@ dmdAnal sigs dmd (Lam var body) 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, @@ -251,10 +250,8 @@ dmdAnal sigs dmd (Case scrut case_bndr ty [alt@(DataAlt dc,bndrs,rhs)]) (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 @@ -262,7 +259,6 @@ dmdAnal sigs dmd (Case scrut case_bndr ty 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) diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index 276d8da..f407691 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -158,11 +158,9 @@ wwExpr (Let bind expr) 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) diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index b84f9c6..3d59539 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -429,7 +429,6 @@ mkWWcpr body_ty RetCPR 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) @@ -446,7 +445,6 @@ mkWWcpr body_ty RetCPR 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) @@ -469,9 +467,7 @@ mkWWcpr body_ty other -- No CPR info -- 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} @@ -498,11 +494,9 @@ mk_unpk_case arg unpk_args boxing_con boxing_tycon body -- 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 diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 9fad373..7fdf2e3 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -177,6 +177,8 @@ data AlgTyConRhs -- 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 diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index 6d2be04..a23b2d7 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -21,7 +21,7 @@ module Util ( nTimes, -- sorting - sortLe, + sortLe, sortWith, -- transitive closures transitiveClosure, @@ -426,6 +426,11 @@ mergeSortLe le = generalMergeSort le 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} %************************************************************************