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 )
--
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.
--
-- 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
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
-- 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
(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)