Refactor dumping of register allocator statistics.

parent ca9e6d1e
......@@ -20,6 +20,7 @@ import RegAllocInfo
import NCGMonad
import PositionIndependentCode
import RegAllocLinear
import RegAllocStats
import RegLiveness
import RegCoalesce
import qualified RegAllocColor as Color
......@@ -158,12 +159,11 @@ nativeCodeGen dflags cmms us
-> 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.
......@@ -256,7 +256,7 @@ data CmmNativeGenDump
, cdNative :: [NatCmmTop]
, cdLiveness :: [LiveCmmTop]
, cdCoalesce :: [LiveCmmTop]
, cdCodeGraphs :: [([LiveCmmTop], Color.Graph Reg RegClass Reg)]
, cdRegAllocStats :: [RegAllocStats]
, cdColoredGraph :: Maybe (Color.Graph Reg RegClass Reg)
, cdAlloced :: [NatCmmTop] }
......@@ -314,7 +314,7 @@ cmmNativeGen dflags cmm
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
......@@ -331,7 +331,7 @@ cmmNativeGen dflags cmm
coalesced <- regCoalesce withLiveness
-- graph coloring register allocation
(alloced, codeGraphs)
(alloced, regAllocStats)
<- Color.regAlloc
alloc_regs
(mkUniqSet [0..maxSpillSlots])
......@@ -340,7 +340,7 @@ cmmNativeGen dflags cmm
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
......@@ -384,7 +384,7 @@ cmmNativeGen dflags cmm
, cdNative = ppr_native
, cdLiveness = ppr_withLiveness
, cdCoalesce = ppr_coalesce
, cdCodeGraphs = ppr_codeGraphs
, cdRegAllocStats = ppr_regAllocStats
, cdColoredGraph = ppr_coloredGraph
, cdAlloced = ppr_alloced }
......
......@@ -20,11 +20,10 @@ module RegAllocColor (
where
#include "nativeGen/NCG.h"
import qualified GraphColor as Color
import RegLiveness
import RegSpill
import RegAllocStats
import MachRegs
import MachInstrs
import RegCoalesce
......@@ -56,8 +55,7 @@ regAlloc
-> [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
......@@ -100,22 +98,36 @@ regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
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
......@@ -251,81 +263,6 @@ patchRegsFromGraph graph code
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
......
-- 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
......@@ -13,6 +14,7 @@ import MachRegs
import MachInstrs
import Cmm
import State
import Unique
import UniqFM
import UniqSet
......@@ -36,8 +38,9 @@ regSpill
-> 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
......@@ -58,12 +61,13 @@ 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)
......@@ -133,9 +137,12 @@ spillRead regSlotMap instr reg
= 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"
......@@ -145,9 +152,12 @@ spillWrite regSlotMap instr 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"
......@@ -160,14 +170,18 @@ spillModify regSlotMap instr 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
......@@ -184,50 +198,58 @@ patchReg1 old new 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))
......@@ -3,29 +3,55 @@ module State where
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')
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment