From 557d889d9db42c76b8b4cd07f07eb3616ff3236b Mon Sep 17 00:00:00 2001 From: simonmar Date: Fri, 20 Aug 2004 12:21:05 +0000 Subject: [PATCH] [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. --- ghc/compiler/cmm/PprC.hs | 33 +++++++++++++++------------------ ghc/compiler/cmm/PprCmm.hs | 16 +++++++--------- ghc/compiler/codeGen/CgUtils.hs | 25 +++++-------------------- 3 files changed, 27 insertions(+), 47 deletions(-) diff --git a/ghc/compiler/cmm/PprC.hs b/ghc/compiler/cmm/PprC.hs index a50d403..cc70a9a 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 fb1dec1..961c6e4 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 ffd25eb..5dbef8b 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) -- 1.7.10.4