{-# LANGUAGE BangPatterns, CPP, DeriveFunctor #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}


{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-- | Carries interesting info for debugging / profiling of the
--   graph coloring register allocator.
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.Reg.Target
import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.Types

import GHC.Platform
import GHC.Platform.Reg
import GHC.Platform.Reg.Class

import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import GHC.Utils.Outputable
import GHC.Utils.Monad.State

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

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

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

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

          -- | Target platform
        , forall statics instr. RegAllocStats statics instr -> Platform
raPlatform    :: !Platform
        }


        -- 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.
          forall statics instr.
RegAllocStats statics instr -> [LiveCmmDecl statics instr]
raCode        :: [LiveCmmDecl statics instr]

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

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

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

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

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

          -- | Target platform
        , raPlatform    :: !Platform
        }


        -- 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.
        , forall statics instr.
RegAllocStats statics instr -> Graph VirtualReg RegClass RealReg
raGraphColored  :: Color.Graph VirtualReg RegClass RealReg

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

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

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

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

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

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

          -- | Target platform
        , raPlatform    :: !Platform
        }
        deriving (forall a b. a -> RegAllocStats statics b -> RegAllocStats statics a
forall a b.
(a -> b) -> RegAllocStats statics a -> RegAllocStats statics b
forall statics a b.
a -> RegAllocStats statics b -> RegAllocStats statics a
forall statics a b.
(a -> b) -> RegAllocStats statics a -> RegAllocStats statics b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> RegAllocStats statics b -> RegAllocStats statics a
$c<$ :: forall statics a b.
a -> RegAllocStats statics b -> RegAllocStats statics a
fmap :: forall a b.
(a -> b) -> RegAllocStats statics a -> RegAllocStats statics b
$cfmap :: forall statics a b.
(a -> b) -> RegAllocStats statics a -> RegAllocStats statics b
Functor)


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

 ppr :: RegAllocStats statics instr -> SDoc
ppr (s :: RegAllocStats statics instr
s@RegAllocStatsStart{})
    =      String -> SDoc
text String
"#  Start"
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"#  Native code with liveness information."
        SDoc -> SDoc -> SDoc
$$ forall env a. OutputableP env a => env -> a -> SDoc
pdoc (forall statics instr. RegAllocStats statics instr -> Platform
raPlatform RegAllocStats statics instr
s) (forall statics instr.
RegAllocStats statics instr -> [LiveCmmDecl statics instr]
raLiveCmm RegAllocStats statics instr
s)
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
""
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"#  Initial register conflict graph."
        SDoc -> SDoc -> 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 (forall statics instr. RegAllocStats statics instr -> Platform
raPlatform RegAllocStats statics instr
s))
                (Platform
-> (RegClass -> VirtualReg -> Int)
-> (RegClass -> RealReg -> Int)
-> Triv VirtualReg RegClass RealReg
trivColorable (forall statics instr. RegAllocStats statics instr -> Platform
raPlatform RegAllocStats statics instr
s)
                        (Platform -> RegClass -> VirtualReg -> Int
targetVirtualRegSqueeze (forall statics instr. RegAllocStats statics instr -> Platform
raPlatform RegAllocStats statics instr
s))
                        (Platform -> RegClass -> RealReg -> Int
targetRealRegSqueeze (forall statics instr. RegAllocStats statics instr -> Platform
raPlatform RegAllocStats statics instr
s)))
                (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 String
"#  Spill"

        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"#  Code with liveness information."
        SDoc -> SDoc -> SDoc
$$ forall env a. OutputableP env a => env -> a -> SDoc
pdoc (forall statics instr. RegAllocStats statics instr -> Platform
raPlatform RegAllocStats statics instr
s) (forall statics instr.
RegAllocStats statics instr -> [LiveCmmDecl statics instr]
raCode RegAllocStats statics instr
s)
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
""

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

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

        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"#  Code with spills inserted."
        SDoc -> SDoc -> SDoc
$$ forall env a. OutputableP env a => env -> a -> SDoc
pdoc (forall statics instr. RegAllocStats statics instr -> Platform
raPlatform RegAllocStats statics instr
s) (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 = (Int
spills, Int
reloads, Int
moves) })
    =      String -> SDoc
text String
"#  Colored"

        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"#  Code with liveness information."
        SDoc -> SDoc -> SDoc
