Commit de1160be authored by Joachim Breitner's avatar Joachim Breitner

Refactor the story around switches (#10137)

This re-implements the code generation for case expressions at the Stg →
Cmm level, both for data type cases as well as for integral literal
cases. (Cases on float are still treated as before).

The goal is to allow for fancier strategies in implementing them, for a
cleaner separation of the strategy from the gritty details of Cmm, and
to run this later than the Common Block Optimization, allowing for one
way to attack #10124. The new module CmmSwitch contains a number of
notes explaining this changes. For example, it creates larger
consecutive jump tables than the previous code, if possible.

nofib shows little significant overall improvement of runtime. The
rather large wobbling comes from changes in the code block order
(see #8082, not much we can do about it). But the decrease in code size
alone makes this worthwhile.

```
        Program           Size    Allocs   Runtime   Elapsed  TotalMem
            Min          -1.8%      0.0%     -6.1%     -6.1%     -2.9%
            Max          -0.7%     +0.0%     +5.6%     +5.7%     +7.8%
 Geometric Mean          -1.4%     -0.0%     -0.3%     -0.3%     +0.0%
```

Compilation time increases slightly:
```
        -1 s.d.                -----            -2.0%
        +1 s.d.                -----            +2.5%
        Average                -----            +0.3%
```

The test case T783 regresses a lot, but it is the only one exhibiting
any regression. The cause is the changed order of branches in an
if-then-else tree, which makes the hoople data flow analysis traverse
the blocks in a suboptimal order. Reverting that gets rid of this
regression, but has a consistent, if only very small (+0.2%), negative
effect on runtime. So I conclude that this test is an extreme outlier
and no reason to change the code.

Differential Revision: https://phabricator.haskell.org/D720
parent e24f6381
......@@ -30,7 +30,7 @@ module Literal
, inIntRange, inWordRange, tARGET_MAX_INT, inCharRange
, isZeroLit
, litFitsInChar
, onlyWithinBounds
, litValue
-- ** Coercions
, word2IntLit, int2WordLit
......@@ -271,6 +271,17 @@ isZeroLit (MachFloat 0) = True
isZeroLit (MachDouble 0) = True
isZeroLit _ = False
-- | Returns the 'Integer' contained in the 'Literal', for when that makes
-- sense, i.e. for 'Char', 'Int', 'Word' and 'LitInteger'.
litValue :: Literal -> Integer
litValue (MachChar c) = toInteger $ ord c
litValue (MachInt i) = i
litValue (MachInt64 i) = i
litValue (MachWord i) = i
litValue (MachWord64 i) = i
litValue (LitInteger i _) = i
litValue l = pprPanic "litValue" (ppr l)
{-
Coercions
~~~~~~~~~
......@@ -360,16 +371,6 @@ litIsLifted :: Literal -> Bool
litIsLifted (LitInteger {}) = True
litIsLifted _ = False
-- | x `onlyWithinBounds` (l,h) is true if l <= y < h ==> x = y
onlyWithinBounds :: Literal -> (Literal, Literal) -> Bool
onlyWithinBounds (MachChar x) (MachChar l, MachChar h) = x == l && succ x == h
onlyWithinBounds (MachInt x) (MachInt l, MachInt h) = x == l && succ x == h
onlyWithinBounds (MachWord x) (MachWord l, MachWord h) = x == l && succ x == h
onlyWithinBounds (MachInt64 x) (MachInt64 l, MachInt64 h) = x == l && succ x == h
onlyWithinBounds (MachWord64 x) (MachWord64 l, MachWord64 h) = x == l && succ x == h
onlyWithinBounds _ _ = False
{-
Types
~~~~~
......
......@@ -8,6 +8,7 @@ where
import BlockId
import Cmm
import CmmUtils
import CmmSwitch (eqSwitchTargetWith)
import CmmContFlowOpt
import Prelude hiding (iterate, succ, unzip, zip)
......@@ -203,13 +204,10 @@ eqLastWith eqBid (CmmCondBranch c1 t1 f1) (CmmCondBranch c2 t2 f2) =
c1 == c2 && eqBid t1 t2 && eqBid f1 f2
eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) =
t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2
eqLastWith eqBid (CmmSwitch e1 bs1) (CmmSwitch e2 bs2) =
e1 == e2 && eqListWith (eqMaybeWith eqBid) bs1 bs2
eqLastWith eqBid (CmmSwitch e1 ids1) (CmmSwitch e2 ids2) =
e1 == e2 && eqSwitchTargetWith eqBid ids1 ids2
eqLastWith _ _ _ = False
eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
eqListWith eltEq es es' = all (uncurry eltEq) (List.zip es es')
eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
eqMaybeWith _ Nothing Nothing = True
......
......@@ -12,6 +12,7 @@ import Hoopl
import BlockId
import Cmm
import CmmUtils
import CmmSwitch (mapSwitchTargets)
import Maybes
import Panic
......@@ -355,7 +356,7 @@ replaceLabels env g
txnode :: CmmNode e x -> CmmNode e x
txnode (CmmBranch bid) = CmmBranch (lookup bid)
txnode (CmmCondBranch p t f) = mkCmmCondBranch (exp p) (lookup t) (lookup f)
txnode (CmmSwitch e arms) = CmmSwitch (exp e) (map (liftM lookup) arms)
txnode (CmmSwitch e ids) = CmmSwitch (exp e) (mapSwitchTargets lookup ids)
txnode (CmmCall t k rg a res r) = CmmCall (exp t) (liftM lookup k) rg a res r
txnode fc@CmmForeignCall{} = fc{ args = map exp (args fc)
, succ = lookup (succ fc) }
......
{-# LANGUAGE GADTs #-}
module CmmImplementSwitchPlans
( cmmImplementSwitchPlans
)
where
import Hoopl
import BlockId
import Cmm
import CmmUtils
import CmmSwitch
import UniqSupply
import DynFlags
--
-- This module replaces Switch statements as generated by the Stg -> Cmm
-- transformation, which might be huge and sparse and hence unsuitable for
-- assembly code, by proper constructs (if-then-else trees, dense jump tables).
--
-- The actual, abstract strategy is determined by createSwitchPlan in
-- CmmSwitch and returned as a SwitchPlan; here is just the implementation in
-- terms of Cmm code. See Note [Cmm Switches, the general plan] in CmmSwitch.
--
-- This division into different modules is both to clearly separte concerns,
-- but also because createSwitchPlan needs access to the constructors of
-- SwitchTargets, a data type exported abstractly by CmmSwitch.
--
-- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for
-- code generation.
cmmImplementSwitchPlans :: DynFlags -> CmmGraph -> UniqSM CmmGraph
cmmImplementSwitchPlans dflags g
| targetSupportsSwitch (hscTarget dflags) = return g
| otherwise = do
blocks' <- concat `fmap` mapM (visitSwitches dflags) (toBlockList g)
return $ ofBlockList (g_entry g) blocks'
visitSwitches :: DynFlags -> CmmBlock -> UniqSM [CmmBlock]
visitSwitches dflags block
| (entry@(CmmEntry _ scope), middle, CmmSwitch expr ids) <- blockSplit block
= do
let plan = createSwitchPlan ids
(newTail, newBlocks) <- implementSwitchPlan dflags scope expr plan
let block' = entry `blockJoinHead` middle `blockAppend` newTail
return $ block' : newBlocks
| otherwise
= return [block]
-- Implementing a switch plan (returning a tail block)
implementSwitchPlan :: DynFlags -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock])
implementSwitchPlan dflags scope expr = go
where
go (Unconditionally l)
= return (emptyBlock `blockJoinTail` CmmBranch l, [])
go (JumpTable ids)
= return (emptyBlock `blockJoinTail` CmmSwitch expr ids, [])
go (IfLT signed i ids1 ids2)
= do
(bid1, newBlocks1) <- go' ids1
(bid2, newBlocks2) <- go' ids2
let lt | signed = cmmSLtWord
| otherwise = cmmULtWord
scrut = lt dflags expr $ CmmLit $ mkWordCLit dflags i
lastNode = CmmCondBranch scrut bid1 bid2
lastBlock = emptyBlock `blockJoinTail` lastNode
return (lastBlock, newBlocks1++newBlocks2)
go (IfEqual i l ids2)
= do
(bid2, newBlocks2) <- go' ids2
let scrut = cmmNeWord dflags expr $ CmmLit $ mkWordCLit dflags i
lastNode = CmmCondBranch scrut bid2 l
lastBlock = emptyBlock `blockJoinTail` lastNode
return (lastBlock, newBlocks2)
-- Same but returning a label to branch to
go' (Unconditionally l)
= return (l, [])
go' p
= do
bid <- mkBlockId `fmap` getUniqueM
(last, newBlocks) <- go p
let block = CmmEntry bid scope `blockJoinHead` last
return (bid, block: newBlocks)
......@@ -14,13 +14,13 @@ import Hoopl
import Cmm
import CmmUtils
import CmmLive
import CmmSwitch (switchTargetsToList)
import PprCmm ()
import BlockId
import FastString
import Outputable
import DynFlags
import Data.Maybe
import Control.Monad (liftM, ap)
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative (Applicative(..))
......@@ -171,9 +171,9 @@ lintCmmLast labels node = case node of
_ <- lintCmmExpr e
checkCond dflags e
CmmSwitch e branches -> do
CmmSwitch e ids -> do
dflags <- getDynFlags
mapM_ checkTarget $ catMaybes branches
mapM_ checkTarget $ switchTargetsToList ids
erep <- lintCmmExpr e
if (erep `cmmEqType_ignoring_ptrhood` bWord dflags)
then return ()
......
......@@ -23,6 +23,7 @@ module CmmNode (
import CodeGen.Platform
import CmmExpr
import CmmSwitch
import DynFlags
import FastString
import ForeignCall
......@@ -89,11 +90,10 @@ data CmmNode e x where
cml_true, cml_false :: ULabel
} -> CmmNode O C
CmmSwitch :: CmmExpr -> [Maybe Label] -> CmmNode O C -- Table branch
-- The scrutinee is zero-based;
-- zero -> first block
-- one -> second block etc
-- Undefined outside range, and when there's a Nothing
CmmSwitch
:: CmmExpr -- Scrutinee, of some integral type
-> SwitchTargets -- Cases. See [Note SwitchTargets]
-> CmmNode O C
CmmCall :: { -- A native call or tail call
cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
......@@ -228,7 +228,7 @@ instance NonLocal CmmNode where
successors (CmmBranch l) = [l]
successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint
successors (CmmSwitch _ ls) = catMaybes ls
successors (CmmSwitch _ ids) = switchTargetsToList ids
successors (CmmCall {cml_cont=l}) = maybeToList l
successors (CmmForeignCall {succ=l}) = [l]
......@@ -464,7 +464,7 @@ mapExp f (CmmStore addr e) = CmmStore (f addr) (f e)
mapExp f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
mapExp _ l@(CmmBranch _) = l
mapExp f (CmmCondBranch e ti fi) = CmmCondBranch (f e) ti fi
mapExp f (CmmSwitch e tbl) = CmmSwitch (f e) tbl
mapExp f (CmmSwitch e ids) = CmmSwitch (f e) ids
mapExp f n@CmmCall {cml_target=tgt} = n{cml_target = f tgt}
mapExp f (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ ret_args updfr intrbl
......@@ -560,7 +560,7 @@ foldExpDeep f = foldExp (wrapRecExpf f)
mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C
mapSuccessors f (CmmBranch bid) = CmmBranch (f bid)
mapSuccessors f (CmmCondBranch p y n) = CmmCondBranch p (f y) (f n)
mapSuccessors f (CmmSwitch e arms) = CmmSwitch e (map (fmap f) arms)
mapSuccessors f (CmmSwitch e ids) = CmmSwitch e (mapSwitchTargets f ids)
mapSuccessors _ n = n
-- -----------------------------------------------------------------------------
......
......@@ -226,6 +226,7 @@ import CmmOpt
import MkGraph
import Cmm
import CmmUtils
import CmmSwitch ( mkSwitchTargets )
import CmmInfo
import BlockId
import CmmLex
......@@ -258,6 +259,7 @@ import Data.Array
import Data.Char ( ord )
import System.Exit
import Data.Maybe
import qualified Data.Map as M
#include "HsVersions.h"
}
......@@ -676,24 +678,24 @@ globals :: { [GlobalReg] }
: GLOBALREG { [$1] }
| GLOBALREG ',' globals { $1 : $3 }
maybe_range :: { Maybe (Int,Int) }
: '[' INT '..' INT ']' { Just (fromIntegral $2, fromIntegral $4) }
maybe_range :: { Maybe (Integer,Integer) }
: '[' INT '..' INT ']' { Just ($2, $4) }
| {- empty -} { Nothing }
arms :: { [CmmParse ([Int],Either BlockId (CmmParse ()))] }
arms :: { [CmmParse ([Integer],Either BlockId (CmmParse ()))] }
: {- empty -} { [] }
| arm arms { $1 : $2 }
arm :: { CmmParse ([Int],Either BlockId (CmmParse ())) }
arm :: { CmmParse ([Integer],Either BlockId (CmmParse ())) }
: 'case' ints ':' arm_body { do b <- $4; return ($2, b) }
arm_body :: { CmmParse (Either BlockId (CmmParse ())) }
: '{' body '}' { return (Right (withSourceNote $1 $3 $2)) }
| 'goto' NAME ';' { do l <- lookupLabel $2; return (Left l) }
ints :: { [Int] }
: INT { [ fromIntegral $1 ] }
| INT ',' ints { fromIntegral $1 : $3 }
ints :: { [Integer] }
: INT { [ $1 ] }
| INT ',' ints { $1 : $3 }
default :: { Maybe (CmmParse ()) }
: 'default' ':' '{' body '}' { Just (withSourceNote $3 $5 $4) }
......@@ -1307,7 +1309,9 @@ withSourceNote a b parse = do
-- optional range on the switch (eg. switch [0..7] {...}), or by
-- the minimum/maximum values from the branches.
doSwitch :: Maybe (Int,Int) -> CmmParse CmmExpr -> [([Int],Either BlockId (CmmParse ()))]
doSwitch :: Maybe (Integer,Integer)
-> CmmParse CmmExpr
-> [([Integer],Either BlockId (CmmParse ()))]
-> Maybe (CmmParse ()) -> CmmParse ()
doSwitch mb_range scrut arms deflt
= do
......@@ -1319,22 +1323,16 @@ doSwitch mb_range scrut arms deflt
-- Compile each case branch
table_entries <- mapM emitArm arms
let table = M.fromList (concat table_entries)
-- Construct the table
let
all_entries = concat table_entries
ixs = map fst all_entries
(min,max)
| Just (l,u) <- mb_range = (l,u)
| otherwise = (minimum ixs, maximum ixs)
dflags <- getDynFlags
let range = fromMaybe (0, tARGET_MAX_WORD dflags) mb_range
entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max)
all_entries)
expr <- scrut
-- ToDo: check for out of range and jump to default if necessary
emit (mkSwitch expr entries)
emit $ mkSwitch expr (mkSwitchTargets False range dflt_entry table)
where
emitArm :: ([Int],Either BlockId (CmmParse ())) -> CmmParse [(Int,BlockId)]
emitArm :: ([Integer],Either BlockId (CmmParse ())) -> CmmParse [(Integer,BlockId)]
emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
emitArm (ints,Right code) = do
blockid <- forkLabelledCode code
......
......@@ -11,6 +11,7 @@ import Cmm
import CmmLint
import CmmBuildInfoTables
import CmmCommonBlockElim
import CmmImplementSwitchPlans
import CmmProcPoint
import CmmContFlowOpt
import CmmLayoutStack
......@@ -71,6 +72,10 @@ cpsTop hsc_env proc =
-- Any work storing block Labels must be performed _after_
-- elimCommonBlocks
g <- {-# SCC "createSwitchPlans" #-}
runUniqSM $ cmmImplementSwitchPlans dflags g
dump Opt_D_dump_cmm_switch "Post switch plan" g
----------- Proc points -------------------------------------------------
let call_pps = {-# SCC "callProcPoints" #-} callProcPoints g
proc_points <-
......
......@@ -18,6 +18,7 @@ import PprCmm ()
import CmmUtils
import CmmInfo
import CmmLive (cmmGlobalLiveness)
import CmmSwitch
import Data.List (sortBy)
import Maybes
import Control.Monad
......@@ -295,7 +296,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
case lastNode block of
CmmBranch id -> add_if_pp id rst
CmmCondBranch _ ti fi -> add_if_pp ti (add_if_pp fi rst)
CmmSwitch _ tbl -> foldr add_if_pp rst (catMaybes tbl)
CmmSwitch _ ids -> foldr add_if_pp rst $ switchTargetsToList ids
_ -> rst
-- when jumping to a PP that has an info table, if
......@@ -382,7 +383,7 @@ replaceBranches env cmmg
last :: CmmNode O C -> CmmNode O C
last (CmmBranch id) = CmmBranch (lookup id)
last (CmmCondBranch e ti fi) = CmmCondBranch e (lookup ti) (lookup fi)
last (CmmSwitch e tbl) = CmmSwitch e (map (fmap lookup) tbl)
last (CmmSwitch e ids) = CmmSwitch e (mapSwitchTargets lookup ids)
last l@(CmmCall {}) = l { cml_cont = Nothing }
-- NB. remove the continuation of a CmmCall, since this
-- label will now be in a different CmmProc. Not only
......
This diff is collapsed.
......@@ -28,9 +28,11 @@ module CmmUtils(
cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW,
cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW,
cmmNegate,
cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord,
cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord,
cmmUShrWord, cmmAddWord, cmmMulWord, cmmQuotWord,
cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
cmmSLtWord,
cmmNeWord, cmmEqWord,
cmmOrWord, cmmAndWord,
cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord,
cmmToWord,
isTrivialCmmExpr, hasNoGlobalRegs,
......@@ -304,9 +306,11 @@ cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr
cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty
-----------------------
cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord,
cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord,
cmmUShrWord, cmmAddWord, cmmMulWord, cmmQuotWord
cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
cmmSLtWord,
cmmNeWord, cmmEqWord,
cmmOrWord, cmmAndWord,
cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord
:: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmOrWord dflags e1 e2 = CmmMachOp (mo_wordOr dflags) [e1, e2]
cmmAndWord dflags e1 e2 = CmmMachOp (mo_wordAnd dflags) [e1, e2]
......@@ -316,6 +320,7 @@ cmmULtWord dflags e1 e2 = CmmMachOp (mo_wordULt dflags) [e1, e2]
cmmUGeWord dflags e1 e2 = CmmMachOp (mo_wordUGe dflags) [e1, e2]
cmmUGtWord dflags e1 e2 = CmmMachOp (mo_wordUGt dflags) [e1, e2]
--cmmShlWord dflags e1 e2 = CmmMachOp (mo_wordShl dflags) [e1, e2]
cmmSLtWord dflags e1 e2 = CmmMachOp (mo_wordSLt dflags) [e1, e2]
cmmUShrWord dflags e1 e2 = CmmMachOp (mo_wordUShr dflags) [e1, e2]
cmmAddWord dflags e1 e2 = CmmMachOp (mo_wordAdd dflags) [e1, e2]
cmmSubWord dflags e1 e2 = CmmMachOp (mo_wordSub dflags) [e1, e2]
......
......@@ -22,6 +22,7 @@ where
import BlockId
import Cmm
import CmmCallConv
import CmmSwitch (SwitchTargets)
import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..))
import DynFlags
......@@ -223,7 +224,7 @@ mkJumpExtra dflags conv e actuals updfr_off extra_stack =
mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
mkCbranch pred ifso ifnot = mkLast (CmmCondBranch pred ifso ifnot)
mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
mkSwitch :: CmmExpr -> SwitchTargets -> CmmAGraph
mkSwitch e tbl = mkLast $ CmmSwitch e tbl
mkReturn :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
......
......@@ -33,6 +33,7 @@ import Cmm hiding (pprBBlock)
import PprCmm ()
import Hoopl
import CmmUtils
import CmmSwitch
-- Utils
import CPrim
......@@ -299,21 +300,12 @@ pprCondBranch expr yes no
--
-- we find the fall-through cases
--
-- N.B. we remove Nothing's from the list of branches, as they are
-- 'undefined'. However, they may be defined one day, so we better
-- document this behaviour.
--
pprSwitch :: DynFlags -> CmmExpr -> [ Maybe BlockId ] -> SDoc
pprSwitch dflags e maybe_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 pairs2 )))
$$ rbrace
pprSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> SDoc
pprSwitch dflags e ids
= (hang (ptext (sLit "switch") <+> parens ( pprExpr e ) <+> lbrace)
4 (vcat ( map caseify pairs ) $$ def)) $$ rbrace
where
sndEq (_,x) (_,y) = x == y
(pairs, mbdef) = switchTargetsFallThrough ids
-- fall through case
caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix
......@@ -326,7 +318,10 @@ pprSwitch dflags e maybe_ids
hsep [ ptext (sLit "case") , pprHexVal ix (wordWidth dflags) <> colon ,
ptext (sLit "goto") , (pprBlockId ident) <> semi ]
caseify (_ , _ ) = panic "pprSwtich: swtich with no cases!"
caseify (_ , _ ) = panic "pprSwitch: switch with no cases!"
def | Just l <- mbdef = ptext (sLit "default: goto") <+> pprBlockId l <> semi
| otherwise = empty
-- ---------------------------------------------------------------------
-- Expressions.
......
......@@ -43,6 +43,7 @@ import BlockId ()
import CLabel
import Cmm
import CmmUtils
import CmmSwitch
import DynFlags
import FastString
import Outputable
......@@ -228,25 +229,31 @@ pprNode node = pp_node <+> pp_debug
, ppr f <> semi
]
CmmSwitch expr maybe_ids ->
hang (hcat [ ptext (sLit "switch [0 .. ")
, int (length maybe_ids - 1)
, ptext (sLit "] ")
CmmSwitch expr ids ->
hang (hsep [ ptext (sLit "switch")
, range
, if isTrivialCmmExpr expr
then ppr expr
else parens (ppr expr)
, ptext (sLit " {")
, ptext (sLit "{")
])
4 (vcat ( map caseify pairs )) $$ rbrace
where pairs = groupBy snds (zip [0 .. ] maybe_ids )
snds a b = (snd a) == (snd b)
caseify ixs@((_,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")
, ppr (head [ id | Just id <- ids]) <> semi ]
4 (vcat (map ppCase cases) $$ def) $$ rbrace
where
(cases, mbdef) = switchTargetsFallThrough ids
ppCase (is,l) = hsep
[ ptext (sLit "case")
, commafy $ map integer is
, ptext (sLit ": goto")
, ppr l <> semi
]
def | Just l <- mbdef = hsep
[ ptext (sLit "default: goto")
, ppr l <> semi
]
| otherwise = empty
range = brackets $ hsep [integer lo, ptext (sLit ".."), integer hi]
where (lo,hi) = switchTargetsRange ids
CmmCall tgt k regs out res updfr_off ->
hcat [ ptext (sLit "call"), space
......
This diff is collapsed.
......@@ -197,6 +197,7 @@ Library
CmmPipeline
CmmCallConv
CmmCommonBlockElim
CmmImplementSwitchPlans
CmmContFlowOpt
CmmExpr
CmmInfo
......@@ -204,6 +205,7 @@ Library
CmmLint
CmmLive
CmmMachOp
CmmSwitch
CmmNode
CmmOpt
CmmParse
......
......@@ -601,6 +601,7 @@ compiler_stage2_dll0_MODULES += \
CmmInfo \
CmmMachOp \
CmmNode \
CmmSwitch \
CmmUtils \
CodeGen.Platform \
CodeGen.Platform.ARM \
......
......@@ -18,6 +18,7 @@ import Cmm
import CPrim
import PprCmm
import CmmUtils
import CmmSwitch
import Hoopl
import DynFlags
......@@ -824,18 +825,16 @@ For a real example of this, see ./rts/StgStdThunks.cmm
-- | Switch branch
--
-- N.B. We remove Nothing's from the list of branches, as they are 'undefined'.
-- However, they may be defined one day, so we better document this behaviour.
genSwitch :: CmmExpr -> [Maybe BlockId] -> LlvmM StmtData
genSwitch cond maybe_ids = do
genSwitch :: CmmExpr -> SwitchTargets -> LlvmM StmtData
genSwitch cond ids = do
(vc, stmts, top) <- exprToVar cond
let ty = getVarType vc
let pairs = [ (ix, id) | (ix,Just id) <- zip [0..] maybe_ids ]
let labels = map (\(ix, b) -> (mkIntLit ty ix, blockIdToLlvm b)) pairs
let labels = [ (mkIntLit ty ix, blockIdToLlvm b)
| (ix, b) <- switchTargetsCases ids ]
-- out of range is undefined, so let's just branch to first label
let (_, defLbl) = head labels
let defLbl | Just l <- switchTargetsDefault ids = blockIdToLlvm l
| otherwise = snd (head labels)
let s1 = Switch vc defLbl labels
return $ (stmts `snocOL` s1, top)
......
......@@ -243,6 +243,7 @@ data DumpFlag
-- enabled if you run -ddump-cmm
| Opt_D_dump_cmm_cfg
| Opt_D_dump_cmm_cbe
| Opt_D_dump_cmm_switch
| Opt_D_dump_cmm_proc
| Opt_D_dump_cmm_sink
| Opt_D_dump_cmm_sp
......@@ -2441,6 +2442,7 @@ dynamic_flags = [
, defGhcFlag "ddump-cmm-raw" (setDumpFlag Opt_D_dump_cmm_raw)
, defGhcFlag "ddump-cmm-cfg" (setDumpFlag Opt_D_dump_cmm_cfg)
, defGhcFlag "ddump-cmm-cbe" (setDumpFlag Opt_D_dump_cmm_cbe)
, defGhcFlag "ddump-cmm-switch" (setDumpFlag Opt_D_dump_cmm_switch)
, defGhcFlag "ddump-cmm-proc" (setDumpFlag Opt_D_dump_cmm_proc)
, defGhcFlag "ddump-cmm-sink" (setDumpFlag Opt_D_dump_cmm_sink)
, defGhcFlag "ddump-cmm-sp" (setDumpFlag Opt_D_dump_cmm_sp)
......
......@@ -45,6 +45,7 @@ import BlockId
import PprCmm ( pprExpr )
import Cmm
import CmmUtils
import CmmSwitch
import CLabel
import Hoopl
......@@ -152,8 +153,8 @@ stmtToInstrs stmt = do
CmmCondBranch arg true false -> do b1 <- genCondJump true arg
b2 <- genBranch false
return (b1 `appOL` b2)
CmmSwitch arg ids -> do dflags <- getDynFlags
genSwitch dflags arg ids
CmmSwitch arg ids -> do dflags <- getDynFlags
genSwitch dflags arg ids
CmmCall { cml_target = arg } -> genJump arg
_ ->
panic "stmtToInstrs: statement should have been cps'd away"
......@@ -1201,11 +1202,11 @@ genCCall' dflags gcp target dest_regs args0
-- -----------------------------------------------------------------------------
-- Generating a table-branch
genSwitch :: DynFlags -> CmmExpr -> [Maybe BlockId] -> NatM InstrBlock
genSwitch dflags expr ids
genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock
genSwitch dflags expr targets
| gopt Opt_PIC dflags
= do
(reg,e_code) <- getSomeReg expr
(reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)
tmp <- getNewRegNat II32
lbl <- getNewLabelNat
dflags <- getDynFlags
......@@ -1221,7 +1222,7 @@ genSwitch dflags expr ids
return code
| otherwise
= do
(reg,e_code) <- getSomeReg expr
(reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)
tmp <- getNewRegNat II32
lbl <- getNewLabelNat
let code = e_code `appOL` toOL [
......@@ -1232,6 +1233,7 @@ genSwitch dflags expr ids
BCTR ids (Just lbl)
]
return code
where (offset, ids) = switchTargetsToTable targets
generateJumpTableForInstr :: DynFlags -> Instr
-> Maybe (NatCmmDecl CmmStatics Instr)
......
......@@ -43,6 +43,7 @@ import NCGMonad
import BlockId
import Cmm
import CmmUtils
import CmmSwitch
import Hoopl
import PIC
import Reg
......@@ -150,8 +151,8 @@ stmtToInstrs stmt = do
CmmCondBranch arg true false -> do b1 <- genCondJump true arg
b2 <- genBranch false
return (b1 `appOL` b2)
CmmSwitch arg ids -> do dflags <- getDynFlags
genSwitch dflags arg ids
CmmSwitch arg ids -> do dflags <- getDynFlags
genSwitch dflags arg ids
CmmCall { cml_target = arg } -> genJump arg
_
......@@ -308,13 +309,13 @@ genCondJump bid bool = do
-- -----------------------------------------------------------------------------
-- Generating a table-branch
genSwitch :: DynFlags -> CmmExpr -> [Maybe BlockId] -> NatM InstrBlock
genSwitch dflags expr ids
genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock
genSwitch dflags expr targets
| gopt Opt_PIC dflags