{-# LANGUAGE BangPatterns, CPP #-}

-- | Carries interesting info for debugging / profiling of the
--   graph coloring register allocator.
module RegAlloc.Graph.Stats (
        RegAllocStats (..),

        pprStats,
        pprStatsSpills,
        pprStatsLifetimes,
        pprStatsConflict,
        pprStatsLifeConflict,

        countSRMs, addSRM
) where

#include "nativeGen/NCG.h"

import GhcPrelude

import qualified GraphColor as Color
import RegAlloc.Liveness
import RegAlloc.Graph.Spill
import RegAlloc.Graph.SpillCost
import RegAlloc.Graph.TrivColorable
import Instruction
import RegClass
import Reg
import TargetReg

import PprCmm()
import Outputable
import UniqFM
import UniqSet
import State

-- | Holds interesting statistics from the register allocator.
data RegAllocStats statics instr

        -- Information about the initial conflict graph.
        = RegAllocStatsStart
        { -- | Initial code, with liveness.
          RegAllocStats statics instr -> [LiveCmmDecl statics instr]
raLiveCmm     :: [LiveCmmDecl statics instr]

          -- | The initial, uncolored graph.
        , RegAllocStats statics instr -> Graph VirtualReg RegClass RealReg
raGraph       :: Color.Graph VirtualReg RegClass RealReg

          -- | Information to help choose which regs to spill.
        , RegAllocStats statics instr -> SpillCostInfo
raSpillCosts  :: SpillCostInfo }


        -- Information about an intermediate graph.
        -- This is one that we couldn't color, so had to insert spill code
        -- instruction stream.
        | RegAllocStatsSpill
        { -- | Code we tried to allocate registers for.
          RegAllocStats statics instr -> [LiveCmmDecl statics instr]
raCode        :: [LiveCmmDecl statics instr]

          -- | Partially colored graph.
        , raGraph       :: Color.Graph VirtualReg RegClass RealReg

          -- | The regs that were coalesced.
        , RegAllocStats statics instr -> UniqFM VirtualReg
raCoalesced   :: UniqFM VirtualReg

          -- | Spiller stats.
        , RegAllocStats statics instr -> SpillStats
raSpillStats  :: SpillStats

          -- | Number of instructions each reg lives for.
        , raSpillCosts  :: SpillCostInfo

          -- | Code with spill instructions added.
        , RegAllocStats statics instr -> [LiveCmmDecl statics instr]
raSpilled     :: [LiveCmmDecl statics instr] }


        -- a successful coloring
        | RegAllocStatsColored
        { -- | Code we tried to allocate registers for.
          raCode          :: [LiveCmmDecl statics instr]

          -- | Uncolored graph.
        , raGraph         :: Color.Graph VirtualReg RegClass RealReg

          -- | Coalesced and colored graph.
        , RegAllocStats statics instr -> Graph VirtualReg RegClass RealReg
raGraphColored  :: Color.Graph VirtualReg RegClass RealReg

          -- | Regs that were coalesced.
        , raCoalesced     :: UniqFM VirtualReg

          -- | Code with coalescings applied.
        , RegAllocStats statics instr -> [LiveCmmDecl statics instr]
raCodeCoalesced :: [LiveCmmDecl statics instr]

          -- | Code with vregs replaced by hregs.
        , RegAllocStats statics instr -> [LiveCmmDecl statics instr]
raPatched       :: [LiveCmmDecl statics instr]

          -- | Code with unneeded spill\/reloads cleaned out.
        , RegAllocStats statics instr -> [LiveCmmDecl statics instr]
raSpillClean    :: [LiveCmmDecl statics instr]

          -- | Final code.
        , RegAllocStats statics instr -> [NatCmmDecl statics instr]
raFinal         :: [NatCmmDecl statics instr]

          -- | Spill\/reload\/reg-reg moves present in this code.
        , RegAllocStats statics instr -> (Int, Int, Int)
raSRMs          :: (Int, Int, Int) }


instance (Outputable statics, Outputable instr)
       => Outputable (RegAllocStats statics instr) where

 ppr :: RegAllocStats statics instr -> SDoc
ppr (s :: RegAllocStats statics instr
s@RegAllocStatsStart{}) = (Platform -> SDoc) -> SDoc
sdocWithPlatform ((Platform -> SDoc) -> SDoc) -> (Platform -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \platform :: Platform
platform ->
           String -> SDoc
text "#  Start"
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "#  Native code with liveness information."
        SDoc -> SDoc -> SDoc
$$ [LiveCmmDecl statics instr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (RegAllocStats statics instr -> [LiveCmmDecl statics instr]
forall statics instr.
RegAllocStats statics instr -> [LiveCmmDecl statics instr]
raLiveCmm RegAllocStats statics instr
s)
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text ""
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "#  Initial register conflict graph."
        SDoc -> SDoc -> SDoc
$$ (RealReg -> SDoc)
-> Triv VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
-> SDoc
forall k cls color.
(Uniquable k, Outputable k, Outputable cls, Outputable color) =>
(color -> SDoc) -> Triv k cls color -> Graph k cls color -> SDoc
Color.dotGraph
                (Platform -> RealReg -> SDoc
targetRegDotColor Platform
platform)
                (Platform
-> (RegClass -> VirtualReg -> Int)
-> (RegClass -> RealReg -> Int)
-> Triv VirtualReg RegClass RealReg
trivColorable Platform
platform
                        (Platform -> RegClass -> VirtualReg -> Int
targetVirtualRegSqueeze Platform
platform)
                        (Platform -> RegClass -> RealReg -> Int
targetRealRegSqueeze Platform
platform))
                (RegAllocStats statics instr -> Graph VirtualReg RegClass RealReg
forall statics instr.
RegAllocStats statics instr -> Graph VirtualReg RegClass RealReg
raGraph RegAllocStats statics instr
s)


 ppr (s :: RegAllocStats statics instr
s@RegAllocStatsSpill{}) =
           String -> SDoc
text "#  Spill"

        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "#  Code with liveness information."
        SDoc -> SDoc -> SDoc
$$ [LiveCmmDecl statics instr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (RegAllocStats statics instr -> [LiveCmmDecl statics instr]
forall statics instr.
RegAllocStats statics instr -> [LiveCmmDecl statics instr]
raCode RegAllocStats statics instr
s)
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text ""

        SDoc -> SDoc -> SDoc
$$ (if (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ UniqFM VirtualReg -> Bool
forall elt. UniqFM elt -> Bool
isNullUFM (UniqFM VirtualReg -> Bool) -> UniqFM VirtualReg -> Bool
forall a b. (a -> b) -> a -> b
$ RegAllocStats statics instr -> UniqFM VirtualReg
forall statics instr.
RegAllocStats statics instr -> UniqFM VirtualReg
raCoalesced RegAllocStats statics instr
s)
                then    String -> SDoc
text "#  Registers coalesced."
                        SDoc -> SDoc -> SDoc
$$ UniqFM VirtualReg -> ([(Unique, VirtualReg)] -> SDoc) -> SDoc
forall a. UniqFM a -> ([(Unique, a)] -> SDoc) -> SDoc
pprUFMWithKeys (RegAllocStats statics instr -> UniqFM VirtualReg
forall statics instr.
RegAllocStats statics instr -> UniqFM VirtualReg
raCoalesced RegAllocStats statics instr
s) ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc)
-> ([(Unique, VirtualReg)] -> [SDoc])
-> [(Unique, VirtualReg)]
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Unique, VirtualReg) -> SDoc) -> [(Unique, VirtualReg)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Unique, VirtualReg) -> SDoc
forall a. Outputable a => a -> SDoc
ppr)
                        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text ""
                else SDoc
empty)

        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "#  Spills inserted."
        SDoc -> SDoc -> SDoc