$$ forall env a. OutputableP env a => env -> a -> SDoc
pdoc (forall statics instr. RegAllocStats statics instr -> Platform
raPlatform RegAllocStats statics instr
s) (forall statics instr.
RegAllocStats statics instr -> [LiveCmmDecl statics instr]
raCode RegAllocStats statics instr
s)
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
""

        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"#  Register conflict graph (colored)."
        SDoc -> SDoc -> 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 (forall statics instr. RegAllocStats statics instr -> Platform
raPlatform RegAllocStats statics instr
s))
                (Platform
-> (RegClass -> VirtualReg -> Int)
-> (RegClass -> RealReg -> Int)
-> Triv VirtualReg RegClass RealReg
trivColorable (forall statics instr. RegAllocStats statics instr -> Platform
raPlatform RegAllocStats statics instr
s)
                        (Platform -> RegClass -> VirtualReg -> Int
targetVirtualRegSqueeze (forall statics instr. RegAllocStats statics instr -> Platform
raPlatform RegAllocStats statics instr
s))
                        (Platform -> RegClass -> RealReg -> Int
targetRealRegSqueeze (forall statics instr. RegAllocStats statics instr -> Platform
raPlatform RegAllocStats statics instr
s)))
                (forall statics instr.
RegAllocStats statics instr -> Graph VirtualReg RegClass RealReg
raGraphColored RegAllocStats statics instr
s)
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
""

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

        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"#  Native code after coalescings applied."
        SDoc -> SDoc -> SDoc
$$ forall env a. OutputableP env a => env -> a -> SDoc
pdoc (forall statics instr. RegAllocStats statics instr -> Platform
raPlatform RegAllocStats statics instr
s) (forall statics instr.
RegAllocStats statics instr -> [LiveCmmDecl statics instr]
raCodeCoalesced RegAllocStats statics instr
s)
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
""

        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"#  Native code after register allocation."
        SDoc -> SDoc -> SDoc
$$ forall env a. OutputableP env a => env -> a -> SDoc
pdoc (forall statics instr. RegAllocStats statics instr -> Platform
raPlatform RegAllocStats statics instr
s) (forall statics instr.
RegAllocStats statics instr -> [LiveCmmDecl statics instr]
raPatched RegAllocStats statics instr
s)
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
""

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

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


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

pprStats :: forall statics instr.
[RegAllocStats statics instr]
-> Graph VirtualReg RegClass RealReg -> SDoc
pprStats [RegAllocStats statics instr]
stats Graph VirtualReg RegClass RealReg
graph
 = let  outSpills :: SDoc
outSpills       = forall statics instr. [RegAllocStats statics instr] -> SDoc
pprStatsSpills    [RegAllocStats statics instr]
stats
        outLife :: SDoc
outLife         = forall statics instr. [RegAllocStats statics instr] -> SDoc
pprStatsLifetimes [RegAllocStats statics instr]
stats
        outConflict :: SDoc
outConflict     = forall statics instr. [RegAllocStats statics instr] -> SDoc
pprStatsConflict  [RegAllocStats statics instr]
stats
        outScatter :: SDoc
outScatter      = 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 :: forall statics instr. [RegAllocStats statics instr] -> SDoc
pprStatsSpills [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   = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int)
addSRM (Int
0, Int
0, Int
0)
                forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall statics instr.
RegAllocStats statics instr -> (Int, Int, Int)
raSRMs [RegAllocStats statics instr]
finals

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


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

pprStatsLifetimes :: forall statics instr. [RegAllocStats statics instr] -> SDoc
pprStatsLifetimes [RegAllocStats statics instr]
stats
 = let  info :: SpillCostInfo
info            = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SpillCostInfo -> SpillCostInfo -> SpillCostInfo
plusSpillCostInfo SpillCostInfo
zeroSpillCostInfo
                                [ 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, Int)
lifeBins        = UniqFM VirtualReg (VirtualReg, Int) -> UniqFM Int (Int, Int)
binLifetimeCount forall a b. (a -> b) -> a -> b
$ SpillCostInfo -> UniqFM VirtualReg (VirtualReg, Int)
lifeMapFromSpillCostInfo SpillCostInfo
info

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


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

   in   forall key elt.
Uniquable key =>
(elt -> elt -> elt)
-> UniqFM key elt -> [(key, elt)] -> UniqFM key elt
addListToUFM_C
                (\(Int
l1, Int
c1) (Int
_, Int
c2) -> (Int
l1, Int
c1 forall a. Num a => a -> a -> a
+ Int
c2))
                forall key elt. UniqFM key 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 :: forall statics instr. [RegAllocStats statics instr] -> SDoc
pprStatsConflict [RegAllocStats statics instr]
stats
 = let  confMap :: UniqFM Int (Int, Int)
confMap = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall elt key.
(elt -> elt -> elt)
-> UniqFM key elt -> UniqFM key elt -> UniqFM key elt
plusUFM_C (\(Int
c1, Int
n1) (Int
_, Int
n2) -> (Int
c1, Int
n1 forall a. Num a => a -> a -> a
+ Int
n2)))
                        forall key elt. UniqFM key elt
emptyUFM
                forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall k cls color. Graph k cls color -> UniqFM Int (Int, Int)
