Refactor cmmNativeGen so dumps can be emitted inline with NCG stages

parent ab676aa3
......@@ -81,7 +81,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs
; case hscTarget dflags of {
HscInterpreted -> return ();
HscAsm -> outputAsm dflags filenm this_mod location flat_abstractC;
HscAsm -> outputAsm dflags filenm flat_abstractC;
HscC -> outputC dflags filenm this_mod location
flat_abstractC stubs_exist pkg_deps
foreign_stubs;
......@@ -158,13 +158,13 @@ outputC dflags filenm mod location flat_absC
%************************************************************************
\begin{code}
outputAsm dflags filenm this_mod location flat_absC
outputAsm dflags filenm flat_absC
#ifndef OMIT_NATIVE_CODEGEN
= do ncg_uniqs <- mkSplitUniqSupply 'n'
ncg_output_d <- {-# SCC "NativeCodeGen" #-}
nativeCodeGen dflags this_mod location flat_absC ncg_uniqs
nativeCodeGen dflags flat_absC ncg_uniqs
dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" (docToSDoc ncg_output_d)
{-# SCC "OutputAsm" #-} doOutput filenm $
\f -> printDoc LeftMode f ncg_output_d
......
......@@ -102,7 +102,7 @@ data DynFlag
| Opt_D_dump_asm_regalloc
| Opt_D_dump_asm_regalloc_stages
| Opt_D_dump_asm_conflicts
| Opt_D_drop_asm_stats
| Opt_D_dump_asm_stats
| Opt_D_dump_cpranal
| Opt_D_dump_deriv
| Opt_D_dump_ds
......@@ -142,7 +142,7 @@ data DynFlag
| Opt_D_dump_minimal_imports
| Opt_D_dump_mod_cycles
| Opt_D_faststring_stats
| Opt_DumpToFile -- Redirect dump output to files instead of stdout.
| Opt_DumpToFile -- ^ Append dump output to files instead of stdout.
| Opt_DoCoreLinting
| Opt_DoStgLinting
| Opt_DoCmmLinting
......@@ -1028,7 +1028,7 @@ dynamic_flags = [
, ( "ddump-asm-conflicts", setDumpFlag Opt_D_dump_asm_conflicts)
, ( "ddump-asm-regalloc-stages",
setDumpFlag Opt_D_dump_asm_regalloc_stages)
, ( "ddrop-asm-stats", setDumpFlag Opt_D_drop_asm_stats)
, ( "ddump-asm-stats", setDumpFlag Opt_D_dump_asm_stats)
, ( "ddump-cpranal", setDumpFlag Opt_D_dump_cpranal)
, ( "ddump-deriv", setDumpFlag Opt_D_dump_deriv)
, ( "ddump-ds", setDumpFlag Opt_D_dump_ds)
......
......@@ -16,7 +16,7 @@ module ErrUtils (
ghcExit,
doIfSet, doIfSet_dyn,
dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc,
dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc, dumpSDoc,
-- * Messages during compilation
putMsg,
......@@ -199,13 +199,13 @@ dumpIfSet_core dflags flag hdr doc
| dopt flag dflags
|| verbosity dflags >= 4
|| dopt Opt_D_verbose_core2core dflags
= writeDump dflags flag (mkDumpDoc hdr doc)
= dumpSDoc dflags flag hdr doc
| otherwise = return ()
dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn dflags flag hdr doc
| dopt flag dflags || verbosity dflags >= 4
= writeDump dflags flag (mkDumpDoc hdr doc)
= dumpSDoc dflags flag hdr doc
| otherwise
= return ()
......@@ -228,11 +228,13 @@ mkDumpDoc hdr doc
-- | Write out a dump.
-- If --dump-to-file is set then this goes to a file.
-- otherwise emit to stdout.
writeDump :: DynFlags -> DynFlag -> SDoc -> IO ()
writeDump dflags dflag doc
dumpSDoc :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpSDoc dflags dflag hdr doc
= do let mFile = chooseDumpFile dflags dflag
case mFile of
-- write the dump to a file
-- don't add the header in this case, we can see what kind
-- of dump it is from the filename.
Just fileName
-> do handle <- openFile fileName AppendMode
hPrintDump handle doc
......@@ -240,7 +242,7 @@ writeDump dflags dflag doc
-- write the dump to stdout
Nothing
-> do printDump doc
-> do printDump (mkDumpDoc hdr doc)
-- | Choose where to put a dump file based on DynFlags
......
This diff is collapsed.
......@@ -63,7 +63,7 @@ regAlloc regsFree slotsFree code
<- regAlloc_spin 0 trivColorable regsFree slotsFree [] code
return ( code_final
, debug_codeGraphs )
, reverse debug_codeGraphs )
regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
= do
......@@ -84,6 +84,16 @@ regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
let fmLife = plusUFMs_C (\(r1, l1) (r2, l2) -> (r1, l1 + l2))
$ map lifetimeCount code
-- record startup state
let stat1 =
if spinCount == 0
then Just $ RegAllocStatsStart
{ raLiveCmm = code
, raGraph = graph
, raLifetimes = fmLife }
else Nothing
-- the function to choose regs to leave uncolored
let spill = chooseSpill_maxLife fmLife
......@@ -101,13 +111,11 @@ regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
-- record what happened in this stage for debugging
let stat =
RegAllocStatsColored
{ raLiveCmm = code
, raGraph = graph_colored
, raPatchedCmm = code_patched
, raLifetimes = fmLife }
{ raGraph = graph_colored
, raPatchedCmm = code_patched }
return ( code_nat
, debug_codeGraphs ++ [stat]
, maybeToList stat1 ++ [stat] ++ debug_codeGraphs
, graph_colored)
else do
......@@ -122,14 +130,14 @@ regAlloc_spin (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
-- record what happened in this stage for debugging
let stat =
RegAllocStatsSpill
{ raLiveCmm = code_spilled
, raGraph = graph_colored
{ raGraph = graph_colored
, raSpillStats = spillStats
, raLifetimes = fmLife }
, raLifetimes = fmLife
, raSpilled = code_spilled }
-- try again
regAlloc_spin (spinCount + 1) triv regsFree slotsFree'
(debug_codeGraphs ++ [stat])
(maybeToList stat1 ++ [stat] ++ debug_codeGraphs)
code_relive
......
......@@ -82,7 +82,7 @@ The algorithm is roughly:
module RegAllocLinear (
regAlloc,
RegAllocStats
RegAllocStats, pprStats
) where
#include "HsVersions.h"
......@@ -103,7 +103,7 @@ import Outputable
#ifndef DEBUG
import Data.Maybe ( fromJust )
#endif
import Data.List ( nub, partition, mapAccumL)
import Data.List ( nub, partition, mapAccumL, foldl')
import Control.Monad ( when )
import Data.Word
import Data.Bits
......@@ -1000,7 +1000,7 @@ getUniqueR = RegM $ \s ->
-- | Record that a spill instruction was inserted, for profiling.
recordSpill :: SpillReason -> RegM ()
recordSpill spill
= RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #)
= RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #)
-- -----------------------------------------------------------------------------
......@@ -1046,6 +1046,31 @@ binSpillReasons reasons
SpillJoinRM r -> (r, [0, 0, 0, 0, 1])) reasons)
-- | Pretty print some RegAllocStats
pprStats :: [RegAllocStats] -> SDoc
pprStats statss
= let spills = foldl' (plusUFM_C (zipWith (+)))
emptyUFM
$ map ra_spillInstrs statss
spillTotals = foldl' (zipWith (+))
[0, 0, 0, 0, 0]
$ eltsUFM spills
pprSpill (reg, spills)
= parens $ (hcat $ punctuate (text ", ") (doubleQuotes (ppr reg) : map ppr spills))
in ( text "-- spills-added-total"
$$ text "-- (allocs, clobbers, loads, joinRR, joinRM)"
$$ (parens $ (hcat $ punctuate (text ", ") (map ppr spillTotals)))
$$ text ""
$$ text "-- spills-added"
$$ text "-- (reg_name, allocs, clobbers, loads, joinRR, joinRM)"
$$ (vcat $ map pprSpill
$ ufmToList spills)
$$ text "")
-- -----------------------------------------------------------------------------
-- Utils
......
......@@ -6,6 +6,7 @@ module RegAllocStats (
RegAllocStats (..),
regDotColor,
pprStats,
pprStatsSpills,
pprStatsLifetimes,
pprStatsConflict,
......@@ -29,49 +30,64 @@ import Data.List
data RegAllocStats
-- initial graph
= RegAllocStatsStart
{ raLiveCmm :: [LiveCmmTop] -- ^ initial code, with liveness
, raGraph :: Color.Graph Reg RegClass Reg -- ^ the initial, uncolored graph
, raLifetimes :: UniqFM (Reg, Int) } -- ^ number of instrs each reg lives for
-- a spill stage
= RegAllocStatsSpill
{ raLiveCmm :: [LiveCmmTop] -- ^ code we tried to allocate regs for
, raGraph :: Color.Graph Reg RegClass Reg -- ^ the partially colored graph
| RegAllocStatsSpill
{ raGraph :: Color.Graph Reg RegClass Reg -- ^ the partially colored graph
, raSpillStats :: SpillStats -- ^ spiller stats
, raLifetimes :: UniqFM (Reg, Int) } -- ^ number of instrs each reg lives for
, raLifetimes :: UniqFM (Reg, Int) -- ^ number of instrs each reg lives for
, raSpilled :: [LiveCmmTop] } -- ^ code with spill instructions added
-- 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
, raLifetimes :: UniqFM (Reg, Int) } -- ^ number of instrs each reg lives for
{ raGraph :: Color.Graph Reg RegClass Reg -- ^ the colored graph
, raPatchedCmm :: [LiveCmmTop] } -- ^ code after register allocation
instance Outputable RegAllocStats where
ppr (s@RegAllocStatsSpill{})
= text "-- Spill"
$$ text "-- Native code with liveness information."
ppr (s@RegAllocStatsStart{})
= text "# Start"
$$ text "# Native code with liveness information."
$$ ppr (raLiveCmm s)
$$ text " "
$$ text "-- Register conflict graph."
$$ text ""
$$ text "# Initial register conflict graph."
$$ Color.dotGraph regDotColor trivColorable (raGraph s)
$$ text "-- Spill statistics."
ppr (s@RegAllocStatsSpill{})
= text "# Spill"
$$ text "# Register conflict graph."
$$ Color.dotGraph regDotColor trivColorable (raGraph s)
$$ text ""
$$ text "# Spills inserted."
$$ ppr (raSpillStats s)
$$ text ""
$$ text "# Code with spills inserted."
$$ (ppr (raSpilled s))
ppr (s@RegAllocStatsColored{})
= text "-- Colored"
= text "# Colored"
$$ text "# Register conflict graph."
$$ Color.dotGraph regDotColor trivColorable (raGraph s)
$$ text ""
$$ text "# Native code after register allocation."
$$ ppr (raPatchedCmm s)
$$ text "-- Native code with liveness information."
$$ ppr (raLiveCmm s)
$$ text " "
$$ text "-- Register conflict graph."
$$ Color.dotGraph regDotColor trivColorable (raGraph s)
-- | Do all the different analysis on this list of RegAllocStats
pprStats :: [RegAllocStats] -> Color.Graph Reg RegClass Reg -> SDoc
pprStats stats graph
= let outSpills = pprStatsSpills stats
outLife = pprStatsLifetimes stats
outConflict = pprStatsConflict stats
outScatter = pprStatsLifeConflict stats graph
$$ text "-- Native code after register allocation."
$$ ppr (raPatchedCmm s)
in vcat [outSpills, outLife, outConflict, outScatter]
-- | Dump a table of how many spill loads / stores were inserted for each vreg.
......@@ -83,27 +99,37 @@ pprStatsSpills stats
spillStats = [ s | s@RegAllocStatsSpill{} <- stats]
-- build a map of how many spill load/stores were inserted for each vreg
spillLS = foldl' (plusUFM_C accSpillLS) emptyUFM
$ map (spillLoadStore . raSpillStats) spillStats
spillSL = foldl' (plusUFM_C accSpillSL) emptyUFM
$ map (spillStoreLoad . raSpillStats) spillStats
-- print the count of load/spills as a tuple so we can read back from the file easilly
pprSpillLS (r, loads, stores)
pprSpillSL (r, loads, stores)
= (parens $ (hcat $ punctuate (text ", ") [doubleQuotes (ppr r), int loads, int stores]))
-- sum up the total number of spill instructions inserted
spillList = eltsUFM spillSL
spillTotal = foldl' (\(s1, l1) (s2, l2) -> (s1 + s2, l1 + l2))
(0, 0)
$ map (\(n, s, l) -> (s, l))
$ spillList
in ( text "-- spills-added"
$$ text "-- (reg_name, spill_loads_added, spill_stores_added)."
$$ (vcat $ map pprSpillLS $ eltsUFM spillLS)
$$ text "\n")
in ( text "-- spills-added-total"
$$ text "-- (stores, loads)"
$$ (ppr spillTotal)
$$ text ""
$$ text "-- spills-added"
$$ text "-- (reg_name, stores, loads)"
$$ (vcat $ map pprSpillSL $ spillList)
$$ text "")
-- | Dump a table of how long vregs tend to live for.
-- | Dump a table of how long vregs tend to live for in the initial code.
pprStatsLifetimes
:: [RegAllocStats] -> SDoc
pprStatsLifetimes stats
= let lifeMap = foldl' plusUFM emptyUFM $ map raLifetimes stats
= let lifeMap = foldl' plusUFM emptyUFM
[ raLifetimes s | s@RegAllocStatsStart{} <- stats ]
lifeBins = binLifetimeCount lifeMap
in ( text "-- vreg-population-lifetimes"
......@@ -123,7 +149,7 @@ binLifetimeCount fm
lifes
-- | Dump a table of how many conflicts vregs tend to have.
-- | Dump a table of how many conflicts vregs tend to have in the initial code.
pprStatsConflict
:: [RegAllocStats] -> SDoc
......@@ -131,7 +157,7 @@ pprStatsConflict stats
= let confMap = foldl' (plusUFM_C (\(c1, n1) (c2, n2) -> (c1, n1 + n2)))
emptyUFM
$ map Color.slurpNodeConflictCount
$ map raGraph stats
[ raGraph s | s@RegAllocStatsStart{} <- stats ]
in ( text "-- vreg-conflicts"
$$ text "-- (conflict_count, number_of_vregs_that_had_that_many_conflicts)"
......@@ -142,10 +168,14 @@ pprStatsConflict stats
-- | For every vreg, dump it's how many conflicts it has and its lifetime
-- good for making a scatter plot.
pprStatsLifeConflict
:: [RegAllocStats] -> Color.Graph Reg RegClass Reg -> SDoc
:: [RegAllocStats]
-> Color.Graph Reg RegClass Reg -- ^ global register conflict graph
-> SDoc
pprStatsLifeConflict stats graph
= let lifeMap = foldl' plusUFM emptyUFM $ map raLifetimes stats
= let lifeMap = foldl' plusUFM emptyUFM
[ raLifetimes s | s@RegAllocStatsStart{} <- stats ]
scatter = map (\r -> let Just (_, lifetime) = lookupUFM lifeMap r
Just node = Color.lookupNode graph r
in parens $ hcat $ punctuate (text ", ")
......
......@@ -2,7 +2,7 @@
module RegSpill (
regSpill,
SpillStats(..),
accSpillLS
accSpillSL
)
where
......@@ -142,7 +142,7 @@ spillRead regSlotMap instr reg
, mkLoadInstr nReg delta slot ]
modify $ \s -> s
{ stateSpillLS = addToUFM_C accSpillLS (stateSpillLS s) reg (reg, 1, 0) }
{ stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) }
return ( instr', (pre, []))
......@@ -157,7 +157,7 @@ spillWrite regSlotMap instr reg
, mkSpillInstr nReg delta slot ]
modify $ \s -> s
{ stateSpillLS = addToUFM_C accSpillLS (stateSpillLS s) reg (reg, 0, 1) }
{ stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) }
return ( instr', ([], post))
......@@ -175,7 +175,7 @@ spillModify regSlotMap instr reg
, mkSpillInstr nReg delta slot ]
modify $ \s -> s
{ stateSpillLS = addToUFM_C accSpillLS (stateSpillLS s) reg (reg, 1, 1) }
{ stateSpillSL = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) }
return ( instr', (pre, post))
......@@ -206,13 +206,13 @@ data SpillS
= SpillS
{ stateDelta :: Int
, stateUS :: UniqSupply
, stateSpillLS :: UniqFM (Reg, Int, Int) } -- ^ spilled reg vs number of times vreg was loaded, stored
, stateSpillSL :: UniqFM (Reg, Int, Int) } -- ^ spilled reg vs number of times vreg was loaded, stored
initSpillS uniqueSupply
= SpillS
{ stateDelta = 0
, stateUS = uniqueSupply
, stateSpillLS = emptyUFM }
, stateSpillSL = emptyUFM }
type SpillM a = State SpillS a
......@@ -232,8 +232,8 @@ newUnique
modify $ \s -> s { stateUS = us2 }
return uniq
accSpillLS (r1, l1, s1) (r2, l2, s2)
= (r1, l1 + l2, s1 + s2)
accSpillSL (r1, s1, l1) (r2, s2, l2)
= (r1, s1 + s2, l1 + l2)
......@@ -242,15 +242,15 @@ accSpillLS (r1, l1, s1) (r2, l2, s2)
data SpillStats
= SpillStats
{ spillLoadStore :: UniqFM (Reg, Int, Int) }
{ spillStoreLoad :: UniqFM (Reg, Int, Int) }
makeSpillStats :: SpillS -> SpillStats
makeSpillStats s
= SpillStats
{ spillLoadStore = stateSpillLS s }
{ spillStoreLoad = stateSpillSL s }
instance Outputable SpillStats where
ppr s
= (vcat $ map (\(r, l, s) -> ppr r <+> int l <+> int s)
$ eltsUFM (spillLoadStore s))
ppr stats
= (vcat $ map (\(r, s, l) -> ppr r <+> int s <+> int l)
$ eltsUFM (spillStoreLoad stats))
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