$$ SpillStats -> SDoc
forall a. Outputable a => a -> SDoc
ppr (RegAllocStats statics instr -> SpillStats
forall statics instr. RegAllocStats statics instr -> SpillStats
raSpillStats RegAllocStats statics instr
s)
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text ""

        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "#  Code with spills inserted."
        SDoc -> SDoc -> SDoc
$$ [LiveCmmDecl statics instr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (RegAllocStats statics instr -> [LiveCmmDecl statics instr]
forall statics instr.
RegAllocStats statics instr -> [LiveCmmDecl statics instr]
raSpilled RegAllocStats statics instr
s)


 ppr (s :: RegAllocStats statics instr
s@RegAllocStatsColored { raSRMs :: forall statics instr.
RegAllocStats statics instr -> (Int, Int, Int)
raSRMs = (spills :: Int
spills, reloads :: Int
reloads, moves :: Int
moves) })
    = (Platform -> SDoc) -> SDoc
sdocWithPlatform ((Platform -> SDoc) -> SDoc) -> (Platform -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \platform :: Platform
platform ->
           String -> SDoc
text "#  Colored"

        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "#  Code with liveness information."
        SDoc -> SDoc -> SDoc
$$ [LiveCmmDecl statics instr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (RegAllocStats statics instr -> [LiveCmmDecl statics instr]
forall statics instr.
RegAllocStats statics instr -> [LiveCmmDecl statics instr]
raCode RegAllocStats statics instr
s)
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text ""

        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "#  Register conflict graph (colored)."
        SDoc -> SDoc -> SDoc
$$ (RealReg -> SDoc)
-> Triv VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
-> SDoc
forall k cls color.
(Uniquable k, Outputable k, Outputable cls, Outputable color) =>
(color -> SDoc) -> Triv k cls color -> Graph k cls color -> SDoc
Color.dotGraph
                (Platform -> RealReg -> SDoc
targetRegDotColor Platform
platform)
                (Platform
-> (RegClass -> VirtualReg -> Int)
-> (RegClass -> RealReg -> Int)
-> Triv VirtualReg RegClass RealReg
trivColorable Platform
platform
                        (Platform -> RegClass -> VirtualReg -> Int
targetVirtualRegSqueeze Platform
platform)
                        (Platform -> RegClass -> RealReg -> Int
targetRealRegSqueeze Platform
platform))
                (RegAllocStats statics instr -> Graph VirtualReg RegClass RealReg
forall statics instr.
RegAllocStats statics instr -> Graph VirtualReg RegClass RealReg
raGraphColored RegAllocStats statics instr
s)
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text ""

        SDoc -> SDoc -> SDoc
$$ (if (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ UniqFM VirtualReg -> Bool
forall elt. UniqFM elt -> Bool
isNullUFM (UniqFM VirtualReg -> Bool) -> UniqFM VirtualReg -> Bool
forall a b. (a -> b) -> a -> b
$ RegAllocStats statics instr -> UniqFM VirtualReg
forall statics instr.
RegAllocStats statics instr -> UniqFM VirtualReg
raCoalesced RegAllocStats statics instr
s)
                then    String -> SDoc
text "#  Registers coalesced."
                        SDoc -> SDoc -> SDoc
$$ UniqFM VirtualReg -> ([(Unique, VirtualReg)] -> SDoc) -> SDoc
forall a. UniqFM a -> ([(Unique, a)] -> SDoc) -> SDoc
pprUFMWithKeys (RegAllocStats statics instr -> UniqFM VirtualReg
forall statics instr.
RegAllocStats statics instr -> UniqFM VirtualReg
raCoalesced RegAllocStats statics instr
s) ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc)
-> ([(Unique, VirtualReg)] -> [SDoc])
-> [(Unique, VirtualReg)]
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Unique, VirtualReg) -> SDoc) -> [(Unique, VirtualReg)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Unique, VirtualReg) -> SDoc
forall a. Outputable a => a -> SDoc
ppr)
                        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text ""
                else SDoc