Color.slurpNodeConflictCount
                        [ 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 String
"-- vreg-conflicts"
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"--   (conflict_count, number_of_vregs_that_had_that_many_conflicts)"
        SDoc -> SDoc -> SDoc
$$ forall key a. UniqFM key a -> ([a] -> SDoc) -> SDoc
pprUFM UniqFM Int (Int, Int)
confMap ([SDoc] -> SDoc
vcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr)
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"\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 :: forall statics instr.
[RegAllocStats statics instr]
-> Graph VirtualReg RegClass RealReg -> SDoc
pprStatsLifeConflict [RegAllocStats statics instr]
stats Graph VirtualReg RegClass RealReg
graph
 = let  lifeMap :: UniqFM VirtualReg (VirtualReg, Int)
lifeMap = SpillCostInfo -> UniqFM VirtualReg (VirtualReg, Int)
lifeMapFromSpillCostInfo
                forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SpillCostInfo -> SpillCostInfo -> SpillCostInfo
plusSpillCostInfo SpillCostInfo
zeroSpillCostInfo
                forall a b. (a -> b) -> a -> b
$ [ 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 = forall a b. (a -> b) -> [a] -> [b]
map   (\VirtualReg
r ->  let lifetime :: Int
lifetime  = case forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM VirtualReg (VirtualReg, Int)
lifeMap VirtualReg
r of
                                                      Just (VirtualReg
_, Int
l) -> Int
l
                                                      Maybe (VirtualReg, Int)
Nothing     -> Int
0
                                    Just Node VirtualReg RegClass RealReg
node = 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 forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hcat forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate (String -> SDoc
text String
", ")
                                        [ SDoc -> SDoc
doubleQuotes forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ forall k cls color. Node k cls color -> k
Color.nodeId Node VirtualReg RegClass RealReg
node
                                        , forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ forall a. UniqSet a -> Int
sizeUniqSet (forall k cls color. Node k cls color -> UniqSet k
Color.nodeConflicts Node VirtualReg RegClass RealReg
node)
                                        , forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ Int
lifetime ])
                forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall k cls color. Node k cls color -> k
Color.nodeId
                forall a b. (a -> b) -> a -> b
$ forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM
                -- See Note [Unique Determinism and code generation]
                forall a b. (a -> b) -> a -> b
$ forall k cls color.
Graph k cls color -> UniqFM k (Node k cls color)
Color.graphMap Graph VirtualReg RegClass RealReg
graph

   in   (  String -> SDoc
text String
"-- vreg-conflict-lifetime"
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"--   (vreg, vreg_conflicts, vreg_lifetime)"
        SDoc -> SDoc -> SDoc
$$ ([SDoc] -> SDoc
vcat [SDoc]
scatter)
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"\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 :: forall instr statics.
Instruction instr =>
LiveCmmDecl statics instr -> (Int, Int, Int)
countSRMs LiveCmmDecl statics instr
cmm
        = forall s a. State s a -> s -> s
execState (forall (m :: * -> *) instr statics.
Monad m =>
(LiveBasicBlock instr -> m (LiveBasicBlock instr))
-> LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr)
mapBlockTopM forall instr.
Instruction instr =>
GenBasicBlock (LiveInstr instr)
-> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr))
countSRM_block LiveCmmDecl statics instr
cmm) (Int
0, Int
0, Int
0)


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

countSRM_block :: forall instr.
Instruction instr =>
GenBasicBlock (LiveInstr instr)
-> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr))
countSRM_block (BasicBlock BlockId
i [LiveInstr instr]
instrs)
 = do   [LiveInstr instr]
instrs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall instr.
Instruction instr =>
LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr)
countSRM_instr [LiveInstr instr]
instrs
        forall (m :: * -> *) a. Monad m => a -> m a
return  forall a b. (a -> b) -> a -> b
$ 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 :: forall instr.
Instruction instr =>
LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr)
countSRM_instr LiveInstr instr
li
        | LiveInstr SPILL{} Maybe Liveness
_    <- LiveInstr instr
li
        = do    forall s. (s -> s) -> State s ()
modify  forall a b. (a -> b) -> a -> b
$ \(Int
s, Int
r, Int
m)    -> (Int
s forall a. Num a => a -> a -> a
+ Int
1, Int
r, Int
m)
                forall (m :: * -> *) a. Monad m => a -> m a
return LiveInstr instr
li

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

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

        | Bool
otherwise
        =       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 (Int
s1, Int
r1, Int
m1) (Int
s2, Int
r2, Int
m2)
 = let  !s :: Int
s = Int
s1 forall a. Num a => a -> a -> a
+ Int
s2
        !r :: Int
r = Int
r1 forall a. Num a => a -> a -> a
+ Int
r2
        !m :: Int
m = Int
m1 forall a. Num a => a -> a -> a
+ Int
m2
   in   (Int
s, Int
r, Int
m)