[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.

37 files changed, 142 insertions, 159 deletions

diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index 7dabf46148..e7084ca7f2 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 df2f323f0e..a3ea531320 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 925a51f6ac..169b86efed 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 28c913d369..3e9127689c 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 76d1bd3dff..131d8a7714 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 d3c1679e09..cc664f1b59 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 77f2156408..b07d917777 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 10ad00c6b5..1c20f5118e 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 dbcc86d153..ba592a9e4f 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 cbc28442ea..a41e62fb6c 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 30531eaf30..4db17ea00f 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 a2af48e577..576c721608 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 8491613e1d..9f19dd152f 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 931bcc9029..10fd4abb55 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 ea307ac45c..75a0a62d6d 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 7f4e83e395..63be22cd54 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 bcafd651bc..a4fb275926 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 393762fe40..cd4bdd447f 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 193f6028aa..85b0110be0 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 b4d084364b..2db56221b2 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 4fdec53451..3ab8d6eedc 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 061cd4b85d..0ca2257189 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 b14f04230c..e3b877e975 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 8df30e1416..a1a41315ef 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 5ea95a25c5..bc45befbc2 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 08f3d8406b..d0f043b3c9 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 60892770d6..960ab4504b 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 15bd6123db..0f0616e9d3 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 e09dc22c0b..095a0a5358 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 e07470be1e..eb516869b0 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 1813d7ef97..2863348904 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 9397af6c74..e351ea4a27 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 903cff200d..8928b20b7a 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 276d8da52f..f407691db9 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 b84f9c60b3..3d595394b5 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 9fad373410..7fdf2e3a29 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 6d2be048be..a23b2d748c 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}
 
 %************************************************************************