empty)

        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "#  Native code after coalescings applied."
        SDoc -> SDoc -> SDoc
$$ [LiveCmmDecl statics instr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (RegAllocStats statics instr -> [LiveCmmDecl statics instr]
forall statics instr.
RegAllocStats statics instr -> [LiveCmmDecl statics instr]
raCodeCoalesced RegAllocStats statics instr
s)
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text ""

        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "#  Native code after register allocation."
        SDoc -> SDoc -> SDoc
$$ [LiveCmmDecl statics instr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (RegAllocStats statics instr -> [LiveCmmDecl statics instr]
forall statics instr.
RegAllocStats statics instr -> [LiveCmmDecl statics instr]
raPatched RegAllocStats statics instr
s)
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text ""

        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "#  Clean out unneeded spill/reloads."
        SDoc -> SDoc -> SDoc
$$ [LiveCmmDecl statics instr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (RegAllocStats statics instr -> [LiveCmmDecl statics instr]
forall statics instr.
RegAllocStats statics instr -> [LiveCmmDecl statics instr]
raSpillClean RegAllocStats statics instr
s)
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text ""

        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "#  Final code, after rewriting spill/rewrite pseudo instrs."
        SDoc -> SDoc -> SDoc
$$ [NatCmmDecl statics instr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (RegAllocStats statics instr -> [NatCmmDecl statics instr]
forall statics instr.
RegAllocStats statics instr -> [NatCmmDecl statics instr]
raFinal RegAllocStats statics instr
s)
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text ""
        SDoc -> SDoc -> SDoc
$$  String -> SDoc
text "#  Score:"
        SDoc -> SDoc -> SDoc
$$ (String -> SDoc
text "#          spills  inserted: " SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
spills)
        SDoc -> SDoc -> SDoc
$$ (String -> SDoc
text "#          reloads inserted: " SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
reloads)
        SDoc -> SDoc -> SDoc
$$ (String -> SDoc
text "#   reg-reg moves remaining: " SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
moves)
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text ""


-- | Do all the different analysis on this list of RegAllocStats
pprStats
        :: [RegAllocStats statics instr]
        -> Color.Graph VirtualReg RegClass RealReg
        -> SDoc

pprStats :: [RegAllocStats statics instr]
-> Graph VirtualReg RegClass RealReg -> SDoc
pprStats stats :: [RegAllocStats statics instr]
stats graph :: Graph VirtualReg RegClass RealReg
graph
 = let  outSpills :: SDoc
outSpills       = [RegAllocStats statics instr] -> SDoc
forall statics instr. [RegAllocStats statics instr] -> SDoc
pprStatsSpills    [RegAllocStats statics instr]
stats
        outLife :: SDoc
outLife         = [RegAllocStats statics instr] -> SDoc
forall statics instr. [RegAllocStats statics instr] -> SDoc
pprStatsLifetimes [RegAllocStats statics instr]
stats
        outConflict :: SDoc
outConflict     = [RegAllocStats statics instr] -> SDoc
forall statics instr. [RegAllocStats statics instr] -> SDoc
pprStatsConflict  [RegAllocStats statics instr]
stats
        outScatter :: SDoc
outScatter      = [RegAllocStats statics instr]
-> Graph VirtualReg RegClass RealReg -> SDoc
forall statics instr.
[RegAllocStats statics instr]
-> Graph VirtualReg RegClass RealReg -> SDoc
pprStatsLifeConflict [RegAllocStats statics instr]
stats Graph VirtualReg RegClass RealReg
graph

  in    [SDoc] -> SDoc
vcat [SDoc
outSpills, SDoc
outLife, SDoc
outConflict, SDoc
outScatter]


-- | Dump a table of how many spill loads \/ stores were inserted for each vreg.
pprStatsSpills
        :: [RegAllocStats statics instr] -> SDoc

pprStatsSpills :: [RegAllocStats statics instr] -> SDoc
pprStatsSpills stats :: [RegAllocStats statics instr]
stats
 = let
        finals :: [RegAllocStats statics instr]
finals  = [ RegAllocStats statics instr
s   | s :: RegAllocStats statics instr
s@RegAllocStatsColored{} <- [RegAllocStats statics instr]
stats]

        -- sum up how many stores\/loads\/reg-reg-moves were left in the code
        total :: (Int, Int, Int)
total   = ((Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int))
-> (Int, Int, Int) -> [(Int, Int, Int)] -> (Int, Int, Int)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int)
addSRM (0, 0, 0)
                ([(Int, Int, Int)] -> (Int, Int, Int))
-> [(Int, Int, Int)] -> (Int, Int, Int)
forall a b. (a -> b) -> a -> b
$ (RegAllocStats statics instr -> (Int, Int, Int))
-> [RegAllocStats statics instr] -> [(Int, Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map RegAllocStats statics instr -> (Int, Int, Int)
forall statics instr.
RegAllocStats statics instr -> (Int, Int, Int)
raSRMs [RegAllocStats statics instr]
finals

    in  (  String -> SDoc
text "-- spills-added-total"
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "--    (stores, loads, reg_reg_moves_remaining)"
        SDoc -> SDoc -> SDoc
$$ (Int, Int, Int) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Int, Int, Int)
total
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "")


-- | Dump a table of how long vregs tend to live for in the initial code.
pprStatsLifetimes
        :: [RegAllocStats statics instr] -> SDoc

pprStatsLifetimes :: [RegAllocStats statics instr] -> SDoc
pprStatsLifetimes stats :: [RegAllocStats statics instr]
stats
 = let  info :: SpillCostInfo
info            = (SpillCostInfo -> SpillCostInfo -> SpillCostInfo)
-> SpillCostInfo -> [SpillCostInfo] -> SpillCostInfo
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SpillCostInfo -> SpillCostInfo -> SpillCostInfo
plusSpillCostInfo SpillCostInfo
zeroSpillCostInfo
                                [ RegAllocStats statics instr -> SpillCostInfo
forall statics instr. RegAllocStats statics instr -> SpillCostInfo
raSpillCosts RegAllocStats statics instr
s
                                        | s :: RegAllocStats statics instr
s@RegAllocStatsStart{} <- [RegAllocStats statics instr]
stats ]

        lifeBins :: UniqFM (Int, Int)
lifeBins        = UniqFM (VirtualReg, Int) -> UniqFM (Int, Int)
binLifetimeCount (UniqFM (VirtualReg, Int) -> UniqFM (Int, Int))
-> UniqFM (VirtualReg, Int) -> UniqFM (Int, Int)
forall a b. (a -> b) -> a -> b
$ SpillCostInfo -> UniqFM (VirtualReg, Int)
lifeMapFromSpillCostInfo SpillCostInfo
info

   in   (  String -> SDoc
text "-- vreg-population-lifetimes"
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "--   (instruction_count, number_of_vregs_that_lived_that_long)"
        SDoc -> SDoc -> SDoc
$$ UniqFM (Int, Int) -> ([(Int, Int)] -> SDoc) -> SDoc
forall a. UniqFM a -> ([a] -> SDoc) -> SDoc
pprUFM UniqFM (Int, Int)
lifeBins ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc)
-> ([(Int, Int)] -> [SDoc]) -> [(Int, Int)] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int) -> SDoc) -> [(Int, Int)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> SDoc
forall a. Outputable a => a -> SDoc
ppr)
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "\n")


binLifetimeCount :: UniqFM (VirtualReg, Int) -> UniqFM (Int, Int)
binLifetimeCount :: UniqFM (VirtualReg, Int) -> UniqFM (Int, Int)
binLifetimeCount fm :: UniqFM (VirtualReg, Int)
fm
 = let  lifes :: [(Int, (Int, Int))]
lifes   = (Int -> (Int, (Int, Int))) -> [Int] -> [(Int, (Int, Int))]
forall a b. (a -> b) -> [a] -> [b]
map (\l :: Int
l -> (Int
l, (Int
l, 1)))
                ([Int] -> [(Int, (Int, Int))]) -> [Int] -> [(Int, (Int, Int))]
forall a b. (a -> b) -> a -> b
$ ((VirtualReg, Int) -> Int) -> [(VirtualReg, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (VirtualReg, Int) -> Int
forall a b. (a, b) -> b
snd
                ([(VirtualReg, Int)] -> [Int]) -> [(VirtualReg, Int)] -> [Int]
forall a b. (a -> b) -> a -> b
$ UniqFM (VirtualReg, Int) -> [(VirtualReg, Int)]
forall elt. UniqFM elt -> [elt]
nonDetEltsUFM UniqFM (VirtualReg, Int)
fm
                -- See Note [Unique Determinism and code generation]

   in   ((Int, Int) -> (Int, Int) -> (Int, Int))
-> UniqFM (Int, Int) -> [(Int, (Int, Int))] -> UniqFM (Int, Int)
forall key elt.
Uniquable key =>
(elt -> elt -> elt) -> UniqFM elt -> [(key, elt)] -> UniqFM elt
addListToUFM_C
                (\(l1 :: Int
l1, c1 :: Int
c1) (_, c2 :: Int
c2) -> (Int
l1, Int
c1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
c2))
                UniqFM (Int, Int)
forall elt. UniqFM elt
emptyUFM
                [(Int, (Int, Int))]
lifes


-- | Dump a table of how many conflicts vregs tend to have in the initial code.
pprStatsConflict
        :: [RegAllocStats statics instr] -> SDoc

pprStatsConflict :: [RegAllocStats statics instr] -> SDoc
pprStatsConflict stats :: [RegAllocStats statics instr]
stats
 = let  confMap :: UniqFM (Int, Int)
confMap = (UniqFM (Int, Int) -> UniqFM (Int, Int) -> UniqFM (Int, Int))
-> UniqFM (Int, Int) -> [UniqFM (Int, Int)] -> UniqFM (Int, Int)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (((Int, Int) -> (Int, Int) -> (Int, Int))
-> UniqFM (Int, Int) -> UniqFM (Int, Int) -> UniqFM (Int, Int)
forall elt.
(elt -> elt -> elt) -> UniqFM elt -> UniqFM elt -> UniqFM elt
plusUFM_C (\(c1 :: Int
c1, n1 :: Int
n1) (_, n2 :: Int
n2) -> (Int
c1, Int
n1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n2)))
                        UniqFM (Int, Int)
forall elt. UniqFM elt
emptyUFM
                ([UniqFM (Int, Int)] -> UniqFM (Int, Int))
-> [UniqFM (Int, Int)] -> UniqFM (Int, Int)
forall a b. (a -> b) -> a -> b
$ (Graph VirtualReg RegClass RealReg -> UniqFM (Int, Int))
-> [Graph VirtualReg RegClass RealReg] -> [UniqFM (Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map Graph VirtualReg RegClass RealReg -> UniqFM (Int, Int)
forall k cls color. Graph k cls color -> UniqFM (Int, Int)
Color.slurpNodeConflictCount
                        [ RegAllocStats statics instr -> Graph VirtualReg RegClass RealReg
forall statics instr.
RegAllocStats statics instr -> Graph VirtualReg RegClass RealReg
raGraph RegAllocStats statics instr
s | s :: RegAllocStats statics instr
s@RegAllocStatsStart{} <- [RegAllocStats statics instr]
stats ]

   in   (  String -> SDoc
text "-- vreg-conflicts"
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "--   (conflict_count, number_of_vregs_that_had_that_many_conflicts)"
        SDoc -> SDoc -> SDoc
$$ UniqFM (Int, Int) -> ([(Int, Int)] -> SDoc) -> SDoc
forall a. UniqFM a -> ([a] -> SDoc) -> SDoc
pprUFM UniqFM (Int, Int)
confMap ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc)
-> ([(Int, Int)] -> [SDoc]) -> [(Int, Int)] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int) -> SDoc) -> [(Int, Int)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> SDoc
forall a. Outputable a => a -> SDoc
ppr)
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "\n")


-- | For every vreg, dump how many conflicts it has, and its lifetime.
--      Good for making a scatter plot.
pprStatsLifeConflict
        :: [RegAllocStats statics instr]
        -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph
        -> SDoc

pprStatsLifeConflict :: [RegAllocStats statics instr]
-> Graph VirtualReg RegClass RealReg -> SDoc
pprStatsLifeConflict stats :: [RegAllocStats statics instr]
stats graph :: Graph VirtualReg RegClass RealReg
graph
 = let  lifeMap :: UniqFM (VirtualReg, Int)
lifeMap = SpillCostInfo -> UniqFM (VirtualReg, Int)
lifeMapFromSpillCostInfo
                (SpillCostInfo -> UniqFM (VirtualReg, Int))
-> SpillCostInfo -> UniqFM (VirtualReg, Int)
forall a b. (a -> b) -> a -> b
$ (SpillCostInfo -> SpillCostInfo -> SpillCostInfo)
-> SpillCostInfo -> [SpillCostInfo] -> SpillCostInfo
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SpillCostInfo -> SpillCostInfo -> SpillCostInfo
plusSpillCostInfo SpillCostInfo
zeroSpillCostInfo
                ([SpillCostInfo] -> SpillCostInfo)
-> [SpillCostInfo] -> SpillCostInfo
forall a b. (a -> b) -> a -> b
$ [ RegAllocStats statics instr -> SpillCostInfo
forall statics instr. RegAllocStats statics instr -> SpillCostInfo
raSpillCosts RegAllocStats statics instr
s | s :: RegAllocStats statics instr
s@RegAllocStatsStart{} <- [RegAllocStats statics instr]
stats ]

        scatter :: [SDoc]
scatter = (VirtualReg -> SDoc) -> [VirtualReg] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map   (\r :: VirtualReg
r ->  let lifetime :: Int
lifetime  = case UniqFM (VirtualReg, Int) -> VirtualReg -> Maybe (VirtualReg, Int)
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM (VirtualReg, Int)
lifeMap VirtualReg
r of
                                                      Just (_, l :: Int
l) -> Int
l
                                                      Nothing     -> 0
                                    Just node :: Node VirtualReg RegClass RealReg
node = Graph VirtualReg RegClass RealReg
-> VirtualReg -> Maybe (Node VirtualReg RegClass RealReg)
forall k cls color.
Uniquable k =>
Graph k cls color -> k -> Maybe (Node k cls color)
Color.lookupNode Graph VirtualReg RegClass RealReg
graph VirtualReg
r
                                in SDoc -> SDoc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate (String -> SDoc
text ", ")
                                        [ SDoc -> SDoc
doubleQuotes (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ VirtualReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr (VirtualReg -> SDoc) -> VirtualReg -> SDoc
forall a b. (a -> b) -> a -> b
$ Node VirtualReg RegClass RealReg -> VirtualReg
forall k cls color. Node k cls color -> k
Color.nodeId Node VirtualReg RegClass RealReg
node
                                        , Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Int -> SDoc) -> Int -> SDoc
forall a b. (a -> b) -> a -> b
$ UniqSet VirtualReg -> Int
forall a. UniqSet a -> Int
sizeUniqSet (Node VirtualReg RegClass RealReg -> UniqSet VirtualReg
forall k cls color. Node k cls color -> UniqSet k
Color.nodeConflicts Node VirtualReg RegClass RealReg
node)
                                        , Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Int -> SDoc) -> Int -> SDoc
forall a b. (a -> b) -> a -> b
$ Int
lifetime ])
                ([VirtualReg] -> [SDoc]) -> [VirtualReg] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ (Node VirtualReg RegClass RealReg -> VirtualReg)
-> [Node VirtualReg RegClass RealReg] -> [VirtualReg]
forall a b. (a -> b) -> [a] -> [b]
map Node VirtualReg RegClass RealReg -> VirtualReg
forall k cls color. Node k cls color -> k
Color.nodeId
                ([Node VirtualReg RegClass RealReg] -> [VirtualReg])
-> [Node VirtualReg RegClass RealReg] -> [VirtualReg]
forall a b. (a -> b) -> a -> b
$ UniqFM (Node VirtualReg RegClass RealReg)
-> [Node VirtualReg RegClass RealReg]
forall elt. UniqFM elt -> [elt]
nonDetEltsUFM
                -- See Note [Unique Determinism and code generation]
                (UniqFM (Node VirtualReg RegClass RealReg)
 -> [Node VirtualReg RegClass RealReg])
-> UniqFM (Node VirtualReg RegClass RealReg)
-> [Node VirtualReg RegClass RealReg]
forall a b. (a -> b) -> a -> b
$ Graph VirtualReg RegClass RealReg
-> UniqFM (Node VirtualReg RegClass RealReg)
forall k cls color. Graph k cls color -> UniqFM (Node k cls color)
Color.graphMap Graph VirtualReg RegClass RealReg
graph

   in   (  String -> SDoc
text "-- vreg-conflict-lifetime"
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "--   (vreg, vreg_conflicts, vreg_lifetime)"
        SDoc -> SDoc -> SDoc
$$ ([SDoc] -> SDoc
vcat [SDoc]
scatter)
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "\n")


-- | Count spill/reload/reg-reg moves.
--      Lets us see how well the register allocator has done.
countSRMs
        :: Instruction instr
        => LiveCmmDecl statics instr -> (Int, Int, Int)

countSRMs :: LiveCmmDecl statics instr -> (Int, Int, Int)
countSRMs cmm :: LiveCmmDecl statics instr
cmm
        = State (Int, Int, Int) (LiveCmmDecl statics instr)
-> (Int, Int, Int) -> (Int, Int, Int)
forall s a. State s a -> s -> s
execState ((LiveBasicBlock instr
 -> State (Int, Int, Int) (LiveBasicBlock instr))
-> LiveCmmDecl statics instr
-> State (Int, Int, Int) (LiveCmmDecl statics instr)
forall (m :: * -> *) instr statics.
Monad m =>
(LiveBasicBlock instr -> m (LiveBasicBlock instr))
-> LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr)
mapBlockTopM LiveBasicBlock instr
-> State (Int, Int, Int) (LiveBasicBlock instr)
forall instr.
Instruction instr =>
GenBasicBlock (LiveInstr instr)
-> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr))
countSRM_block LiveCmmDecl statics instr
cmm) (0, 0, 0)


