compiler/nativeGen/RegAllocStats.hs

   1
   2 -- Carries interesting info for debugging / profiling of the
   3 --      graph coloring register allocator.
   4
   5 {-# OPTIONS -w #-}
   6 -- The above warning supression flag is a temporary kludge.
   7 -- While working on this module you are encouraged to remove it and fix
   8 -- any warnings in the module. See
   9 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  10 -- for details
  11
  12 module RegAllocStats (
  13         RegAllocStats (..),
  14         regDotColor,
  15
  16         pprStats,
  17         pprStatsSpills,
  18         pprStatsLifetimes,
  19         pprStatsConflict,
  20         pprStatsLifeConflict,
  21
  22         countSRMs, addSRM
  23 )
  24
  25 where
  26
  27 #include "nativeGen/NCG.h"
  28
  29 import qualified GraphColor as Color
  30 import RegLiveness
  31 import RegAllocInfo
  32 import RegSpill
  33 import MachRegs
  34 import MachInstrs
  35 import Cmm
  36
  37 import Outputable
  38 import UniqFM
  39 import UniqSet
  40 import State
  41
  42 import Data.List
  43
  44 data RegAllocStats
  45
  46         -- initial graph
  47         = RegAllocStatsStart
  48         { raLiveCmm     :: [LiveCmmTop]                   -- ^ initial code, with liveness
  49         , raGraph       :: Color.Graph Reg RegClass Reg  -- ^ the initial, uncolored graph
  50         , raLifetimes   :: UniqFM (Reg, Int) }            -- ^ number of instrs each reg lives for
  51
  52         -- a spill stage
  53         | RegAllocStatsSpill
  54         { raGraph       :: Color.Graph Reg RegClass Reg -- ^ the partially colored graph
  55         , raCoalesced   :: UniqFM Reg                   -- ^ the regs that were coaleced
  56         , raSpillStats  :: SpillStats                   -- ^ spiller stats
  57         , raLifetimes   :: UniqFM (Reg, Int)            -- ^ number of instrs each reg lives for
  58         , raSpilled     :: [LiveCmmTop] }               -- ^ code with spill instructions added
  59
  60         -- a successful coloring
  61         | RegAllocStatsColored
  62         { raGraph       :: Color.Graph Reg RegClass Reg -- ^ the colored graph
  63         , raCoalesced   :: UniqFM Reg                   -- ^ the regs that were coaleced
  64         , raPatched     :: [LiveCmmTop]                 -- ^ code with vregs replaced by hregs
  65         , raSpillClean  :: [LiveCmmTop]                 -- ^ code with unneeded spill/reloads cleaned out
  66         , raFinal       :: [NatCmmTop]                  -- ^ final code
  67         , raSRMs        :: (Int, Int, Int) }            -- ^ spill/reload/reg-reg moves present in this code
  68
  69 instance Outputable RegAllocStats where
  70
  71  ppr (s@RegAllocStatsStart{})
  72         =  text "#  Start"
  73         $$ text "#  Native code with liveness information."
  74         $$ ppr (raLiveCmm s)
  75         $$ text ""
  76         $$ text "#  Initial register conflict graph."
  77         $$ Color.dotGraph regDotColor trivColorable (raGraph s)
  78
  79
  80  ppr (s@RegAllocStatsSpill{})
  81         =  text "#  Spill"
  82
  83         $$ text "#  Register conflict graph."
  84         $$ Color.dotGraph regDotColor trivColorable (raGraph s)
  85         $$ text ""
  86
  87         $$ (if (not $ isNullUFM $ raCoalesced s)
  88                 then    text "#  Registers coalesced."
  89                         $$ (vcat $ map ppr $ ufmToList $ raCoalesced s)
  90                         $$ text ""
  91                 else empty)
  92
  93         $$ text "#  Spills inserted."
  94         $$ ppr (raSpillStats s)
  95         $$ text ""
  96
  97         $$ text "#  Code with spills inserted."
  98         $$ (ppr (raSpilled s))
  99
 100
 101  ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) })
 102         =  text "#  Colored"
 103
 104         $$ text "#  Register conflict graph."
 105         $$ Color.dotGraph regDotColor trivColorable (raGraph s)
 106         $$ text ""
 107
 108         $$ (if (not $ isNullUFM $ raCoalesced s)
 109                 then    text "#  Registers coalesced."
 110                         $$ (vcat $ map ppr $ ufmToList $ raCoalesced s)
 111                         $$ text ""
 112                 else empty)
 113
 114         $$ text "#  Native code after register allocation."
 115         $$ ppr (raPatched s)
 116         $$ text ""
 117
 118         $$ text "#  Clean out unneeded spill/reloads."
 119         $$ ppr (raSpillClean s)
 120         $$ text ""
 121
 122         $$ text "#  Final code, after rewriting spill/rewrite pseudo instrs."
 123         $$ ppr (raFinal s)
 124         $$ text ""
 125         $$  text "#  Score:"
 126         $$ (text "#          spills  inserted: " <> int spills)
 127         $$ (text "#          reloads inserted: " <> int reloads)
 128         $$ (text "#   reg-reg moves remaining: " <> int moves)
 129         $$ text ""
 130
 131 -- | Do all the different analysis on this list of RegAllocStats
 132 pprStats :: [RegAllocStats] -> Color.Graph Reg RegClass Reg -> SDoc
 133 pprStats stats graph
 134  = let  outSpills       = pprStatsSpills    stats
 135         outLife         = pprStatsLifetimes stats
 136         outConflict     = pprStatsConflict  stats
 137         outScatter      = pprStatsLifeConflict stats graph
 138
 139   in    vcat [outSpills, outLife, outConflict, outScatter]
 140
 141
 142 -- | Dump a table of how many spill loads / stores were inserted for each vreg.
 143 pprStatsSpills
 144         :: [RegAllocStats] -> SDoc
 145
 146 pprStatsSpills stats
 147  = let
 148         finals  = [ s   | s@RegAllocStatsColored{} <- stats]
 149
 150         -- sum up how many stores/loads/reg-reg-moves were left in the code
 151         total   = foldl' addSRM (0, 0, 0)
 152                 $ map raSRMs finals
 153
 154     in  (  text "-- spills-added-total"
 155         $$ text "--    (stores, loads, reg_reg_moves_remaining)"
 156         $$ ppr total
 157         $$ text "")
 158
 159
 160 -- | Dump a table of how long vregs tend to live for in the initial code.
 161 pprStatsLifetimes
 162         :: [RegAllocStats] -> SDoc
 163
 164 pprStatsLifetimes stats
 165  = let  lifeMap         = foldl' plusUFM emptyUFM
 166                                 [ raLifetimes s | s@RegAllocStatsStart{} <- stats ]
 167         lifeBins        = binLifetimeCount lifeMap
 168
 169    in   (  text "-- vreg-population-lifetimes"
 170         $$ text "--   (instruction_count, number_of_vregs_that_lived_that_long)"
 171         $$ (vcat $ map ppr $ eltsUFM lifeBins)
 172         $$ text "\n")
 173
 174 binLifetimeCount :: UniqFM (Reg, Int) -> UniqFM (Int, Int)
 175 binLifetimeCount fm
 176  = let  lifes   = map (\l -> (l, (l, 1)))
 177                 $ map snd
 178                 $ eltsUFM fm
 179
 180    in   addListToUFM_C
 181                 (\(l1, c1) (l2, c2) -> (l1, c1 + c2))
 182                 emptyUFM
 183                 lifes
 184
 185
 186 -- | Dump a table of how many conflicts vregs tend to have in the initial code.
 187 pprStatsConflict
 188         :: [RegAllocStats] -> SDoc
 189
 190 pprStatsConflict stats
 191  = let  confMap = foldl' (plusUFM_C (\(c1, n1) (c2, n2) -> (c1, n1 + n2)))
 192                         emptyUFM
 193                 $ map Color.slurpNodeConflictCount
 194                         [ raGraph s | s@RegAllocStatsStart{} <- stats ]
 195
 196    in   (  text "-- vreg-conflicts"
 197         $$ text "--   (conflict_count, number_of_vregs_that_had_that_many_conflicts)"
 198         $$ (vcat $ map ppr $ eltsUFM confMap)
 199         $$ text "\n")
 200
 201
 202 -- | For every vreg, dump it's how many conflicts it has and its lifetime
 203 --      good for making a scatter plot.
 204 pprStatsLifeConflict
 205         :: [RegAllocStats]
 206         -> Color.Graph Reg RegClass Reg         -- ^ global register conflict graph
 207         -> SDoc
 208
 209 pprStatsLifeConflict stats graph
 210  = let  lifeMap = foldl' plusUFM emptyUFM
 211                         [ raLifetimes s | s@RegAllocStatsStart{} <- stats ]
 212
 213         scatter = map   (\r ->  let lifetime    = case lookupUFM lifeMap r of
 214                                                         Just (_, l)     -> l
 215                                                         Nothing         -> 0
 216                                     Just node   = Color.lookupNode graph r
 217                                 in parens $ hcat $ punctuate (text ", ")
 218                                         [ doubleQuotes $ ppr $ Color.nodeId node
 219                                         , ppr $ sizeUniqSet (Color.nodeConflicts node)
 220                                         , ppr $ lifetime ])
 221                 $ map Color.nodeId
 222                 $ eltsUFM
 223                 $ Color.graphMap graph
 224
 225    in   (  text "-- vreg-conflict-lifetime"
 226         $$ text "--   (vreg, vreg_conflicts, vreg_lifetime)"
 227         $$ (vcat scatter)
 228         $$ text "\n")
 229
 230
 231 -- | Count spill/reload/reg-reg moves.
 232 --      Lets us see how well the register allocator has done.
 233 --
 234 countSRMs :: LiveCmmTop -> (Int, Int, Int)
 235 countSRMs cmm
 236         = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0)
 237
 238 countSRM_block (BasicBlock i instrs)
 239  = do   instrs' <- mapM countSRM_instr instrs
 240         return  $ BasicBlock i instrs'
 241
 242 countSRM_instr li@(Instr instr live)
 243         | SPILL reg slot        <- instr
 244         = do    modify  $ \(s, r, m)    -> (s + 1, r, m)
 245                 return li
 246
 247         | RELOAD slot reg       <- instr
 248         = do    modify  $ \(s, r, m)    -> (s, r + 1, m)
 249                 return li
 250
 251         | Just _                <- isRegRegMove instr
 252         = do    modify  $ \(s, r, m)    -> (s, r, m + 1)
 253                 return li
 254
 255         | otherwise
 256         =       return li
 257
 258 -- sigh..
 259 addSRM (s1, r1, m1) (s2, r2, m2)
 260         = (s1+s2, r1+r2, m1+m2)
 261
 262 -----
 263 -- Register colors for drawing conflict graphs
 264 --      Keep this out of MachRegs.hs because it's specific to the graph coloring allocator.
 265
 266
 267 -- reg colors for x86
 268 #if i386_TARGET_ARCH
 269 regDotColor :: Reg -> SDoc
 270 regDotColor reg
 271  = let  Just    str     = lookupUFM regColors reg
 272    in   text str
 273
 274 regColors
 275  = listToUFM
 276  $      [ (eax, "#00ff00")
 277         , (ebx, "#0000ff")
 278         , (ecx, "#00ffff")
 279         , (edx, "#0080ff")
 280
 281         , (fake0, "#ff00ff")
 282         , (fake1, "#ff00aa")
 283         , (fake2, "#aa00ff")
 284         , (fake3, "#aa00aa")
 285         , (fake4, "#ff0055")
 286         , (fake5, "#5500ff") ]
 287 #endif
 288
 289
 290 -- reg colors for x86_64
 291 #if x86_64_TARGET_ARCH
 292 regDotColor :: Reg -> SDoc
 293 regDotColor reg
 294  = let  Just    str     = lookupUFM regColors reg
 295    in   text str
 296
 297 regColors
 298  = listToUFM
 299  $      [ (rax, "#00ff00"), (eax, "#00ff00")
 300         , (rbx, "#0000ff"), (ebx, "#0000ff")
 301         , (rcx, "#00ffff"), (ecx, "#00ffff")
 302         , (rdx, "#0080ff"), (edx, "#00ffff")
 303         , (r8,  "#00ff80")
 304         , (r9,  "#008080")
 305         , (r10, "#0040ff")
 306         , (r11, "#00ff40")
 307         , (r12, "#008040")
 308         , (r13, "#004080")
 309         , (r14, "#004040")
 310         , (r15, "#002080") ]
 311
 312         ++ zip (map RealReg [16..31]) (repeat "red")
 313 #endif
 314
 315
 316 -- reg colors for ppc
 317 #if powerpc_TARGET_ARCH
 318 regDotColor :: Reg -> SDoc
 319 regDotColor reg
 320  = case regClass reg of
 321         RcInteger       -> text "blue"
 322         RcFloat         -> text "red"
 323 #endif
 324
 325
 326 {-
 327 toX11Color (r, g, b)
 328  = let  rs      = padL 2 '0' (showHex r "")
 329         gs      = padL 2 '0' (showHex r "")
 330         bs      = padL 2 '0' (showHex r "")
 331
 332         padL n c s
 333                 = replicate (n - length s) c ++ s
 334   in    "#" ++ rs ++ gs ++ bs
 335 -}