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

1 files changed, 9 insertions, 1 deletions

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