countSRM_block
        :: Instruction instr
        => GenBasicBlock (LiveInstr instr)
        -> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr))

countSRM_block :: GenBasicBlock (LiveInstr instr)
-> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr))
countSRM_block (BasicBlock i :: BlockId
i instrs :: [LiveInstr instr]
instrs)
 = do   [LiveInstr instr]
instrs' <- (LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr))
-> [LiveInstr instr] -> State (Int, Int, Int) [LiveInstr instr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr)
forall instr.
Instruction instr =>
LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr)
countSRM_instr [LiveInstr instr]
instrs
        GenBasicBlock (LiveInstr instr)
-> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr))
forall (m :: * -> *) a. Monad m => a -> m a
return  (GenBasicBlock (LiveInstr instr)
 -> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr)))
-> GenBasicBlock (LiveInstr instr)
-> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr))
forall a b. (a -> b) -> a -> b
$ BlockId -> [LiveInstr instr] -> GenBasicBlock (LiveInstr instr)
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
i [LiveInstr instr]
instrs'


countSRM_instr
        :: Instruction instr
        => LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr)

countSRM_instr :: LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr)
countSRM_instr li :: LiveInstr instr
li
        | LiveInstr SPILL{} _    <- LiveInstr instr
li
        = do    ((Int, Int, Int) -> (Int, Int, Int)) -> State (Int, Int, Int) ()
