compiler/nativeGen/RegAllocStats.hs

   1
   2 -- Carries interesting info for debugging / profiling of the
   3 --      graph coloring register allocator.
   4
   5 {-# OPTIONS_GHC -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/WorkingConventions#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         , raSpillStats  :: SpillStats                   -- ^ spiller stats
  56         , raLifetimes   :: UniqFM (Reg, Int)            -- ^ number of instrs each reg lives for
  57         , raSpilled     :: [LiveCmmTop] }               -- ^ code with spill instructions added
  58
  59         -- a successful coloring
  60         | RegAllocStatsColored
  61         { raGraph       :: Color.Graph Reg RegClass Reg -- ^ the colored graph
  62         , raPatched     :: [LiveCmmTop]                 -- ^ code with vregs replaced by hregs
  63         , raSpillClean  :: [LiveCmmTop]                 -- ^ code with unneeded spill/reloads cleaned out
  64         , raFinal       :: [NatCmmTop]                  -- ^ final code
  65         , raSRMs        :: (Int, Int, Int) }            -- ^ spill/reload/reg-reg moves present in this code
  66
  67 instance Outputable RegAllocStats where
  68
  69  ppr (s@RegAllocStatsStart{})
  70         =  text "#  Start"
  71         $$ text "#  Native code with liveness information."
  72         $$ ppr (raLiveCmm s)
  73         $$ text ""
  74         $$ text "#  Initial register conflict graph."
  75         $$ Color.dotGraph regDotColor trivColorable (raGraph s)
  76
  77  ppr (s@RegAllocStatsSpill{})
  78         =  text "#  Spill"
  79         $$ text "#  Register conflict graph."
  80         $$ Color.dotGraph regDotColor trivColorable (raGraph s)
  81         $$ text ""
  82         $$ text "#  Spills inserted."
  83         $$ ppr (raSpillStats s)
  84         $$ text ""
  85         $$ text "#  Code with spills inserted."
  86         $$ (ppr (raSpilled s))
  87
  88  ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) })
  89         =  text "#  Colored"
  90         $$ text "#  Register conflict graph."
  91         $$ Color.dotGraph regDotColor trivColorable (raGraph s)
  92         $$ text ""
  93         $$ text "#  Native code after register allocation."
  94         $$ ppr (raPatched s)
  95         $$ text ""
  96         $$ text "#  Clean out unneeded spill/reloads."
  97         $$ ppr (raSpillClean s)
  98         $$ text ""
  99         $$ text "#  Final code, after rewriting spill/rewrite pseudo instrs."
 100         $$ ppr (raFinal s)
 101         $$ text ""
 102         $$  text "#  Score:"
 103         $$ (text "#          spills  inserted: " <> int spills)
 104         $$ (text "#          reloads inserted: " <> int reloads)
 105         $$ (text "#   reg-reg moves remaining: " <> int moves)
 106         $$ text ""
 107
 108 -- | Do all the different analysis on this list of RegAllocStats
 109 pprStats :: [RegAllocStats] -> Color.Graph Reg RegClass Reg -> SDoc
 110 pprStats stats graph
 111  = let  outSpills       = pprStatsSpills    stats
 112         outLife         = pprStatsLifetimes stats
 113         outConflict     = pprStatsConflict  stats
 114         outScatter      = pprStatsLifeConflict stats graph
 115
 116   in    vcat [outSpills, outLife, outConflict, outScatter]
 117
 118
 119 -- | Dump a table of how many spill loads / stores were inserted for each vreg.
 120 pprStatsSpills
 121         :: [RegAllocStats] -> SDoc
 122
 123 pprStatsSpills stats
 124  = let
 125         finals  = [ s   | s@RegAllocStatsColored{} <- stats]
 126
 127         -- sum up how many stores/loads/reg-reg-moves were left in the code
 128         total   = foldl' addSRM (0, 0, 0)
 129                 $ map raSRMs finals
 130
 131     in  (  text "-- spills-added-total"
 132         $$ text "--    (stores, loads, reg_reg_moves_remaining)"
 133         $$ ppr total
 134         $$ text "")
 135
 136
 137 -- | Dump a table of how long vregs tend to live for in the initial code.
 138 pprStatsLifetimes
 139         :: [RegAllocStats] -> SDoc
 140
 141 pprStatsLifetimes stats
 142  = let  lifeMap         = foldl' plusUFM emptyUFM
 143                                 [ raLifetimes s | s@RegAllocStatsStart{} <- stats ]
 144         lifeBins        = binLifetimeCount lifeMap
 145
 146    in   (  text "-- vreg-population-lifetimes"
 147         $$ text "--   (instruction_count, number_of_vregs_that_lived_that_long)"
 148         $$ (vcat $ map ppr $ eltsUFM lifeBins)
 149         $$ text "\n")
 150
 151 binLifetimeCount :: UniqFM (Reg, Int) -> UniqFM (Int, Int)
 152 binLifetimeCount fm
 153  = let  lifes   = map (\l -> (l, (l, 1)))
 154                 $ map snd
 155                 $ eltsUFM fm
 156
 157    in   addListToUFM_C
 158                 (\(l1, c1) (l2, c2) -> (l1, c1 + c2))
 159                 emptyUFM
 160                 lifes
 161
 162
 163 -- | Dump a table of how many conflicts vregs tend to have in the initial code.
 164 pprStatsConflict
 165         :: [RegAllocStats] -> SDoc
 166
 167 pprStatsConflict stats
 168  = let  confMap = foldl' (plusUFM_C (\(c1, n1) (c2, n2) -> (c1, n1 + n2)))
 169                         emptyUFM
 170                 $ map Color.slurpNodeConflictCount
 171                         [ raGraph s | s@RegAllocStatsStart{} <- stats ]
 172
 173    in   (  text "-- vreg-conflicts"
 174         $$ text "--   (conflict_count, number_of_vregs_that_had_that_many_conflicts)"
 175         $$ (vcat $ map ppr $ eltsUFM confMap)
 176         $$ text "\n")
 177
 178
 179 -- | For every vreg, dump it's how many conflicts it has and its lifetime
 180 --      good for making a scatter plot.
 181 pprStatsLifeConflict
 182         :: [RegAllocStats]
 183         -> Color.Graph Reg RegClass Reg         -- ^ global register conflict graph
 184         -> SDoc
 185
 186 pprStatsLifeConflict stats graph
 187  = let  lifeMap = foldl' plusUFM emptyUFM
 188                         [ raLifetimes s | s@RegAllocStatsStart{} <- stats ]
 189
 190         scatter = map   (\r ->  let lifetime    = case lookupUFM lifeMap r of
 191                                                         Just (_, l)     -> l
 192                                                         Nothing         -> 0
 193                                     Just node   = Color.lookupNode graph r
 194                                 in parens $ hcat $ punctuate (text ", ")
 195                                         [ doubleQuotes $ ppr $ Color.nodeId node
 196                                         , ppr $ sizeUniqSet (Color.nodeConflicts node)
 197                                         , ppr $ lifetime ])
 198                 $ map Color.nodeId
 199                 $ eltsUFM
 200                 $ Color.graphMap graph
 201
 202    in   (  text "-- vreg-conflict-lifetime"
 203         $$ text "--   (vreg, vreg_conflicts, vreg_lifetime)"
 204         $$ (vcat scatter)
 205         $$ text "\n")
 206
 207
 208 -- | Count spill/reload/reg-reg moves.
 209 --      Lets us see how well the register allocator has done.
 210 --
 211 countSRMs :: LiveCmmTop -> (Int, Int, Int)
 212 countSRMs cmm
 213         = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0)
 214
 215 countSRM_block (BasicBlock i instrs)
 216  = do   instrs' <- mapM countSRM_instr instrs
 217         return  $ BasicBlock i instrs'
 218
 219 countSRM_instr li@(Instr instr live)
 220         | SPILL reg slot        <- instr
 221         = do    modify  $ \(s, r, m)    -> (s + 1, r, m)
 222                 return li
 223
 224         | RELOAD slot reg       <- instr
 225         = do    modify  $ \(s, r, m)    -> (s, r + 1, m)
 226                 return li
 227
 228         | Just _                <- isRegRegMove instr
 229         = do    modify  $ \(s, r, m)    -> (s, r, m + 1)
 230                 return li
 231
 232         | otherwise
 233         =       return li
 234
 235 -- sigh..
 236 addSRM (s1, r1, m1) (s2, r2, m2)
 237         = (s1+s2, r1+r2, m1+m2)
 238
 239 -----
 240 -- Register colors for drawing conflict graphs
 241 --      Keep this out of MachRegs.hs because it's specific to the graph coloring allocator.
 242
 243
 244 -- reg colors for x86
 245 #if i386_TARGET_ARCH
 246 regDotColor :: Reg -> SDoc
 247 regDotColor reg
 248  = let  Just    str     = lookupUFM regColors reg
 249    in   text str
 250
 251 regColors
 252  = listToUFM
 253  $      [ (eax, "#00ff00")
 254         , (ebx, "#0000ff")
 255         , (ecx, "#00ffff")
 256         , (edx, "#0080ff")
 257
 258         , (fake0, "#ff00ff")
 259         , (fake1, "#ff00aa")
 260         , (fake2, "#aa00ff")
 261         , (fake3, "#aa00aa")
 262         , (fake4, "#ff0055")
 263         , (fake5, "#5500ff") ]
 264 #endif
 265
 266
 267 -- reg colors for x86_64
 268 #if x86_64_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  $      [ (rax, "#00ff00"), (eax, "#00ff00")
 277         , (rbx, "#0000ff"), (ebx, "#0000ff")
 278         , (rcx, "#00ffff"), (ecx, "#00ffff")
 279         , (rdx, "#0080ff"), (edx, "#00ffff")
 280         , (r8,  "#00ff80")
 281         , (r9,  "#008080")
 282         , (r10, "#0040ff")
 283         , (r11, "#00ff40")
 284         , (r12, "#008040")
 285         , (r13, "#004080")
 286         , (r14, "#004040")
 287         , (r15, "#002080") ]
 288
 289         ++ zip (map RealReg [16..31]) (repeat "red")
 290 #endif
 291
 292
 293 -- reg colors for ppc
 294 #if powerpc_TARGET_ARCH
 295 regDotColor :: Reg -> SDoc
 296 regDotColor reg
 297  = case regClass reg of
 298         RcInteger       -> text "blue"
 299         RcFloat         -> text "red"
 300 #endif
 301
 302
 303 {-
 304 toX11Color (r, g, b)
 305  = let  rs      = padL 2 '0' (showHex r "")
 306         gs      = padL 2 '0' (showHex r "")
 307         bs      = padL 2 '0' (showHex r "")
 308
 309         padL n c s
 310                 = replicate (n - length s) c ++ s
 311   in    "#" ++ rs ++ gs ++ bs
 312 -}