import NCGMonad
import PositionIndependentCode
import RegAllocLinear
+import RegAllocStats
import RegLiveness
import RegCoalesce
import qualified RegAllocColor as Color
-> dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc_stages
"(asm-regalloc-stages)"
- (vcat $ map (\(stage, (code, graph)) ->
- ( text "-- Stage " <> int stage
- $$ ppr code
- $$ Color.dotGraph Color.regDotColor trivColorable graph))
+ (vcat $ map (\(stage, stats) ->
+ text "-- Stage " <> int stage
+ $$ ppr stats)
(zip [0..] codeGraphs)))
- $ map cdCodeGraphs dump
+ $ map cdRegAllocStats dump
-- Build a global register conflict graph.
-- If you want to see the graph for just one basic block then use asm-regalloc-stages instead.
, cdNative :: [NatCmmTop]
, cdLiveness :: [LiveCmmTop]
, cdCoalesce :: [LiveCmmTop]
- , cdCodeGraphs :: [([LiveCmmTop], Color.Graph Reg RegClass Reg)]
+ , cdRegAllocStats :: [RegAllocStats]
, cdColoredGraph :: Maybe (Color.Graph Reg RegClass Reg)
, cdAlloced :: [NatCmmTop] }
native
---- allocate registers
- (alloced, ppr_alloced, ppr_coalesce, ppr_codeGraphs, ppr_coloredGraph)
+ (alloced, ppr_alloced, ppr_coalesce, ppr_regAllocStats, ppr_coloredGraph)
<- (\withLiveness
-> {-# SCC "regAlloc" #-}
do
coalesced <- regCoalesce withLiveness
-- graph coloring register allocation
- (alloced, codeGraphs)
+ (alloced, regAllocStats)
<- Color.regAlloc
alloc_regs
(mkUniqSet [0..maxSpillSlots])
return ( alloced
, dchoose dflags Opt_D_dump_asm_regalloc alloced []
, dchoose dflags Opt_D_dump_asm_coalesce coalesced []
- , dchoose dflags Opt_D_dump_asm_regalloc_stages codeGraphs []
+ , dchoose dflags Opt_D_dump_asm_regalloc_stages regAllocStats []
, dchoose dflags Opt_D_dump_asm_conflicts Nothing Nothing)
else do
, cdNative = ppr_native
, cdLiveness = ppr_withLiveness
, cdCoalesce = ppr_coalesce
- , cdCodeGraphs = ppr_codeGraphs
+ , cdRegAllocStats = ppr_regAllocStats
, cdColoredGraph = ppr_coloredGraph
, cdAlloced = ppr_alloced }
where
-#include "nativeGen/NCG.h"
-
import qualified GraphColor as Color
import RegLiveness
import RegSpill
+import RegAllocStats
import MachRegs
import MachInstrs
import RegCoalesce
-> [LiveCmmTop] -- ^ code annotated with liveness information.
-> UniqSM
( [NatCmmTop] -- ^ code with registers allocated.
- , [ ( [LiveCmmTop]
- , Color.Graph Reg RegClass Reg) ]) -- ^ code and graph for each pass
+ , [RegAllocStats] ) -- ^ stats for each stage of allocation
regAlloc regsFree slotsFree code
= do
let code_patched = map (patchRegsFromGraph graph_colored) code
let code_nat = map stripLive code_patched
+ -- record what happened in this stage for debugging
+ let stat =
+ RegAllocStatsColored
+ { raLiveCmm = code
+ , raGraph = graph_colored
+ , raPatchedCmm = code_patched }
+
return ( code_nat
- , debug_codeGraphs ++ [(code, graph_colored), (code_patched, graph_colored)]
+ , debug_codeGraphs ++ [stat]
, graph_colored)
else do
-- spill the uncolored regs
- (code_spilled, slotsFree')
+ (code_spilled, slotsFree', spillStats)
<- regSpill code slotsFree rsSpill
-- recalculate liveness
let code_nat = map stripLive code_spilled
code_relive <- mapM regLiveness code_nat
+
+ -- record what happened in this stage for debugging
+ let stat =
+ RegAllocStatsSpill
+ { raLiveCmm = code_spilled
+ , raGraph = graph_colored
+ , raSpillStats = spillStats }
-- try again
regAlloc_spin (spinCount + 1) triv regsFree slotsFree'
- (debug_codeGraphs ++ [(code, graph_colored)])
+ (debug_codeGraphs ++ [stat])
code_relive
in patchEraseLive patchF code
------
--- Register colors for drawing conflict graphs
--- Keep this out of MachRegs.hs because it's specific to the graph coloring allocator.
-
-
--- reg colors for x86
-#if i386_TARGET_ARCH
-regDotColor :: Reg -> SDoc
-regDotColor reg
- = let Just str = lookupUFM regColors reg
- in text str
-
-regColors
- = listToUFM
- $ [ (eax, "#00ff00")
- , (ebx, "#0000ff")
- , (ecx, "#00ffff")
- , (edx, "#0080ff")
-
- , (fake0, "#ff00ff")
- , (fake1, "#ff00aa")
- , (fake2, "#aa00ff")
- , (fake3, "#aa00aa")
- , (fake4, "#ff0055")
- , (fake5, "#5500ff") ]
-#endif
-
-
--- reg colors for x86_64
-#if x86_64_TARGET_ARCH
-regDotColor :: Reg -> SDoc
-regDotColor reg
- = let Just str = lookupUFM regColors reg
- in text str
-
-regColors
- = listToUFM
- $ [ (rax, "#00ff00"), (eax, "#00ff00")
- , (rbx, "#0000ff"), (ebx, "#0000ff")
- , (rcx, "#00ffff"), (ecx, "#00ffff")
- , (rdx, "#0080ff"), (edx, "#00ffff")
- , (r8, "#00ff80")
- , (r9, "#008080")
- , (r10, "#0040ff")
- , (r11, "#00ff40")
- , (r12, "#008040")
- , (r13, "#004080")
- , (r14, "#004040")
- , (r15, "#002080") ]
-
- ++ zip (map RealReg [16..31]) (repeat "red")
-#endif
-
-
--- reg colors for ppc
-#if powerpc_TARGET_ARCH
-regDotColor :: Reg -> SDoc
-regDotColor reg
- = case regClass reg of
- RcInteger -> text "blue"
- RcFloat -> text "red"
-#endif
-
-
-{-
-toX11Color (r, g, b)
- = let rs = padL 2 '0' (showHex r "")
- gs = padL 2 '0' (showHex r "")
- bs = padL 2 '0' (showHex r "")
-
- padL n c s
- = replicate (n - length s) c ++ s
- in "#" ++ rs ++ gs ++ bs
--}
-
plusUFMs_C :: (elt -> elt -> elt) -> [UniqFM elt] -> UniqFM elt
plusUFMs_C f maps
= foldl (plusUFM_C f) emptyUFM maps
--- /dev/null
+
+-- Carries interesting info for debugging / profiling of the
+-- graph coloring register allocator.
+
+module RegAllocStats (
+ RegAllocStats (..),
+ regDotColor
+)
+
+where
+
+#include "nativeGen/NCG.h"
+
+import qualified GraphColor as Color
+import RegLiveness
+import RegSpill
+import MachRegs
+
+import Outputable
+import UniqFM
+
+
+data RegAllocStats
+
+ -- a spill stage
+ = RegAllocStatsSpill
+ { raLiveCmm :: [LiveCmmTop] -- ^ code we tried to allocate regs for
+ , raGraph :: Color.Graph Reg RegClass Reg -- ^ the partially colored graph
+ , raSpillStats :: SpillStats } -- ^ spiller stats
+
+ -- a successful coloring
+ | RegAllocStatsColored
+ { raLiveCmm :: [LiveCmmTop] -- ^ the code we allocated regs for
+ , raGraph :: Color.Graph Reg RegClass Reg -- ^ the colored graph
+ , raPatchedCmm :: [LiveCmmTop] } -- ^ code with register allocation
+
+
+instance Outputable RegAllocStats where
+
+ ppr (s@RegAllocStatsSpill{})
+ = text "-- Spill"
+
+ $$ text "-- Native code with liveness information."
+ $$ ppr (raLiveCmm s)
+ $$ text " "
+
+ $$ text "-- Register conflict graph."
+ $$ Color.dotGraph regDotColor trivColorable (raGraph s)
+
+ $$ text "-- Spill statistics."
+ $$ ppr (raSpillStats s)
+
+
+ ppr (s@RegAllocStatsColored{})
+ = text "-- Colored"
+
+ $$ text "-- Native code with liveness information."
+ $$ ppr (raLiveCmm s)
+ $$ text " "
+
+ $$ text "-- Register conflict graph."
+ $$ Color.dotGraph regDotColor trivColorable (raGraph s)
+
+ $$ text "-- Native code after register allocation."
+ $$ ppr (raPatchedCmm s)
+
+
+-----
+-- Register colors for drawing conflict graphs
+-- Keep this out of MachRegs.hs because it's specific to the graph coloring allocator.
+
+
+-- reg colors for x86
+#if i386_TARGET_ARCH
+regDotColor :: Reg -> SDoc
+regDotColor reg
+ = let Just str = lookupUFM regColors reg
+ in text str
+
+regColors
+ = listToUFM
+ $ [ (eax, "#00ff00")
+ , (ebx, "#0000ff")
+ , (ecx, "#00ffff")
+ , (edx, "#0080ff")
+
+ , (fake0, "#ff00ff")
+ , (fake1, "#ff00aa")
+ , (fake2, "#aa00ff")
+ , (fake3, "#aa00aa")
+ , (fake4, "#ff0055")
+ , (fake5, "#5500ff") ]
+#endif
+
+
+-- reg colors for x86_64
+#if x86_64_TARGET_ARCH
+regDotColor :: Reg -> SDoc
+regDotColor reg
+ = let Just str = lookupUFM regColors reg
+ in text str
+
+regColors
+ = listToUFM
+ $ [ (rax, "#00ff00"), (eax, "#00ff00")
+ , (rbx, "#0000ff"), (ebx, "#0000ff")
+ , (rcx, "#00ffff"), (ecx, "#00ffff")
+ , (rdx, "#0080ff"), (edx, "#00ffff")
+ , (r8, "#00ff80")
+ , (r9, "#008080")
+ , (r10, "#0040ff")
+ , (r11, "#00ff40")
+ , (r12, "#008040")
+ , (r13, "#004080")
+ , (r14, "#004040")
+ , (r15, "#002080") ]
+
+ ++ zip (map RealReg [16..31]) (repeat "red")
+#endif
+
+
+-- reg colors for ppc
+#if powerpc_TARGET_ARCH
+regDotColor :: Reg -> SDoc
+regDotColor reg
+ = case regClass reg of
+ RcInteger -> text "blue"
+ RcFloat -> text "red"
+#endif
+
+
+{-
+toX11Color (r, g, b)
+ = let rs = padL 2 '0' (showHex r "")
+ gs = padL 2 '0' (showHex r "")
+ bs = padL 2 '0' (showHex r "")
+
+ padL n c s
+ = replicate (n - length s) c ++ s
+ in "#" ++ rs ++ gs ++ bs
+-}
module RegSpill (
- regSpill
+ regSpill,
+ SpillStats(..)
)
where
import MachInstrs
import Cmm
+import State
import Unique
import UniqFM
import UniqSet
-> UniqSet Int -- ^ available stack slots
-> UniqSet Reg -- ^ the regs to spill
-> UniqSM
- ([LiveCmmTop] -- ^ code will spill instructions
- , UniqSet Int) -- ^ left over slots
+ ([LiveCmmTop] -- code will spill instructions
+ , UniqSet Int -- left over slots
+ , SpillStats ) -- stats about what happened during spilling
regSpill code slotsFree regs
us <- getUs
-- run the spiller on all the blocks
- let (# code', _ #) =
- runSpill (mapM (mapBlockTopM (regSpill_block regSlotMap)) code)
+ let (code', state') =
+ runState (mapM (mapBlockTopM (regSpill_block regSlotMap)) code)
(initSpillS us)
return ( code'
- , minusUniqSet slotsFree (mkUniqSet slots) )
+ , minusUniqSet slotsFree (mkUniqSet slots)
+ , makeSpillStats state')
regSpill_block regSlotMap (BasicBlock i instrs)
= do delta <- getDelta
(instr', nReg) <- patchInstr reg instr
- let pre = [ COMMENT FSLIT("spill read")
+ let pre = [ COMMENT FSLIT("spill load")
, mkLoadInstr nReg delta slot ]
+ modify $ \s -> s
+ { stateSpillLS = addToUFM_C accSpillLS (stateSpillLS s) reg (reg, 1, 0) }
+
return ( instr', (pre, []))
| otherwise = panic "RegSpill.spillRead: no slot defined for spilled reg"
= do delta <- getDelta
(instr', nReg) <- patchInstr reg instr
- let post = [ COMMENT FSLIT("spill write")
+ let post = [ COMMENT FSLIT("spill store")
, mkSpillInstr nReg delta slot ]
+ modify $ \s -> s
+ { stateSpillLS = addToUFM_C accSpillLS (stateSpillLS s) reg (reg, 0, 1) }
+
return ( instr', ([], post))
| otherwise = panic "RegSpill.spillWrite: no slot defined for spilled reg"
let pre = [ COMMENT FSLIT("spill mod load")
, mkLoadInstr nReg delta slot ]
- let post = [ COMMENT FSLIT("spill mod write")
+ let post = [ COMMENT FSLIT("spill mod store")
, mkSpillInstr nReg delta slot ]
+ modify $ \s -> s
+ { stateSpillLS = addToUFM_C accSpillLS (stateSpillLS s) reg (reg, 1, 1) }
+
return ( instr', (pre, post))
| otherwise = panic "RegSpill.spillModify: no slot defined for spilled reg"
+
-- | rewrite uses of this virtual reg in an instr to use a different virtual reg
patchInstr :: Reg -> Instr -> SpillM (Instr, Reg)
patchInstr reg instr
in patchRegs instr patchF
--------------------------------------------------------------------------------------------
+------------------------------------------------------
-- Spiller monad
data SpillS
= SpillS
{ stateDelta :: Int
- , stateUS :: UniqSupply }
+ , stateUS :: UniqSupply
+ , stateSpillLS :: UniqFM (Reg, Int, Int) } -- ^ spilled reg vs number of times vreg was loaded, stored
initSpillS uniqueSupply
= SpillS
{ stateDelta = 0
- , stateUS = uniqueSupply }
+ , stateUS = uniqueSupply
+ , stateSpillLS = emptyUFM }
-newtype SpillM a
- = SpillM
- { runSpill :: SpillS -> (# a, SpillS #) }
-
-instance Monad SpillM where
- return x = SpillM $ \s -> (# x, s #)
-
- m >>= n = SpillM $ \s ->
- case runSpill m s of
- (# r, s' #) -> runSpill (n r) s'
+type SpillM a = State SpillS a
setDelta :: Int -> SpillM ()
setDelta delta
- = SpillM $ \s -> (# (), s { stateDelta = delta } #)
+ = modify $ \s -> s { stateDelta = delta }
getDelta :: SpillM Int
-getDelta = SpillM $ \s -> (# stateDelta s, s #)
+getDelta = gets stateDelta
newUnique :: SpillM Unique
newUnique
- = SpillM $ \s
- -> case splitUniqSupply (stateUS s) of
- (us1, us2)
- -> (# uniqFromSupply us1
- , s { stateUS = us2 } #)
-
-mapAccumLM _ s [] = return (s, [])
-mapAccumLM f s (x:xs)
- = do
- (s1, x') <- f s x
- (s2, xs') <- mapAccumLM f s1 xs
- return (s2, x' : xs')
+ = do us <- gets stateUS
+ case splitUniqSupply us of
+ (us1, us2)
+ -> do let uniq = uniqFromSupply us1
+ modify $ \s -> s { stateUS = us2 }
+ return uniq
+
+accSpillLS (r1, l1, s1) (r2, l2, s2)
+ = (r1, l1 + l2, s1 + s2)
+
+
+
+----------------------------------------------------
+-- Spiller stats
+
+data SpillStats
+ = SpillStats
+ { spillLoadStore :: UniqFM (Reg, Int, Int) }
+
+makeSpillStats :: SpillS -> SpillStats
+makeSpillStats s
+ = SpillStats
+ { spillLoadStore = stateSpillLS s }
+instance Outputable SpillStats where
+ ppr s
+ = (vcat $ map (\(r, l, s) -> ppr r <+> int l <+> int s)
+ $ eltsUFM (spillLoadStore s))
newtype State s a
= State
- { runState :: s -> (# a, s #) }
+ { runState' :: s -> (# a, s #) }
instance Monad (State s) where
return x = State $ \s -> (# x, s #)
m >>= n = State $ \s ->
- case runState m s of
- (# r, s' #) -> runState (n r) s'
+ case runState' m s of
+ (# r, s' #) -> runState' (n r) s'
get :: State s s
get = State $ \s -> (# s, s #)
+gets :: (s -> a) -> State s a
+gets f = State $ \s -> (# f s, s #)
+
put :: s -> State s ()
put s' = State $ \s -> (# (), s' #)
modify :: (s -> s) -> State s ()
modify f = State $ \s -> (# (), f s #)
+
evalState :: State s a -> s -> a
evalState s i
- = case runState s i of
+ = case runState' s i of
(# a, s' #) -> a
+
execState :: State s a -> s -> s
execState s i
- = case runState s i of
+ = case runState' s i of
(# a, s' #) -> s'
+
+
+runState :: State s a -> s -> (a, s)
+runState s i
+ = case runState' s i of
+ (# a, s' #) -> (a, s')
+
+
+mapAccumLM
+ :: Monad m
+ => (acc -> x -> m (acc, y)) -- ^ combining funcction
+ -> acc -- ^ initial state
+ -> [x] -- ^ inputs
+ -> m (acc, [y]) -- ^ final state, outputs
+
+mapAccumLM _ s [] = return (s, [])
+mapAccumLM f s (x:xs)
+ = do
+ (s1, x') <- f s x
+ (s2, xs') <- mapAccumLM f s1 xs
+ return (s2, x' : xs')
projects / ghc-hetmet.git / commitdiff