forall s. (s -> s) -> State s ()
modify  (((Int, Int, Int) -> (Int, Int, Int)) -> State (Int, Int, Int) ())
-> ((Int, Int, Int) -> (Int, Int, Int)) -> State (Int, Int, Int) ()
forall a b. (a -> b) -> a -> b
$ \(s :: Int
s, r :: Int
r, m :: Int
m)    -> (Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Int
r, Int
m)
                LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr)
forall (m :: * -> *) a. Monad m => a -> m a
return LiveInstr instr
li

        | LiveInstr RELOAD{} _  <- LiveInstr instr
li
        = do    ((Int, Int, Int) -> (Int, Int, Int)) -> State (Int, Int, Int) ()
forall s. (s -> s) -> State s ()
modify  (((Int, Int, Int) -> (Int, Int, Int)) -> State (Int, Int, Int) ())
-> ((Int, Int, Int) -> (Int, Int, Int)) -> State (Int, Int, Int) ()
forall a b. (a -> b) -> a -> b
$ \(s :: Int
s, r :: Int
r, m :: Int
m)    -> (Int
s, Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Int
m)
                LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr)
forall (m :: * -> *) a. Monad m => a -> m a
return LiveInstr instr
li

        | LiveInstr instr :: InstrSR instr
instr _     <- LiveInstr instr
li
        , Just _        <- InstrSR instr -> Maybe (Reg, Reg)
