module GHC.CmmToAsm.Reg.Graph.Stats (
RegAllocStats (..),
pprStats,
pprStatsSpills,
pprStatsLifetimes,
pprStatsConflict,
pprStatsLifeConflict,
countSRMs, addSRM
) where
import GHC.Prelude
import qualified GHC.Data.Graph.Color as Color
import GHC.CmmToAsm.Reg.Liveness
import GHC.CmmToAsm.Reg.Graph.Spill
import GHC.CmmToAsm.Reg.Graph.SpillCost
import GHC.CmmToAsm.Reg.Graph.TrivColorable
import GHC.CmmToAsm.Instr
import GHC.Platform.Reg.Class
import GHC.Platform.Reg
import GHC.CmmToAsm.Reg.Target
import GHC.Platform
import GHC.Utils.Outputable
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import GHC.Utils.Monad.State
data RegAllocStats statics instr
= RegAllocStatsStart
{
raLiveCmm :: [LiveCmmDecl statics instr]
, raGraph :: Color.Graph VirtualReg RegClass RealReg
, raSpillCosts :: SpillCostInfo
, raPlatform :: !Platform
}
| RegAllocStatsSpill
{
raCode :: [LiveCmmDecl statics instr]
, raGraph :: Color.Graph VirtualReg RegClass RealReg
, raCoalesced :: UniqFM VirtualReg VirtualReg
, raSpillStats :: SpillStats
, raSpillCosts :: SpillCostInfo
, raSpilled :: [LiveCmmDecl statics instr]
, raPlatform :: !Platform
}
| RegAllocStatsColored
{
raCode :: [LiveCmmDecl statics instr]
, raGraph :: Color.Graph VirtualReg RegClass RealReg
, raGraphColored :: Color.Graph VirtualReg RegClass RealReg
, raCoalesced :: UniqFM VirtualReg VirtualReg
, raCodeCoalesced :: [LiveCmmDecl statics instr]
, raPatched :: [LiveCmmDecl statics instr]
, raSpillClean :: [LiveCmmDecl statics instr]
, raFinal :: [NatCmmDecl statics instr]
, raSRMs :: (Int, Int, Int)
, raPlatform :: !Platform
}
instance (Outputable statics, Outputable instr)
=> Outputable (RegAllocStats statics instr) where
ppr (s@RegAllocStatsStart{})
= text "# Start"
$$ text "# Native code with liveness information."
$$ ppr (raLiveCmm s)
$$ text ""
$$ text "# Initial register conflict graph."
$$ Color.dotGraph
(targetRegDotColor (raPlatform s))
(trivColorable (raPlatform s)
(targetVirtualRegSqueeze (raPlatform s))
(targetRealRegSqueeze (raPlatform s)))
(raGraph s)
ppr (s@RegAllocStatsSpill{}) =
text "# Spill"
$$ text "# Code with liveness information."
$$ ppr (raCode s)
$$ text ""
$$ (if (not $ isNullUFM $ raCoalesced s)
then text "# Registers coalesced."
$$ pprUFMWithKeys (raCoalesced s) (vcat . map ppr)
$$ text ""
else empty)
$$ text "# Spills inserted."
$$ ppr (raSpillStats s)
$$ text ""
$$ text "# Code with spills inserted."
$$ ppr (raSpilled s)
ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) })
= text "# Colored"
$$ text "# Code with liveness information."
$$ ppr (raCode s)
$$ text ""
$$ text "# Register conflict graph (colored)."
$$ Color.dotGraph
(targetRegDotColor (raPlatform s))
(trivColorable (raPlatform s)
(targetVirtualRegSqueeze (raPlatform s))
(targetRealRegSqueeze (raPlatform s)))
(raGraphColored s)
$$ text ""
$$ (if (not $ isNullUFM $ raCoalesced s)
then text "# Registers coalesced."
$$ pprUFMWithKeys (raCoalesced s) (vcat . map ppr)
$$ text ""
else empty)
$$ text "# Native code after coalescings applied."
$$ ppr (raCodeCoalesced s)
$$ text ""
$$ text "# Native code after register allocation."
$$ ppr (raPatched s)
$$ text ""
$$ text "# Clean out unneeded spill/reloads."
$$ ppr (raSpillClean s)
$$ text ""
$$ text "# Final code, after rewriting spill/rewrite pseudo instrs."
$$ ppr (raFinal s)
$$ text ""
$$ text "# Score:"
$$ (text "# spills inserted: " <> int spills)
$$ (text "# reloads inserted: " <> int reloads)
$$ (text "# reg-reg moves remaining: " <> int moves)
$$ text ""
pprStats
:: [RegAllocStats statics instr]
-> Color.Graph VirtualReg RegClass RealReg
-> SDoc
pprStats stats graph
= let outSpills = pprStatsSpills stats
outLife = pprStatsLifetimes stats
outConflict = pprStatsConflict stats
outScatter = pprStatsLifeConflict stats graph
in vcat [outSpills, outLife, outConflict, outScatter]
pprStatsSpills
:: [RegAllocStats statics instr] -> SDoc
pprStatsSpills stats
= let
finals = [ s | s@RegAllocStatsColored{} <- stats]
total = foldl' addSRM (0, 0, 0)
$ map raSRMs finals
in ( text "-- spills-added-total"
$$ text "-- (stores, loads, reg_reg_moves_remaining)"
$$ ppr total
$$ text "")
pprStatsLifetimes
:: [RegAllocStats statics instr] -> SDoc
pprStatsLifetimes stats
= let info = foldl' plusSpillCostInfo zeroSpillCostInfo
[ raSpillCosts s
| s@RegAllocStatsStart{} <- stats ]
lifeBins = binLifetimeCount $ lifeMapFromSpillCostInfo info
in ( text "-- vreg-population-lifetimes"
$$ text "-- (instruction_count, number_of_vregs_that_lived_that_long)"
$$ pprUFM lifeBins (vcat . map ppr)
$$ text "\n")
binLifetimeCount :: UniqFM VirtualReg (VirtualReg, Int) -> UniqFM Int (Int, Int)
binLifetimeCount fm
= let lifes = map (\l -> (l, (l, 1)))
$ map snd
$ nonDetEltsUFM fm
in addListToUFM_C
(\(l1, c1) (_, c2) -> (l1, c1 + c2))
emptyUFM
lifes
pprStatsConflict
:: [RegAllocStats statics instr] -> SDoc
pprStatsConflict stats
= let confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2)))
emptyUFM
$ map Color.slurpNodeConflictCount
[ raGraph s | s@RegAllocStatsStart{} <- stats ]
in ( text "-- vreg-conflicts"
$$ text "-- (conflict_count, number_of_vregs_that_had_that_many_conflicts)"
$$ pprUFM confMap (vcat . map ppr)
$$ text "\n")
pprStatsLifeConflict
:: [RegAllocStats statics instr]
-> Color.Graph VirtualReg RegClass RealReg
-> SDoc
pprStatsLifeConflict stats graph
= let lifeMap = lifeMapFromSpillCostInfo
$ foldl' plusSpillCostInfo zeroSpillCostInfo
$ [ raSpillCosts s | s@RegAllocStatsStart{} <- stats ]
scatter = map (\r -> let lifetime = case lookupUFM lifeMap r of
Just (_, l) -> l
Nothing -> 0
Just node = Color.lookupNode graph r
in parens $ hcat $ punctuate (text ", ")
[ doubleQuotes $ ppr $ Color.nodeId node
, ppr $ sizeUniqSet (Color.nodeConflicts node)
, ppr $ lifetime ])
$ map Color.nodeId
$ nonDetEltsUFM
$ Color.graphMap graph
in ( text "-- vreg-conflict-lifetime"
$$ text "-- (vreg, vreg_conflicts, vreg_lifetime)"
$$ (vcat scatter)
$$ text "\n")
countSRMs
:: Instruction instr
=> LiveCmmDecl statics instr -> (Int, Int, Int)
countSRMs cmm
= execState (mapBlockTopM countSRM_block cmm) (0, 0, 0)
countSRM_block
:: Instruction instr
=> GenBasicBlock (LiveInstr instr)
-> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr))
countSRM_block (BasicBlock i instrs)
= do instrs' <- mapM countSRM_instr instrs
return $ BasicBlock i instrs'
countSRM_instr
:: Instruction instr
=> LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr)
countSRM_instr li
| LiveInstr SPILL{} _ <- li
= do modify $ \(s, r, m) -> (s + 1, r, m)
return li
| LiveInstr RELOAD{} _ <- li
= do modify $ \(s, r, m) -> (s, r + 1, m)
return li
| LiveInstr instr _ <- li
, Just _ <- takeRegRegMoveInstr instr
= do modify $ \(s, r, m) -> (s, r, m + 1)
return li
| otherwise
= return li
addSRM :: (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int)
addSRM (s1, r1, m1) (s2, r2, m2)
= let !s = s1 + s2
!r = r1 + r2
!m = m1 + m2
in (s, r, m)