diff options
26 files changed, 1323 insertions, 293 deletions
diff --git a/compiler/basicTypes/Literal.hs b/compiler/basicTypes/Literal.hs index 2c71be499b..ced05a4d2f 100644 --- a/compiler/basicTypes/Literal.hs +++ b/compiler/basicTypes/Literal.hs @@ -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 ~~~~~ diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/cmm/CmmCommonBlockElim.hs index 95910d16d5..09124106d5 100644 --- a/compiler/cmm/CmmCommonBlockElim.hs +++ b/compiler/cmm/CmmCommonBlockElim.hs @@ -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 diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs index bcb4cf97b3..95c195078f 100644 --- a/compiler/cmm/CmmContFlowOpt.hs +++ b/compiler/cmm/CmmContFlowOpt.hs @@ -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) } diff --git a/compiler/cmm/CmmImplementSwitchPlans.hs b/compiler/cmm/CmmImplementSwitchPlans.hs new file mode 100644 index 0000000000..9fb68d8131 --- /dev/null +++ b/compiler/cmm/CmmImplementSwitchPlans.hs @@ -0,0 +1,90 @@ +{-# 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) diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index e5938150e7..edce2e97bc 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -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 () diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs index 73f997168e..45538d3886 100644 --- a/compiler/cmm/CmmNode.hs +++ b/compiler/cmm/CmmNode.hs @@ -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 -- ----------------------------------------------------------------------------- diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 916c161647..6c4b835fc3 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -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 diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index af4f62a4a8..37dbd12525 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -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 <- diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index 2add4741ef..a31048206b 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -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 diff --git a/compiler/cmm/CmmSwitch.hs b/compiler/cmm/CmmSwitch.hs new file mode 100644 index 0000000000..95e57c70af --- /dev/null +++ b/compiler/cmm/CmmSwitch.hs @@ -0,0 +1,415 @@ +{-# LANGUAGE GADTs #-} +module CmmSwitch ( + SwitchTargets, + mkSwitchTargets, + switchTargetsCases, switchTargetsDefault, switchTargetsRange, switchTargetsSigned, + mapSwitchTargets, switchTargetsToTable, switchTargetsFallThrough, + switchTargetsToList, eqSwitchTargetWith, + + SwitchPlan(..), + targetSupportsSwitch, + createSwitchPlan, + ) where + +import Outputable +import DynFlags +import Compiler.Hoopl (Label) + +import Data.Maybe +import Data.List (groupBy) +import Data.Function (on) +import qualified Data.Map as M + +-- Note [Cmm Switches, the general plan] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Compiling a high-level switch statement, as it comes out of a STG case +-- expression, for example, allows for a surprising amount of design decisions. +-- Therefore, we cleanly separated this from the Stg → Cmm transformation, as +-- well as from the actual code generation. +-- +-- The overall plan is: +-- * The Stg → Cmm transformation creates a single `SwitchTargets` in +-- emitSwitch and emitCmmLitSwitch in StgCmmUtils.hs. +-- At this stage, they are unsuitable for code generation. +-- * A dedicated Cmm transformation (CmmImplementSwitchPlans) replaces these +-- switch statements with code that is suitable for code generation, i.e. +-- a nice balanced tree of decisions with dense jump tables in the leafs. +-- The actual planning of this tree is performed in pure code in createSwitchPlan +-- in this module. See Note [createSwitchPlan]. +-- * The actual code generation will not do any further processing and +-- implement each CmmSwitch with a jump tables. +-- +-- When compiling to LLVM or C, CmmImplementSwitchPlans leaves the switch +-- statements alone, as we can turn a SwitchTargets value into a nice +-- switch-statement in LLVM resp. C, and leave the rest to the compiler. +-- +-- See Note [CmmSwitch vs. CmmImplementSwitchPlans] why the two module are +-- separated. + +----------------------------------------------------------------------------- +-- Magic Constants +-- +-- There are a lot of heuristics here that depend on magic values where it is +-- hard to determine the "best" value (for whatever that means). These are the +-- magic values: + +-- | Number of consecutive default values allowed in a jump table. If there are +-- more of them, the jump tables are split. +-- +-- Currently 7, as it costs 7 words of additional code when a jump table is +-- split (at least on x64, determined experimentally). +maxJumpTableHole :: Integer +maxJumpTableHole = 7 + +-- | Minimum size of a jump table. If the number is smaller, the switch is +-- implemented using conditionals. +-- Currently 5, because an if-then-else tree of 4 values is nice and compact. +minJumpTableSize :: Int +minJumpTableSize = 5 + +-- | Minimum non-zero offset for a jump table. See Note [Jump Table Offset]. +minJumpTableOffset :: Integer +minJumpTableOffset = 2 + + +----------------------------------------------------------------------------- +-- Switch Targets + +-- Note [SwitchTargets]: +-- ~~~~~~~~~~~~~~~~~~~~~ +-- +-- The branches of a switch are stored in a SwitchTargets, which consists of an +-- (optional) default jump target, and a map from values to jump targets. +-- +-- If the default jump target is absent, the behaviour of the switch outside the +-- values of the map is undefined. +-- +-- We use an Integer for the keys the map so that it can be used in switches on +-- unsigned as well as signed integers. +-- +-- The map must not be empty. +-- +-- Before code generation, the table needs to be brought into a form where all +-- entries are non-negative, so that it can be compiled into a jump table. +-- See switchTargetsToTable. + + +-- | A value of type SwitchTargets contains the alternatives for a 'CmmSwitch' +-- value, and knows whether the value is signed, the possible range, an +-- optional default value and a map from values to jump labels. +data SwitchTargets = + SwitchTargets + Bool -- Signed values + (Integer, Integer) -- Range + (Maybe Label) -- Default value + (M.Map Integer Label) -- The branches + deriving (Show, Eq) + +-- | The smart constructr mkSwitchTargets normalises the map a bit: +-- * No entries outside the range +-- * No entries equal to the default +-- * No default if all elements have explicit values +mkSwitchTargets :: Bool -> (Integer, Integer) -> Maybe Label -> M.Map Integer Label -> SwitchTargets +mkSwitchTargets signed range@(lo,hi) mbdef ids + = SwitchTargets signed range mbdef' ids' + where + ids' = dropDefault $ restrict ids + mbdef' | defaultNeeded = mbdef + | otherwise = Nothing + + -- Drop entries outside the range, if there is a range + restrict = M.filterWithKey (\x _ -> lo <= x && x <= hi) + + -- Drop entries that equal the default, if there is a default + dropDefault | Just l <- mbdef = M.filter (/= l) + | otherwise = id + + -- Check if the default is still needed + defaultNeeded = fromIntegral (M.size ids') /= hi-lo+1 + + +-- | Changes all labels mentioned in the SwitchTargets value +mapSwitchTargets :: (Label -> Label) -> SwitchTargets -> SwitchTargets +mapSwitchTargets f (SwitchTargets signed range mbdef branches) + = SwitchTargets signed range (fmap f mbdef) (fmap f branches) + +-- | Returns the list of non-default branches of the SwitchTargets value +switchTargetsCases :: SwitchTargets -> [(Integer, Label)] +switchTargetsCases (SwitchTargets _ _ _ branches) = M.toList branches + +-- | Return the default label of the SwitchTargets value +switchTargetsDefault :: SwitchTargets -> Maybe Label +switchTargetsDefault (SwitchTargets _ _ mbdef _) = mbdef + +-- | Return the range of the SwitchTargets value +switchTargetsRange :: SwitchTargets -> (Integer, Integer) +switchTargetsRange (SwitchTargets _ range _ _) = range + +-- | Return whether this is used for a signed value +switchTargetsSigned :: SwitchTargets -> Bool +switchTargetsSigned (SwitchTargets signed _ _ _) = signed + +-- | switchTargetsToTable creates a dense jump table, usable for code generation. +-- Returns an offset to add to the value; the list is 0-based on the result. +-- The conversion from Integer to Int is a bit of a wart, but works due to +-- wrap-around arithmetic (as verified by the CmmSwitchTest test case). +switchTargetsToTable :: SwitchTargets -> (Int, [Maybe Label]) +switchTargetsToTable (SwitchTargets _ (lo,hi) mbdef branches) + = (fromIntegral (-start), [ labelFor i | i <- [start..hi] ]) + where + labelFor i = case M.lookup i branches of Just l -> Just l + Nothing -> mbdef + start | lo >= 0 && lo < minJumpTableOffset = 0 -- See Note [Jump Table Offset] + | otherwise = lo + +-- Note [Jump Table Offset] +-- ~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Usually, the code for a jump table starting at x will first subtract x from +-- the value, to avoid a large amount of empty entries. But if x is very small, +-- the extra entries are no worse than the subtraction in terms of code size, and +-- not having to do the subtraction is quicker. +-- +-- I.e. instead of +-- _u20N: +-- leaq -1(%r14),%rax +-- jmp *_n20R(,%rax,8) +-- _n20R: +-- .quad _c20p +-- .quad _c20q +-- do +-- _u20N: +-- jmp *_n20Q(,%r14,8) +-- +-- _n20Q: +-- .quad 0 +-- .quad _c20p +-- .quad _c20q +-- .quad _c20r + +-- | The list of all labels occuring in the SwitchTargets value. +switchTargetsToList :: SwitchTargets -> [Label] +switchTargetsToList (SwitchTargets _ _ mbdef branches) + = maybeToList mbdef ++ M.elems branches + +-- | Groups cases with equal targets, suitable for pretty-printing to a +-- c-like switch statement with fall-through semantics. +switchTargetsFallThrough :: SwitchTargets -> ([([Integer], Label)], Maybe Label) +switchTargetsFallThrough (SwitchTargets _ _ mbdef branches) = (groups, mbdef) + where + groups = map (\xs -> (map fst xs, snd (head xs))) $ + groupBy ((==) `on` snd) $ + M.toList branches + +-- | Custom equality helper, needed for "CmmCommonBlockElim" +eqSwitchTargetWith :: (Label -> Label -> Bool) -> SwitchTargets -> SwitchTargets -> Bool +eqSwitchTargetWith eq (SwitchTargets signed1 range1 mbdef1 ids1) (SwitchTargets signed2 range2 mbdef2 ids2) = + signed1 == signed2 && range1 == range2 && goMB mbdef1 mbdef2 && goList (M.toList ids1) (M.toList ids2) + where + goMB Nothing Nothing = True + goMB (Just l1) (Just l2) = l1 `eq` l2 + goMB _ _ = False + goList [] [] = True + goList ((i1,l1):ls1) ((i2,l2):ls2) = i1 == i2 && l1 `eq` l2 && goList ls1 ls2 + goList _ _ = False + +----------------------------------------------------------------------------- +-- Code generation for Switches + + +-- | A SwitchPlan abstractly descries how a Switch statement ought to be +-- implemented. See Note [createSwitchPlan] +data SwitchPlan + = Unconditionally Label + | IfEqual Integer Label SwitchPlan + | IfLT Bool Integer SwitchPlan SwitchPlan + | JumpTable SwitchTargets + deriving Show +-- +-- Note [createSwitchPlan] +-- ~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- A SwitchPlan describes how a Switch statement is to be broken down into +-- smaller pieces suitable for code generation. +-- +-- createSwitchPlan creates such a switch plan, in these steps: +-- 1. it splits the switch statement at segments of non-default values that +-- are too large. See splitAtHoles and Note [When to split SwitchTargets] +-- 2. Too small jump tables should be avoided, so we break up smaller pieces +-- in breakTooSmall. +-- 3. We will in the segments between those pieces with a jump to the default +-- label (if there is one), returning a SeparatedList in mkFlatSwitchPlan +-- 4. We find replace two less-than branches by a single equal-to-test in +-- findSingleValues +-- 5. The thus collected pieces are assembled to a balanced binary tree. + + +type FlatSwitchPlan = SeparatedList Integer SwitchPlan + +-- | Does the target support switch out of the box? Then leave this to the +-- target! +targetSupportsSwitch :: HscTarget -> Bool +targetSupportsSwitch HscC = True +targetSupportsSwitch HscLlvm = True +targetSupportsSwitch _ = False + +-- | This function creates a SwitchPlan from a SwitchTargets value, breaking it +-- down into smaller pieces suitable for code generation. +createSwitchPlan :: SwitchTargets -> SwitchPlan +createSwitchPlan (SwitchTargets signed mbdef range m) = + -- pprTrace "createSwitchPlan" (text (show ids) $$ text (show (range,m)) $$ text (show pieces) $$ text (show flatPlan) $$ text (show plan)) $ + plan + where + pieces = concatMap breakTooSmall $ splitAtHoles maxJumpTableHole m + flatPlan = findSingleValues $ mkFlatSwitchPlan signed range mbdef pieces + plan = buildTree signed $ flatPlan + + +--- +--- Step 1: Splitting at large holes +--- +splitAtHoles :: Integer -> M.Map Integer a -> [M.Map Integer a] +splitAtHoles holeSize m = map (\range -> restrictMap range m) nonHoles + where + holes = filter (\(l,h) -> h - l > holeSize) $ zip (M.keys m) (tail (M.keys m)) + nonHoles = reassocTuples lo holes hi + + (lo,_) = M.findMin m + (hi,_) = M.findMax m + +--- +--- Step 2: Avoid small jump tables +--- +-- We do not want jump tables below a certain size. This breaks them up +-- (into singleton maps, for now) +breakTooSmall :: M.Map Integer a -> [M.Map Integer a] +breakTooSmall m + | M.size m > minJumpTableSize = [m] + | otherwise = [M.singleton k v | (k,v) <- M.toList m] + +--- +--- Step 3: Fill in the blanks +--- + +-- A FlatSwitchPlan is a list of SwitchPlans, seperated by a integer dividing the range. +-- So if we have [plan1] n [plan2], then we use plan1 if the expression is < +-- n, and plan2 otherwise. + +mkFlatSwitchPlan :: Bool -> Maybe Label -> (Integer, Integer) -> [M.Map Integer Label] -> FlatSwitchPlan + +-- If we have no default (i.e. undefined where there is no entry), we can +-- branch at the minimum of each map +mkFlatSwitchPlan _ Nothing _ [] = pprPanic "mkFlatSwitchPlan with nothing left to do" empty +mkFlatSwitchPlan signed Nothing _ (m:ms) + = (mkLeafPlan signed Nothing m , [ (fst (M.findMin m'), mkLeafPlan signed Nothing m') | m' <- ms ]) + +-- If we have a default, we have to interleave segments that jump +-- to the default between the maps +mkFlatSwitchPlan signed (Just l) r ms = let ((_,p1):ps) = go r ms in (p1, ps) + where + go (lo,hi) [] + | lo > hi = [] + | otherwise = [(lo, Unconditionally l)] + go (lo,hi) (m:ms) + | lo < min + = (lo, Unconditionally l) : go (min,hi) (m:ms) + | lo == min + = (lo, mkLeafPlan signed (Just l) m) : go (max+1,hi) ms + | otherwise + = pprPanic "mkFlatSwitchPlan" (integer lo <+> integer min) + where + min = fst (M.findMin m) + max = fst (M.findMax m) + + +mkLeafPlan :: Bool -> Maybe Label -> M.Map Integer Label -> SwitchPlan +mkLeafPlan signed mbdef m + | [(_,l)] <- M.toList m -- singleton map + = Unconditionally l + | otherwise + = JumpTable $ mkSwitchTargets signed (min,max) mbdef m + where + min = fst (M.findMin m) + max = fst (M.findMax m) + +--- +--- Step 4: Reduce the number of branches using == +--- + +-- A seqence of three unconditional jumps, with the outer two pointing to the +-- same value and the bounds off by exactly one can be improved +findSingleValues :: FlatSwitchPlan -> FlatSwitchPlan +findSingleValues (Unconditionally l, (i, Unconditionally l2) : (i', Unconditionally l3) : xs) + | l == l3 && i + 1 == i' + = findSingleValues (IfEqual i l2 (Unconditionally l), xs) +findSingleValues (p, (i,p'):xs) + = (p,i) `consSL` findSingleValues (p', xs) +findSingleValues (p, []) + = (p, []) + +--- +--- Step 5: Actually build the tree +--- + +-- Build a balanced tree from a separated list +buildTree :: Bool -> FlatSwitchPlan -> SwitchPlan +buildTree _ (p,[]) = p +buildTree signed sl = IfLT signed m (buildTree signed sl1) (buildTree signed sl2) + where + (sl1, m, sl2) = divideSL sl + + + +-- +-- Utility data type: Non-empty lists with extra markers in between each +-- element: +-- + +type SeparatedList b a = (a, [(b,a)]) + +consSL :: (a, b) -> SeparatedList b a -> SeparatedList b a +consSL (a, b) (a', xs) = (a, (b,a'):xs) + +divideSL :: SeparatedList b a -> (SeparatedList b a, b, SeparatedList b a) +divideSL (_,[]) = error "divideSL: Singleton SeparatedList" +divideSL (p,xs) = ((p, xs1), m, (p', xs2)) + where + (xs1, (m,p'):xs2) = splitAt (length xs `div` 2) xs + +-- +-- Other Utilities +-- + +restrictMap :: Integral a => (a,a) -> M.Map a b -> M.Map a b +restrictMap (lo,hi) m = mid + where (_, mid_hi) = M.split (lo-1) m + (mid, _) = M.split (hi+1) mid_hi + +-- for example: reassocTuples a [(b,c),(d,e)] f == [(a,b),(c,d),(e,f)] +reassocTuples :: a -> [(a,a)] -> a -> [(a,a)] +reassocTuples initial [] last + = [(initial,last)] +reassocTuples initial ((a,b):tuples) last + = (initial,a) : reassocTuples b tuples last + +-- Note [CmmSwitch vs. CmmImplementSwitchPlans] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- I (Joachim) separated the two somewhat closely related modules +-- +-- - CmmSwitch, which provides the CmmSwitchTargets type and contains the strategy +-- for implementing a Cmm switch (createSwitchPlan), and +-- - CmmImplementSwitchPlans, which contains the actuall Cmm graph modification, +-- +-- for these reasons: +-- +-- * CmmSwitch is very low in the dependency tree, i.e. does not depend on any +-- GHC specific modules at all (with the exception of Output and Hoople +-- (Literal)). CmmImplementSwitchPlans is the Cmm transformation and hence very +-- high in the dependency tree. +-- * CmmSwitch provides the CmmSwitchTargets data type, which is abstract, but +-- used in CmmNodes. +-- * Because CmmSwitch is low in the dependency tree, the separation allows +-- for more parallelism when building GHC. +-- * The interaction between the modules is very explicit and easy to +-- understand, due to the small and simple interface. diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index 3ddb9ec002..d21d703e58 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -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] diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs index 064577cd0a..d2aa4aa057 100644 --- a/compiler/cmm/MkGraph.hs +++ b/compiler/cmm/MkGraph.hs @@ -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 diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index a2c3abf320..92c818242d 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -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. diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 9d9f3081dc..d5999f53fa 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -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 diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 98295c9836..9e056582f3 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -51,6 +51,7 @@ import MkGraph import CodeGen.Platform import CLabel import CmmUtils +import CmmSwitch import ForeignCall import IdInfo @@ -60,7 +61,6 @@ import SMRep import Module import Literal import Digraph -import ListSetOps import Util import Unique import DynFlags @@ -68,11 +68,11 @@ import FastString import Outputable import qualified Data.ByteString as BS +import qualified Data.Map as M import Data.Char import Data.List import Data.Ord import Data.Word -import Data.Maybe ------------------------------------------------------------------------- @@ -87,14 +87,6 @@ cgLit (MachStr s) = newByteStringCLit (BS.unpack s) cgLit other_lit = do dflags <- getDynFlags return (mkSimpleLit dflags other_lit) -mkLtOp :: DynFlags -> Literal -> MachOp --- On signed literals we must do a signed comparison -mkLtOp dflags (MachInt _) = MO_S_Lt (wordWidth dflags) -mkLtOp _ (MachFloat _) = MO_F_Lt W32 -mkLtOp _ (MachDouble _) = MO_F_Lt W64 -mkLtOp dflags lit = MO_U_Lt (typeWidth (cmmLitType dflags (mkSimpleLit dflags lit))) - -- ToDo: seems terribly indirect! - mkSimpleLit :: DynFlags -> Literal -> CmmLit mkSimpleLit dflags (MachChar c) = CmmInt (fromIntegral (ord c)) (wordWidth dflags) mkSimpleLit dflags MachNullAddr = zeroCLit dflags @@ -460,174 +452,52 @@ emitSwitch :: CmmExpr -- Tag to switch on -- behaviour outside this range is -- undefined -> FCode () -emitSwitch tag_expr branches mb_deflt lo_tag hi_tag - = do { dflags <- getDynFlags - ; mkCmmSwitch (via_C dflags) tag_expr branches mb_deflt lo_tag hi_tag } - where - via_C dflags | HscC <- hscTarget dflags = True - | otherwise = False - - -mkCmmSwitch :: Bool -- True <=> never generate a - -- conditional tree - -> CmmExpr -- Tag to switch on - -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches - -> Maybe CmmAGraphScoped -- Default branch (if any) - -> ConTagZ -> ConTagZ -- Min and Max possible values; - -- behaviour outside this range is - -- undefined - -> FCode () -- First, two rather common cases in which there is no work to do -mkCmmSwitch _ _ [] (Just code) _ _ = emit (fst code) -mkCmmSwitch _ _ [(_,code)] Nothing _ _ = emit (fst code) +emitSwitch _ [] (Just code) _ _ = emit (fst code) +emitSwitch _ [(_,code)] Nothing _ _ = emit (fst code) -- Right, off we go -mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag = do +emitSwitch tag_expr branches mb_deflt lo_tag hi_tag = do join_lbl <- newLabelC mb_deflt_lbl <- label_default join_lbl mb_deflt branches_lbls <- label_branches join_lbl branches tag_expr' <- assignTemp' tag_expr - emit =<< mk_switch tag_expr' (sortBy (comparing fst) branches_lbls) - mb_deflt_lbl lo_tag hi_tag via_C + -- Sort the branches before calling mk_discrete_switch + let branches_lbls' = [ (fromIntegral i, l) | (i,l) <- sortBy (comparing fst) branches_lbls ] + let range = (fromIntegral lo_tag, fromIntegral hi_tag) - -- Sort the branches before calling mk_switch + emit $ mk_discrete_switch False tag_expr' branches_lbls' mb_deflt_lbl range emitLabel join_lbl -mk_switch :: CmmExpr -> [(ConTagZ, BlockId)] +mk_discrete_switch :: Bool -- ^ Use signed comparisons + -> CmmExpr + -> [(Integer, BlockId)] -> Maybe BlockId - -> ConTagZ -> ConTagZ -> Bool - -> FCode CmmAGraph + -> (Integer, Integer) + -> CmmAGraph -- SINGLETON TAG RANGE: no case analysis to do -mk_switch _tag_expr [(tag, lbl)] _ lo_tag hi_tag _via_C +mk_discrete_switch _ _tag_expr [(tag, lbl)] _ (lo_tag, hi_tag) | lo_tag == hi_tag = ASSERT( tag == lo_tag ) - return (mkBranch lbl) + mkBranch lbl -- SINGLETON BRANCH, NO DEFAULT: no case analysis to do -mk_switch _tag_expr [(_tag,lbl)] Nothing _ _ _ - = return (mkBranch lbl) +mk_discrete_switch _ _tag_expr [(_tag,lbl)] Nothing _ + = mkBranch lbl -- The simplifier might have eliminated a case -- so we may have e.g. case xs of -- [] -> e -- In that situation we can be sure the (:) case -- can't happen, so no need to test --- SINGLETON BRANCH: one equality check to do -mk_switch tag_expr [(tag,lbl)] (Just deflt) _ _ _ - = do dflags <- getDynFlags - let cond = cmmNeWord dflags tag_expr (mkIntExpr dflags tag) - -- We have lo_tag < hi_tag, but there's only one branch, - -- so there must be a default - return (mkCbranch cond deflt lbl) - --- ToDo: we might want to check for the two branch case, where one of --- the branches is the tag 0, because comparing '== 0' is likely to be --- more efficient than other kinds of comparison. - --- DENSE TAG RANGE: use a switch statment. --- --- We also use a switch uncoditionally when compiling via C, because --- this will get emitted as a C switch statement and the C compiler --- should do a good job of optimising it. Also, older GCC versions --- (2.95 in particular) have problems compiling the complicated --- if-trees generated by this code, so compiling to a switch every --- time works around that problem. --- -mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C - | use_switch -- Use a switch - = do let - find_branch :: ConTagZ -> Maybe BlockId - find_branch i = case (assocMaybe branches i) of - Just lbl -> Just lbl - Nothing -> mb_deflt - - -- NB. we have eliminated impossible branches at - -- either end of the range (see below), so the first - -- tag of a real branch is real_lo_tag (not lo_tag). - arms :: [Maybe BlockId] - arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]] - dflags <- getDynFlags - return (mkSwitch (cmmOffset dflags tag_expr (- real_lo_tag)) arms) - - -- if we can knock off a bunch of default cases with one if, then do so - | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches - = do dflags <- getDynFlags - stmts <- mk_switch tag_expr branches mb_deflt - lowest_branch hi_tag via_C - mkCmmIfThenElse - (cmmULtWord dflags tag_expr (mkIntExpr dflags lowest_branch)) - (mkBranch deflt) - stmts - - | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches - = do dflags <- getDynFlags - stmts <- mk_switch tag_expr branches mb_deflt - lo_tag highest_branch via_C - mkCmmIfThenElse - (cmmUGtWord dflags tag_expr (mkIntExpr dflags highest_branch)) - (mkBranch deflt) - stmts - - | otherwise -- Use an if-tree - = do dflags <- getDynFlags - lo_stmts <- mk_switch tag_expr lo_branches mb_deflt - lo_tag (mid_tag-1) via_C - hi_stmts <- mk_switch tag_expr hi_branches mb_deflt - mid_tag hi_tag via_C - mkCmmIfThenElse - (cmmUGeWord dflags tag_expr (mkIntExpr dflags mid_tag)) - hi_stmts - lo_stmts - -- we test (e >= mid_tag) rather than (e < mid_tag), because - -- the former works better when e is a comparison, and there - -- are two tags 0 & 1 (mid_tag == 1). In this case, the code - -- generator can reduce the condition to e itself without - -- having to reverse the sense of the comparison: comparisons - -- can't always be easily reversed (eg. floating - -- pt. comparisons). - where - use_switch = {- pprTrace "mk_switch" ( - ppr tag_expr <+> text "n_tags:" <+> int n_tags <+> - text "branches:" <+> ppr (map fst branches) <+> - text "n_branches:" <+> int n_branches <+> - text "lo_tag:" <+> int lo_tag <+> - text "hi_tag:" <+> int hi_tag <+> - text "real_lo_tag:" <+> int real_lo_tag <+> - text "real_hi_tag:" <+> int real_hi_tag) $ -} - ASSERT( n_branches > 1 && n_tags > 1 ) - n_tags > 2 && (via_C || (dense && big_enough)) - -- up to 4 branches we use a decision tree, otherwise - -- a switch (== jump table in the NCG). This seems to be - -- optimal, and corresponds with what gcc does. - big_enough = n_branches > 4 - dense = n_branches > (n_tags `div` 2) - n_branches = length branches - - -- ignore default slots at each end of the range if there's - -- no default branch defined. - lowest_branch = fst (head branches) - highest_branch = fst (last branches) - - real_lo_tag - | isNothing mb_deflt = lowest_branch - | otherwise = lo_tag - - real_hi_tag - | isNothing mb_deflt = highest_branch - | otherwise = hi_tag - - n_tags = real_hi_tag - real_lo_tag + 1 - - -- INVARIANT: Provided hi_tag > lo_tag (which is true) - -- lo_tag <= mid_tag < hi_tag - -- lo_branches have tags < mid_tag - -- hi_branches have tags >= mid_tag - (lo_branches, mid_tag, hi_branches) = divideBranches branches - +-- SOMETHING MORE COMPLICATED: defer to CmmImplementSwitchPlans +-- See Note [Cmm Switches, the general plan] in CmmSwitch +mk_discrete_switch signed tag_expr branches mb_deflt range + = mkSwitch tag_expr $ mkSwitchTargets signed range mb_deflt (M.fromList branches) divideBranches :: Ord a => [(a,b)] -> ([(a,b)], a, [(a,b)]) divideBranches branches = (lo_branches, mid, hi_branches) @@ -644,20 +514,34 @@ emitCmmLitSwitch :: CmmExpr -- Tag to switch on -> [(Literal, CmmAGraphScoped)] -- Tagged branches -> CmmAGraphScoped -- Default branch (always) -> FCode () -- Emit the code --- Used for general literals, whose size might not be a word, --- where there is always a default case, and where we don't know --- the range of values for certain. For simplicity we always generate a tree. --- --- ToDo: for integers we could do better here, perhaps by generalising --- mk_switch and using that. --SDM 15/09/2004 emitCmmLitSwitch _scrut [] deflt = emit $ fst deflt emitCmmLitSwitch scrut branches deflt = do scrut' <- assignTemp' scrut join_lbl <- newLabelC deflt_lbl <- label_code join_lbl deflt branches_lbls <- label_branches join_lbl branches - emit =<< mk_lit_switch scrut' deflt_lbl noBound - (sortBy (comparing fst) branches_lbls) + + dflags <- getDynFlags + let cmm_ty = cmmExprType dflags scrut + rep = typeWidth cmm_ty + + -- We find the necessary type information in the literals in the branches + let signed = case head branches of + (MachInt _, _) -> True + (MachInt64 _, _) -> True + _ -> False + + let range | signed = (tARGET_MIN_INT dflags, tARGET_MAX_INT dflags) + | otherwise = (0, tARGET_MAX_WORD dflags) + + if isFloatType cmm_ty + then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls + else emit $ mk_discrete_switch + signed + scrut' + [(litValue lit,l) | (lit,l) <- branches_lbls] + (Just deflt_lbl) + range emitLabel join_lbl -- | lower bound (inclusive), upper bound (exclusive) @@ -666,31 +550,23 @@ type LitBound = (Maybe Literal, Maybe Literal) noBound :: LitBound noBound = (Nothing, Nothing) -mk_lit_switch :: CmmExpr -> BlockId +mk_float_switch :: Width -> CmmExpr -> BlockId -> LitBound -> [(Literal,BlockId)] -> FCode CmmAGraph -mk_lit_switch scrut deflt bounds [(lit,blk)] - = do - dflags <- getDynFlags - let - cmm_lit = mkSimpleLit dflags lit - cmm_ty = cmmLitType dflags cmm_lit - rep = typeWidth cmm_ty - ne = if isFloatType cmm_ty then MO_F_Ne rep else MO_Ne rep - - return $ if lit `onlyWithinBounds'` bounds - then mkBranch blk - else mkCbranch (CmmMachOp ne [scrut, CmmLit cmm_lit]) deflt blk +mk_float_switch rep scrut deflt _bounds [(lit,blk)] + = do dflags <- getDynFlags + return $ mkCbranch (cond dflags) deflt blk where - -- If the bounds already imply scrut == lit, then we can skip the final check (#10129) - l `onlyWithinBounds'` (Just lo, Just hi) = l `onlyWithinBounds` (lo, hi) - _ `onlyWithinBounds'` _ = False + cond dflags = CmmMachOp ne [scrut, CmmLit cmm_lit] + where + cmm_lit = mkSimpleLit dflags lit + ne = MO_F_Ne rep -mk_lit_switch scrut deflt_blk_id (lo_bound, hi_bound) branches +mk_float_switch rep scrut deflt_blk_id (lo_bound, hi_bound) branches = do dflags <- getDynFlags - lo_blk <- mk_lit_switch scrut deflt_blk_id bounds_lo lo_branches - hi_blk <- mk_lit_switch scrut deflt_blk_id bounds_hi hi_branches + lo_blk <- mk_float_switch rep scrut deflt_blk_id bounds_lo lo_branches + hi_blk <- mk_float_switch rep scrut deflt_blk_id bounds_hi hi_branches mkCmmIfThenElse (cond dflags) lo_blk hi_blk where (lo_branches, mid_lit, hi_branches) = divideBranches branches @@ -698,8 +574,10 @@ mk_lit_switch scrut deflt_blk_id (lo_bound, hi_bound) branches bounds_lo = (lo_bound, Just mid_lit) bounds_hi = (Just mid_lit, hi_bound) - cond dflags = CmmMachOp (mkLtOp dflags mid_lit) - [scrut, CmmLit (mkSimpleLit dflags mid_lit)] + cond dflags = CmmMachOp lt [scrut, CmmLit cmm_lit] + where + cmm_lit = mkSimpleLit dflags mid_lit + lt = MO_F_Lt rep -------------- diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 684ee6bfaf..c39c83e22c 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -197,6 +197,7 @@ Library CmmPipeline CmmCallConv CmmCommonBlockElim + CmmImplementSwitchPlans CmmContFlowOpt CmmExpr CmmInfo @@ -204,6 +205,7 @@ Library CmmLint CmmLive CmmMachOp + CmmSwitch CmmNode CmmOpt CmmParse diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 132a4dd67a..6f396fa514 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -601,6 +601,7 @@ compiler_stage2_dll0_MODULES += \ CmmInfo \ CmmMachOp \ CmmNode \ + CmmSwitch \ CmmUtils \ CodeGen.Platform \ CodeGen.Platform.ARM \ diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index c7be2c3194..4f864b6904 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -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) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 8e3733f5b6..0dc25e382d 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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) diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index e547ab6c95..a115980183 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -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) diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index bba849da61..a9d861946e 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -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 = error "MachCodeGen: sparc genSwitch PIC not finished\n" | otherwise - = do (e_reg, e_code) <- getSomeReg expr + = do (e_reg, e_code) <- getSomeReg (cmmOffset dflags expr offset) base_reg <- getNewRegNat II32 offset_reg <- getNewRegNat II32 @@ -335,6 +336,7 @@ genSwitch dflags expr ids , LD II32 (AddrRegReg base_reg offset_reg) dst , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label , NOP ] + where (offset, ids) = switchTargetsToTable targets generateJumpTableForInstr :: DynFlags -> Instr -> Maybe (NatCmmDecl CmmStatics Instr) diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 531213dc7f..7b7cc54bbe 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -45,6 +45,7 @@ import BlockId import Module ( primPackageKey ) import PprCmm () import CmmUtils +import CmmSwitch import Cmm import Hoopl import CLabel @@ -180,8 +181,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 , cml_args_regs = gregs } -> do dflags <- getDynFlags @@ -2584,12 +2585,12 @@ outOfLineCmmOp mop res args -- ----------------------------------------------------------------------------- -- Generating a table-branch -genSwitch :: DynFlags -> CmmExpr -> [Maybe BlockId] -> NatM InstrBlock +genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock -genSwitch dflags expr ids +genSwitch dflags expr targets | gopt Opt_PIC dflags = do - (reg,e_code) <- getSomeReg expr + (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset) lbl <- getNewLabelNat dflags <- getDynFlags dynRef <- cmmMakeDynamicReference dflags DataReference lbl @@ -2631,13 +2632,14 @@ genSwitch dflags expr ids ] | otherwise = do - (reg,e_code) <- getSomeReg expr + (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset) lbl <- getNewLabelNat let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (wORD_SIZE dflags)) (ImmCLbl lbl)) code = e_code `appOL` toOL [ JMP_TBL op ids ReadOnlyData lbl ] return code + where (offset, ids) = switchTargetsToTable targets generateJumpTableForInstr :: DynFlags -> Instr -> Maybe (NatCmmDecl (Alignment, CmmStatics) Instr) generateJumpTableForInstr dflags (JMP_TBL _ ids section lbl) diff --git a/testsuite/tests/codeGen/should_run/CmmSwitchTest.hs b/testsuite/tests/codeGen/should_run/CmmSwitchTest.hs new file mode 100644 index 0000000000..4fbe822b3b --- /dev/null +++ b/testsuite/tests/codeGen/should_run/CmmSwitchTest.hs @@ -0,0 +1,505 @@ +{-# LANGUAGE MagicHash #-} +import Control.Monad (unless, forM_) +import GHC.Exts +{-# NOINLINE aa #-} +aa :: Int# -> Int# +aa 1# = 42# +aa 2# = 43# +aa 3# = 43# +aa 4# = 44# +aa 5# = 44# +aa 6# = 45# +aa 7# = 45# +aa 8# = 46# +aa 9# = 46# +aa 10# = 47# +aa _ = 1337# + +{-# NOINLINE ab #-} +ab :: Int# -> Int# +ab 0# = 42# +ab 1# = 42# +ab 2# = 43# +ab 3# = 43# +ab 4# = 44# +ab 5# = 44# +ab 6# = 45# +ab 7# = 45# +ab 8# = 46# +ab 9# = 46# +ab 10# = 47# +ab _ = 1337# + +{-# NOINLINE ac #-} +ac :: Int# -> Int# +ac 1# = 42# +ac 2# = 43# +ac 3# = 43# +ac _ = 1337# + +{-# NOINLINE ad #-} +ad :: Int# -> Int# +ad 1# = 42# +ad 2# = 43# +ad 3# = 43# +ad 4# = 44# +ad _ = 1337# + +{-# NOINLINE ae #-} +ae :: Int# -> Int# +ae 1# = 42# +ae 2# = 43# +ae 3# = 43# +ae 4# = 44# +ae 5# = 44# +ae _ = 1337# + +{-# NOINLINE af #-} +af :: Int# -> Int# +af -1# = 41# +af 0# = 42# +af 1# = 42# +af 2# = 43# +af 3# = 43# +af 4# = 44# +af 5# = 44# +af 6# = 45# +af 7# = 45# +af 8# = 46# +af 9# = 46# +af 10# = 47# +af _ = 1337# + +{-# NOINLINE ag #-} +ag :: Int# -> Int# +ag -10# = 37# +ag -9# = 37# +ag -8# = 38# +ag -7# = 38# +ag -6# = 39# +ag -5# = 39# +ag -4# = 40# +ag -3# = 40# +ag -2# = 41# +ag -1# = 41# +ag 0# = 42# +ag 1# = 42# +ag 2# = 43# +ag 3# = 43# +ag 4# = 44# +ag 5# = 44# +ag 6# = 45# +ag 7# = 45# +ag 8# = 46# +ag 9# = 46# +ag 10# = 47# +ag _ = 1337# + +{-# NOINLINE ah #-} +ah :: Int# -> Int# +ah -20# = 32# +ah -19# = 32# +ah -18# = 33# +ah -17# = 33# +ah -16# = 34# +ah -15# = 34# +ah -14# = 35# +ah -13# = 35# +ah -12# = 36# +ah -11# = 36# +ah -10# = 37# +ah 0# = 42# +ah 1# = 42# +ah 2# = 43# +ah 3# = 43# +ah 4# = 44# +ah 5# = 44# +ah 6# = 45# +ah 7# = 45# +ah 8# = 46# +ah 9# = 46# +ah 10# = 47# +ah _ = 1337# + +{-# NOINLINE ai #-} +ai :: Int# -> Int# +ai -20# = 32# +ai -19# = 32# +ai -18# = 33# +ai -17# = 33# +ai -16# = 34# +ai -15# = 34# +ai -14# = 35# +ai -13# = 35# +ai -12# = 36# +ai -11# = 36# +ai -10# = 37# +ai 1# = 42# +ai 2# = 43# +ai 3# = 43# +ai 4# = 44# +ai 5# = 44# +ai 6# = 45# +ai 7# = 45# +ai 8# = 46# +ai 9# = 46# +ai 10# = 47# +ai _ = 1337# + +{-# NOINLINE aj #-} +aj :: Int# -> Int# +aj -9223372036854775808# = -4611686018427387862# +aj 0# = 42# +aj 9223372036854775807# = 4611686018427387945# +aj _ = 1337# + +{-# NOINLINE ak #-} +ak :: Int# -> Int# +ak 9223372036854775797# = 4611686018427387940# +ak 9223372036854775798# = 4611686018427387941# +ak 9223372036854775799# = 4611686018427387941# +ak 9223372036854775800# = 4611686018427387942# +ak 9223372036854775801# = 4611686018427387942# +ak 9223372036854775802# = 4611686018427387943# +ak 9223372036854775803# = 4611686018427387943# +ak 9223372036854775804# = 4611686018427387944# +ak 9223372036854775805# = 4611686018427387944# +ak 9223372036854775806# = 4611686018427387945# +ak 9223372036854775807# = 4611686018427387945# +ak _ = 1337# + +{-# NOINLINE al #-} +al :: Int# -> Int# +al -9223372036854775808# = -4611686018427387862# +al -9223372036854775807# = -4611686018427387862# +al -9223372036854775806# = -4611686018427387861# +al -9223372036854775805# = -4611686018427387861# +al -9223372036854775804# = -4611686018427387860# +al -9223372036854775803# = -4611686018427387860# +al -9223372036854775802# = -4611686018427387859# +al -9223372036854775801# = -4611686018427387859# +al -9223372036854775800# = -4611686018427387858# +al -9223372036854775799# = -4611686018427387858# +al -9223372036854775798# = -4611686018427387857# +al 9223372036854775797# = 4611686018427387940# +al 9223372036854775798# = 4611686018427387941# +al 9223372036854775799# = 4611686018427387941# +al 9223372036854775800# = 4611686018427387942# +al 9223372036854775801# = 4611686018427387942# +al 9223372036854775802# = 4611686018427387943# +al 9223372036854775803# = 4611686018427387943# +al 9223372036854775804# = 4611686018427387944# +al 9223372036854775805# = 4611686018427387944# +al 9223372036854775806# = 4611686018427387945# +al 9223372036854775807# = 4611686018427387945# +al _ = 1337# + +{-# NOINLINE am #-} +am :: Word# -> Word# +am 0## = 42## +am 1## = 42## +am 2## = 43## +am 3## = 43## +am 4## = 44## +am 5## = 44## +am 6## = 45## +am 7## = 45## +am 8## = 46## +am 9## = 46## +am 10## = 47## +am _ = 1337## + +{-# NOINLINE an #-} +an :: Word# -> Word# +an 1## = 42## +an 2## = 43## +an 3## = 43## +an 4## = 44## +an 5## = 44## +an 6## = 45## +an 7## = 45## +an 8## = 46## +an 9## = 46## +an 10## = 47## +an _ = 1337## + +{-# NOINLINE ao #-} +ao :: Word# -> Word# +ao 0## = 42## +ao _ = 1337## + +{-# NOINLINE ap #-} +ap :: Word# -> Word# +ap 0## = 42## +ap 1## = 42## +ap _ = 1337## + +{-# NOINLINE aq #-} +aq :: Word# -> Word# +aq 0## = 42## +aq 1## = 42## +aq 2## = 43## +aq _ = 1337## + +{-# NOINLINE ar #-} +ar :: Word# -> Word# +ar 0## = 42## +ar 1## = 42## +ar 2## = 43## +ar 3## = 43## +ar _ = 1337## + +{-# NOINLINE as #-} +as :: Word# -> Word# +as 0## = 42## +as 1## = 42## +as 2## = 43## +as 3## = 43## +as 4## = 44## +as _ = 1337## + +{-# NOINLINE at #-} +at :: Word# -> Word# +at 1## = 42## +at _ = 1337## + +{-# NOINLINE au #-} +au :: Word# -> Word# +au 1## = 42## +au 2## = 43## +au _ = 1337## + +{-# NOINLINE av #-} +av :: Word# -> Word# +av 1## = 42## +av 2## = 43## +av 3## = 43## +av _ = 1337## + +{-# NOINLINE aw #-} +aw :: Word# -> Word# +aw 1## = 42## +aw 2## = 43## +aw 3## = 43## +aw 4## = 44## +aw _ = 1337## + +{-# NOINLINE ax #-} +ax :: Word# -> Word# +ax 1## = 42## +ax 2## = 43## +ax 3## = 43## +ax 4## = 44## +ax 5## = 44## +ax _ = 1337## + +{-# NOINLINE ay #-} +ay :: Word# -> Word# +ay 0## = 42## +ay 18446744073709551615## = 9223372036854775849## +ay _ = 1337## + +{-# NOINLINE az #-} +az :: Word# -> Word# +az 18446744073709551605## = 9223372036854775844## +az 18446744073709551606## = 9223372036854775845## +az 18446744073709551607## = 9223372036854775845## +az 18446744073709551608## = 9223372036854775846## +az 18446744073709551609## = 9223372036854775846## +az 18446744073709551610## = 9223372036854775847## +az 18446744073709551611## = 9223372036854775847## +az 18446744073709551612## = 9223372036854775848## +az 18446744073709551613## = 9223372036854775848## +az 18446744073709551614## = 9223372036854775849## +az 18446744073709551615## = 9223372036854775849## +az _ = 1337## + +{-# NOINLINE ba #-} +ba :: Word# -> Word# +ba 0## = 42## +ba 1## = 42## +ba 2## = 43## +ba 3## = 43## +ba 4## = 44## +ba 5## = 44## +ba 6## = 45## +ba 7## = 45## +ba 8## = 46## +ba 9## = 46## +ba 10## = 47## +ba 18446744073709551605## = 9223372036854775844## +ba 18446744073709551606## = 9223372036854775845## +ba 18446744073709551607## = 9223372036854775845## +ba 18446744073709551608## = 9223372036854775846## +ba 18446744073709551609## = 9223372036854775846## +ba 18446744073709551610## = 9223372036854775847## +ba 18446744073709551611## = 9223372036854775847## +ba 18446744073709551612## = 9223372036854775848## +ba 18446744073709551613## = 9223372036854775848## +ba 18446744073709551614## = 9223372036854775849## +ba 18446744073709551615## = 9223372036854775849## +ba _ = 1337## + +aa_check :: IO () +aa_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do + let r = I# (aa i) + unless (r == o) $ putStrLn $ "ERR: aa (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ab_check :: IO () +ab_check = forM_ [(-1,1337), (0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do + let r = I# (ab i) + unless (r == o) $ putStrLn $ "ERR: ab (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ac_check :: IO () +ac_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,1337)] $ \(I# i,o) -> do + let r = I# (ac i) + unless (r == o) $ putStrLn $ "ERR: ac (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ad_check :: IO () +ad_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,1337)] $ \(I# i,o) -> do + let r = I# (ad i) + unless (r == o) $ putStrLn $ "ERR: ad (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ae_check :: IO () +ae_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,1337)] $ \(I# i,o) -> do + let r = I# (ae i) + unless (r == o) $ putStrLn $ "ERR: ae (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +af_check :: IO () +af_check = forM_ [(-2,1337), (-1,41), (0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do + let r = I# (af i) + unless (r == o) $ putStrLn $ "ERR: af (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ag_check :: IO () +ag_check = forM_ [(-11,1337), (-10,37), (-9,37), (-8,38), (-7,38), (-6,39), (-5,39), (-4,40), (-3,40), (-2,41), (-1,41), (0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do + let r = I# (ag i) + unless (r == o) $ putStrLn $ "ERR: ag (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ah_check :: IO () +ah_check = forM_ [(-21,1337), (-20,32), (-19,32), (-18,33), (-17,33), (-16,34), (-15,34), (-14,35), (-13,35), (-12,36), (-11,36), (-10,37), (-9,1337), (-1,1337), (0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do + let r = I# (ah i) + unless (r == o) $ putStrLn $ "ERR: ah (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ai_check :: IO () +ai_check = forM_ [(-21,1337), (-20,32), (-19,32), (-18,33), (-17,33), (-16,34), (-15,34), (-14,35), (-13,35), (-12,36), (-11,36), (-10,37), (-9,1337), (0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do + let r = I# (ai i) + unless (r == o) $ putStrLn $ "ERR: ai (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +aj_check :: IO () +aj_check = forM_ [(-9223372036854775808,-4611686018427387862), (-9223372036854775807,1337), (-1,1337), (0,42), (1,1337), (9223372036854775806,1337), (9223372036854775807,4611686018427387945)] $ \(I# i,o) -> do + let r = I# (aj i) + unless (r == o) $ putStrLn $ "ERR: aj (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ak_check :: IO () +ak_check = forM_ [(9223372036854775796,1337), (9223372036854775797,4611686018427387940), (9223372036854775798,4611686018427387941), (9223372036854775799,4611686018427387941), (9223372036854775800,4611686018427387942), (9223372036854775801,4611686018427387942), (9223372036854775802,4611686018427387943), (9223372036854775803,4611686018427387943), (9223372036854775804,4611686018427387944), (9223372036854775805,4611686018427387944), (9223372036854775806,4611686018427387945), (9223372036854775807,4611686018427387945)] $ \(I# i,o) -> do + let r = I# (ak i) + unless (r == o) $ putStrLn $ "ERR: ak (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +al_check :: IO () +al_check = forM_ [(-9223372036854775808,-4611686018427387862), (-9223372036854775807,-4611686018427387862), (-9223372036854775806,-4611686018427387861), (-9223372036854775805,-4611686018427387861), (-9223372036854775804,-4611686018427387860), (-9223372036854775803,-4611686018427387860), (-9223372036854775802,-4611686018427387859), (-9223372036854775801,-4611686018427387859), (-9223372036854775800,-4611686018427387858), (-9223372036854775799,-4611686018427387858), (-9223372036854775798,-4611686018427387857), (-9223372036854775797,1337), (9223372036854775796,1337), (9223372036854775797,4611686018427387940), (9223372036854775798,4611686018427387941), (9223372036854775799,4611686018427387941), (9223372036854775800,4611686018427387942), (9223372036854775801,4611686018427387942), (9223372036854775802,4611686018427387943), (9223372036854775803,4611686018427387943), (9223372036854775804,4611686018427387944), (9223372036854775805,4611686018427387944), (9223372036854775806,4611686018427387945), (9223372036854775807,4611686018427387945)] $ \(I# i,o) -> do + let r = I# (al i) + unless (r == o) $ putStrLn $ "ERR: al (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +am_check :: IO () +am_check = forM_ [(0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(W# i,o) -> do + let r = W# (am i) + unless (r == o) $ putStrLn $ "ERR: am (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +an_check :: IO () +an_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(W# i,o) -> do + let r = W# (an i) + unless (r == o) $ putStrLn $ "ERR: an (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ao_check :: IO () +ao_check = forM_ [(0,42), (1,1337)] $ \(W# i,o) -> do + let r = W# (ao i) + unless (r == o) $ putStrLn $ "ERR: ao (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ap_check :: IO () +ap_check = forM_ [(0,42), (1,42), (2,1337)] $ \(W# i,o) -> do + let r = W# (ap i) + unless (r == o) $ putStrLn $ "ERR: ap (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +aq_check :: IO () +aq_check = forM_ [(0,42), (1,42), (2,43), (3,1337)] $ \(W# i,o) -> do + let r = W# (aq i) + unless (r == o) $ putStrLn $ "ERR: aq (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ar_check :: IO () +ar_check = forM_ [(0,42), (1,42), (2,43), (3,43), (4,1337)] $ \(W# i,o) -> do + let r = W# (ar i) + unless (r == o) $ putStrLn $ "ERR: ar (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +as_check :: IO () +as_check = forM_ [(0,42), (1,42), (2,43), (3,43), (4,44), (5,1337)] $ \(W# i,o) -> do + let r = W# (as i) + unless (r == o) $ putStrLn $ "ERR: as (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +at_check :: IO () +at_check = forM_ [(0,1337), (1,42), (2,1337)] $ \(W# i,o) -> do + let r = W# (at i) + unless (r == o) $ putStrLn $ "ERR: at (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +au_check :: IO () +au_check = forM_ [(0,1337), (1,42), (2,43), (3,1337)] $ \(W# i,o) -> do + let r = W# (au i) + unless (r == o) $ putStrLn $ "ERR: au (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +av_check :: IO () +av_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,1337)] $ \(W# i,o) -> do + let r = W# (av i) + unless (r == o) $ putStrLn $ "ERR: av (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +aw_check :: IO () +aw_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,1337)] $ \(W# i,o) -> do + let r = W# (aw i) + unless (r == o) $ putStrLn $ "ERR: aw (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ax_check :: IO () +ax_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,1337)] $ \(W# i,o) -> do + let r = W# (ax i) + unless (r == o) $ putStrLn $ "ERR: ax (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ay_check :: IO () +ay_check = forM_ [(0,42), (1,1337), (18446744073709551614,1337), (18446744073709551615,9223372036854775849)] $ \(W# i,o) -> do + let r = W# (ay i) + unless (r == o) $ putStrLn $ "ERR: ay (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +az_check :: IO () +az_check = forM_ [(18446744073709551604,1337), (18446744073709551605,9223372036854775844), (18446744073709551606,9223372036854775845), (18446744073709551607,9223372036854775845), (18446744073709551608,9223372036854775846), (18446744073709551609,9223372036854775846), (18446744073709551610,9223372036854775847), (18446744073709551611,9223372036854775847), (18446744073709551612,9223372036854775848), (18446744073709551613,9223372036854775848), (18446744073709551614,9223372036854775849), (18446744073709551615,9223372036854775849)] $ \(W# i,o) -> do + let r = W# (az i) + unless (r == o) $ putStrLn $ "ERR: az (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ba_check :: IO () +ba_check = forM_ [(0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337), (18446744073709551604,1337), (18446744073709551605,9223372036854775844), (18446744073709551606,9223372036854775845), (18446744073709551607,9223372036854775845), (18446744073709551608,9223372036854775846), (18446744073709551609,9223372036854775846), (18446744073709551610,9223372036854775847), (18446744073709551611,9223372036854775847), (18446744073709551612,9223372036854775848), (18446744073709551613,9223372036854775848), (18446744073709551614,9223372036854775849), (18446744073709551615,9223372036854775849)] $ \(W# i,o) -> do + let r = W# (ba i) + unless (r == o) $ putStrLn $ "ERR: ba (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +main = do + aa_check + ab_check + ac_check + ad_check + ae_check + af_check + ag_check + ah_check + ai_check + aj_check + ak_check + al_check + am_check + an_check + ao_check + ap_check + aq_check + ar_check + as_check + at_check + au_check + av_check + aw_check + ax_check + ay_check + az_check + ba_check diff --git a/testsuite/tests/codeGen/should_run/CmmSwitchTestGen.hs b/testsuite/tests/codeGen/should_run/CmmSwitchTestGen.hs new file mode 100644 index 0000000000..61af0decac --- /dev/null +++ b/testsuite/tests/codeGen/should_run/CmmSwitchTestGen.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE TupleSections #-} + +-- Generates CmmSwitch.hs + +import qualified Data.Set as S +import Data.Word +import Data.List + +output :: Integer -> Integer +output n = n`div`2 + 42 + +def :: Integer +def = 1337 + +type Spec = (String, Bool, [Integer]) + +primtyp True = "Int#" +primtyp False = "Word#" + +con True = "I#" +con False = "W#" + +hash True = "#" +hash False = "##" + +primLit s v = show v ++ hash s + +genSwitch :: Spec -> String +genSwitch (name, signed, values) = unlines $ + [ "{-# NOINLINE " ++ name ++ " #-}" ] ++ + [ name ++ " :: " ++ primtyp signed ++ " -> " ++ primtyp signed ] ++ + [ name ++ " " ++ primLit signed v ++ " = " ++ primLit signed (output v) + | v <- values] ++ + [ name ++ " _ = " ++ primLit signed def ] + +genCheck :: Spec -> String +genCheck (name, signed, values) = unlines $ + [ checkName name ++ " :: IO ()" + , checkName name ++ " = forM_ [" ++ pairs ++ "] $ \\(" ++ con signed ++ " i,o) -> do" + , " let r = " ++ con signed ++ " (" ++ name ++ " i)" + , " unless (r == o) $ putStrLn $ \"ERR: " ++ name ++ " (\" ++ show (" ++ con signed ++ " i)++ \") is \" ++ show r ++ \" and not \" ++ show o ++\".\"" + ] + where + f x | x `S.member` range = output x + | otherwise = def + range = S.fromList values + checkValues = S.toList $ S.fromList $ + [ v' | v <- values, v' <- [v-1,v,v+1], + if signed then v' >= minS && v' <= maxS else v' >= minU && v' <= maxU ] + pairs = intercalate ", " ["(" ++ show v ++ "," ++ show (f v) ++ ")" | v <- checkValues ] + +checkName :: String -> String +checkName f = f ++ "_check" + +genMain :: [Spec] -> String +genMain specs = unlines $ "main = do" : [ " " ++ checkName n | (n,_,_) <- specs ] + +genMod :: [Spec] -> String +genMod specs = unlines $ + "-- This file is generated from CmmSwitchGen!" : + "{-# LANGUAGE MagicHash, NegativeLiterals #-}" : + "import Control.Monad (unless, forM_)" : + "import GHC.Exts" : + map genSwitch specs ++ + map genCheck specs ++ + [ genMain specs ] + +main = putStrLn $ + genMod $ zipWith (\n (s,v) -> (n,s,v)) names $ signedChecks ++ unsignedChecks + + +signedChecks :: [(Bool, [Integer])] +signedChecks = map (True,) + [ [1..10] + , [0..10] + , [1..3] + , [1..4] + , [1..5] + , [-1..10] + , [-10..10] + , [-20.. -10]++[0..10] + , [-20.. -10]++[1..10] + , [minS,0,maxS] + , [maxS-10 .. maxS] + , [minS..minS+10]++[maxS-10 .. maxS] + ] + +minU, maxU, minS, maxS :: Integer +minU = 0 +maxU = fromIntegral (maxBound :: Word) +minS = fromIntegral (minBound :: Int) +maxS = fromIntegral (maxBound :: Int) + + +unsignedChecks :: [(Bool, [Integer])] +unsignedChecks = map (False,) + [ [0..10] + , [1..10] + , [0] + , [0..1] + , [0..2] + , [0..3] + , [0..4] + , [1] + , [1..2] + , [1..3] + , [1..4] + , [1..5] + , [minU,maxU] + , [maxU-10 .. maxU] + , [minU..minU+10]++[maxU-10 .. maxU] + ] + +names :: [String] +names = [ c1:c2:[] | c1 <- ['a'..'z'], c2 <- ['a'..'z']] diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T index d193834c6b..15c3476cc5 100644 --- a/testsuite/tests/codeGen/should_run/all.T +++ b/testsuite/tests/codeGen/should_run/all.T @@ -127,3 +127,4 @@ test('T9013', omit_ways(['ghci']), # ghci doesn't support unboxed tuples compile_and_run, ['']) test('T9340', normal, compile_and_run, ['']) test('cgrun074', normal, compile_and_run, ['']) +test('CmmSwitchTest', when(fast(), skip), compile_and_run, ['']) diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 4a6ab3e49f..2963834650 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -391,7 +391,7 @@ test('T783', # 2014-09-03: 223377364 (Windows) better specialisation, raft of core-to-core optimisations # 2014-12-22: 235002220 (Windows) not sure why - (wordsize(64), 441932632, 10)]), + (wordsize(64), 719814352, 10)]), # prev: 349263216 (amd64/Linux) # 07/08/2012: 384479856 (amd64/Linux) # 29/08/2012: 436927840 (amd64/Linux) @@ -406,6 +406,10 @@ test('T783', # (general round of updates) # 2014-08-29: 441932632 (amd64/Linux) # (better specialisation, raft of core-to-core optimisations) + # 2014-08-29: 719814352 (amd64/Linux) + # (changed order of cmm block causes analyses to allocate much more, + # but the changed order is slighly better in terms of runtime, and + # this test seems to be an extreme outlier.) extra_hc_opts('-static') ], compile,['']) |