forall instr. Instruction instr => instr -> Maybe (Reg, Reg)
takeRegRegMoveInstr InstrSR instr
instr
        = do    ((Int, Int, Int) -> (Int, Int, Int)) -> State (Int, Int, Int) ()
forall s. (s -> s) -> State s ()
modify  (((Int, Int, Int) -> (Int, Int, Int)) -> State (Int, Int, Int) ())
-> ((Int, Int, Int) -> (Int, Int, Int)) -> State (Int, Int, Int) ()
forall a b. (a -> b) -> a -> b
$ \(s :: Int
s, r :: Int
r, m :: Int
m)    -> (Int
s, Int
r, Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
                LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr)
forall (m :: * -> *) a. Monad m => a -> m a
return LiveInstr instr
li

        | Bool
otherwise
        =       LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr)
forall (m :: * -> *) a. Monad m => a -> m a
return LiveInstr instr
li


-- sigh..
addSRM :: (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int)
addSRM :: (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int)
addSRM (s1 :: Int
s1, r1 :: Int
r1, m1 :: Int
m1) (s2 :: Int
s2, r2 :: Int
r2, m2 :: Int
m2)
 = let  !s :: Int
s = Int
s1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
s2
        !r :: Int
r = Int
r1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
r2
        !m :: Int
m = Int
m1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m2
   in   (Int
s, Int
r, Int
m)