[project @ 2004-08-20 12:21:03 by simonmar]

Simplify the "impossible branch" handling, and fix a bug in the
process.  CmmSwitch encodes the possibility of having impossible
branches (the destinations are Maybe BlockId rather than just BlockId)
so we don't need to encode impossible branches as dummy blocks
containing a jump to an impossible location (currently 0).

However, PprC and PprCmm weren't set up to cope with Nothings in a
CmmSwitch, so this commit fixes that too.

3 files changed, 27 insertions, 47 deletions

diff --git a/ghc/compiler/cmm/PprC.hs b/ghc/compiler/cmm/PprC.hs
index a50d403f8e..cc70a9a08a 100644
--- a/ghc/compiler/cmm/PprC.hs
+++ b/ghc/compiler/cmm/PprC.hs
@@ -40,7 +40,7 @@ import Constants
 import CmdLineOpts	( opt_EnsureSplittableC )
 
 -- The rest
-import Data.List        ( intersperse, group )
+import Data.List        ( intersperse, groupBy )
 import Data.Bits        ( shiftR )
 import Char             ( ord, chr )
 import IO               ( Handle )
@@ -251,29 +251,26 @@ pprCondBranch expr ident
 --
 pprSwitch :: CmmExpr -> [ Maybe BlockId ] -> SDoc
 pprSwitch e maybe_ids 
-  = let ids  = [ i | Just i <- maybe_ids ]
-        pairs = zip [ 0 .. ] (concatMap markfalls (group ids))
+  = let pairs  = [ (ix, ident) | (ix,Just ident) <- zip [0..] maybe_ids ]
+	pairs2 = [ (map fst as, snd (head as)) | as <- groupBy sndEq pairs ]
     in 
         (hang (ptext SLIT("switch") <+> parens ( pprExpr e ) <+> lbrace)
-                4 (vcat ( map caseify pairs )))
+                4 (vcat ( map caseify pairs2 )))
         $$ rbrace
 
   where
-    -- fall through case
-    caseify (i,Left ident) = 
-        hsep [ ptext SLIT("case") , pprHexVal i <> colon ,
-                        ptext SLIT("/* fall through for"), 
-                        pprBlockId ident, 
-                        ptext SLIT("*/") ]
-
-    caseify (i,Right ident) = 
-        hsep [ ptext SLIT("case") , pprHexVal i <> colon ,
-                        ptext SLIT("goto") , (pprBlockId ident) <> semi ]
-
-    -- mark the bottom of a fallthough sequence of cases as `Right'
-    markfalls [a] = [Right a]
-    markfalls as  = map (\a -> Left a) (init as) ++ [Right (last as)]
+    sndEq (_,x) (_,y) = x == y
 
+    -- fall through case
+    caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix
+	where 
+	do_fallthrough ix =
+                 hsep [ ptext SLIT("case") , pprHexVal ix <> colon ,
+                        ptext SLIT("/* fall through */") ]
+
+	final_branch ix = 
+	        hsep [ ptext SLIT("case") , pprHexVal ix <> colon ,
+                       ptext SLIT("goto") , (pprBlockId ident) <> semi ]
 
 -- ---------------------------------------------------------------------
 -- Expressions.
diff --git a/ghc/compiler/cmm/PprCmm.hs b/ghc/compiler/cmm/PprCmm.hs
index fb1dec1c7c..961c6e40e1 100644
--- a/ghc/compiler/cmm/PprCmm.hs
+++ b/ghc/compiler/cmm/PprCmm.hs
@@ -219,18 +219,13 @@ genJump expr actuals =
 --
 --      switch [0 .. n] (expr) { case ... ; }
 --
--- N.B. we remove 'Nothing's from the list of branches, as they don't
--- seem to make sense currently. This may change, if they are defined in
--- some way.
---
 genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
 genSwitch expr maybe_ids 
 
-    = let ids   = [ i | Just i <- maybe_ids ]
-          pairs = groupBy snds (zip [0 .. ] ids )
+    = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
 
       in hang (hcat [ ptext SLIT("switch [0 .. ") 
-                    , int (length ids - 1)
+                    , int (length maybe_ids - 1)
                     , ptext SLIT("] ")
                     , if isTrivialCmmExpr expr
                         then pprExpr expr
@@ -242,13 +237,16 @@ genSwitch expr maybe_ids
     where
       snds a b = (snd a) == (snd b)
 
-      caseify :: [(Int,BlockId)] -> SDoc
+      caseify :: [(Int,Maybe BlockId)] -> SDoc
+      caseify ixs@((i,Nothing):_)
+        = ptext SLIT("/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
+		<> ptext SLIT(" */")
       caseify as 
         = let (is,ids) = unzip as 
           in hsep [ ptext SLIT("case")
                   , hcat (punctuate comma (map int is))
                   , ptext SLIT(": goto")
-                  , pprBlockId (head ids) <> semi ]
+                  , pprBlockId (head [ id | Just id <- ids]) <> semi ]
 
 -- --------------------------------------------------------------------------
 -- Expressions
diff --git a/ghc/compiler/codeGen/CgUtils.hs b/ghc/compiler/codeGen/CgUtils.hs
index ffd25eb908..5dbef8b438 100644
--- a/ghc/compiler/codeGen/CgUtils.hs
+++ b/ghc/compiler/codeGen/CgUtils.hs
@@ -394,16 +394,14 @@ mk_switch tag_expr [(tag,stmts)] (Just deflt) lo_tag hi_tag
 -- DENSE TAG RANGE: use a switch statment
 mk_switch tag_expr branches mb_deflt lo_tag hi_tag
   | use_switch 	-- Use a switch
-  = do	{ deflt_id <- get_deflt_id mb_deflt
-	; branch_ids <- mapM forkCgStmts (map snd branches)
+  = do	{ branch_ids <- mapM forkCgStmts (map snd branches)
 	; let 
-		tagged_blk_ids = zip (map fst branches) branch_ids
+		tagged_blk_ids = zip (map fst branches) (map Just branch_ids)
 
-		find_branch :: BlockId -> ConTagZ -> BlockId
-		find_branch deflt_id i = assocDefault deflt_id tagged_blk_ids i
+		find_branch :: ConTagZ -> Maybe BlockId
+		find_branch i = assocDefault mb_deflt tagged_blk_ids i
 
-		arms = [ Just (find_branch deflt_id (i+lo_tag))
-		       | i <- [0..n_tags-1]]
+		arms = [ find_branch (i+lo_tag) | i <- [0..n_tags-1]]
 
 	        switch_stmt = CmmSwitch (cmmOffset tag_expr (- lo_tag)) arms
 
@@ -443,19 +441,6 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag
     (lo_branches, hi_branches) = span is_lo branches
     is_lo (t,_) = t < mid_tag
 
-	-- Add a default block if the case is not exhaustive
-    get_deflt_id  (Just deflt_id) = return deflt_id
-    get_deflt_id  Nothing
- 	| exhaustive 
-	= return (pprPanic "mk_deflt_blks" (ppr tag_expr))
-	| otherwise
-	= do { stmts <- getCgStmts (stmtC jump_to_impossible)
-	     ; id <- forkCgStmts stmts
-	     ; return id }
-
-    jump_to_impossible 
-      = CmmJump (mkLblExpr mkErrorStdEntryLabel) []
-
 
 assignTemp' e
   | isTrivialCmmExpr e = return (CmmNop, e)