diff options
| -rw-r--r-- | ghc/compiler/cmm/PprC.hs | 33 | ||||
| -rw-r--r-- | ghc/compiler/cmm/PprCmm.hs | 16 | ||||
| -rw-r--r-- | 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 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) |