compiler/nativeGen/RegAllocColor.hs

   1 -- | Graph coloring register allocator.
   2 --
   3 -- TODO:
   4 --      Live range splitting:
   5 --              At the moment regs that are spilled are spilled for all time, even though
   6 --              we might be able to allocate them a hardreg in different parts of the code.
   7 --
   8 --      As we're aggressively coalescing before register allocation proper we're not currently
   9 --      using the coalescence information present in the graph.
  10 --
  11 --      The function that choosing the potential spills could be a bit cleverer.
  12 --
  13 --      Colors in graphviz graphs could be nicer.
  14 --
  15
  16 {-# OPTIONS -w #-}
  17 -- The above warning supression flag is a temporary kludge.
  18 -- While working on this module you are encouraged to remove it and fix
  19 -- any warnings in the module. See
  20 --     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
  21 -- for details
  22
  23 module RegAllocColor (
  24         regAlloc,
  25         regDotColor
  26 )
  27
  28 where
  29
  30 import qualified GraphColor     as Color
  31 import RegLiveness
  32 import RegSpill
  33 import RegSpillClean
  34 import RegAllocStats
  35 import MachRegs
  36 import MachInstrs
  37 import PprMach
  38
  39 import UniqSupply
  40 import UniqSet
  41 import UniqFM
  42 import Bag
  43 import Outputable
  44
  45 import Data.List
  46 import Data.Maybe
  47 import Control.Monad
  48
  49 -- | The maximum number of build/spill cycles we'll allow.
  50 --      We should only need 3 or 4 cycles tops.
  51 --      If we run for any longer than this we're probably in an infinite loop,
  52 --      It's probably better just to bail out and report a bug at this stage.
  53 maxSpinCount    :: Int
  54 maxSpinCount    = 10
  55
  56
  57 -- | The top level of the graph coloring register allocator.
  58 --
  59 regAlloc
  60         :: Bool                         -- ^ whether to generate RegAllocStats, or not.
  61         -> UniqFM (UniqSet Reg)         -- ^ the registers we can use for allocation
  62         -> UniqSet Int                  -- ^ the set of available spill slots.
  63         -> [LiveCmmTop]                 -- ^ code annotated with liveness information.
  64         -> UniqSM
  65                 ( [NatCmmTop]           -- ^ code with registers allocated.
  66                 , [RegAllocStats] )     -- ^ stats for each stage of allocation
  67
  68 regAlloc dump regsFree slotsFree code
  69  = do
  70         (code_final, debug_codeGraphs, graph_final)
  71                 <- regAlloc_spin dump 0 trivColorable regsFree slotsFree [] code
  72
  73         return  ( code_final
  74                 , reverse debug_codeGraphs )
  75
  76 regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
  77  = do
  78         -- check that we're not running off down the garden path.
  79         when (spinCount > maxSpinCount)
  80          $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded."
  81                 (  text "It looks like the register allocator is stuck in an infinite loop."
  82                 $$ text "max cycles  = " <> int maxSpinCount
  83                 $$ text "regsFree    = " <> (hcat       $ punctuate space $ map (docToSDoc . pprUserReg)
  84                                                 $ uniqSetToList $ unionManyUniqSets $ eltsUFM regsFree)
  85                 $$ text "slotsFree   = " <> ppr (sizeUniqSet slotsFree))
  86
  87         -- build a conflict graph from the code.
  88         graph           <- buildGraph code
  89
  90         -- build a map of how many instructions each reg lives for.
  91         --      this is lazy, it won't be computed unless we need to spill
  92         let fmLife      = plusUFMs_C (\(r1, l1) (r2, l2) -> (r1, l1 + l2))
  93                         $ map lifetimeCount code
  94
  95         -- record startup state
  96         let stat1       =
  97                 if spinCount == 0
  98                  then   Just $ RegAllocStatsStart
  99                         { raLiveCmm     = code
 100                         , raGraph       = graph
 101                         , raLifetimes   = fmLife }
 102                  else   Nothing
 103
 104
 105         -- the function to choose regs to leave uncolored
 106         let spill       = chooseSpill_maxLife fmLife
 107
 108         -- try and color the graph
 109         let (graph_colored, rsSpill, rmCoalesce)
 110                         = Color.colorGraph regsFree triv spill graph
 111
 112         -- rewrite regs in the code that have been coalesced
 113         let patchF reg  = case lookupUFM rmCoalesce reg of
 114                                 Just reg'       -> reg'
 115                                 Nothing         -> reg
 116         let code_coalesced
 117                         = map (patchEraseLive patchF) code
 118
 119
 120         -- see if we've found a coloring
 121         if isEmptyUniqSet rsSpill
 122          then do
 123                 -- patch the registers using the info in the graph
 124                 let code_patched        = map (patchRegsFromGraph graph_colored) code_coalesced
 125
 126                 -- clean out unneeded SPILL/RELOADs
 127                 let code_spillclean     = map cleanSpills code_patched
 128
 129                 -- strip off liveness information
 130                 let code_nat            = map stripLive code_patched
 131
 132                 -- rewrite SPILL/REALOAD pseudos into real instructions
 133                 let spillNatTop         = mapGenBlockTop spillNatBlock
 134                 let code_final          = map spillNatTop code_nat
 135
 136                 -- record what happened in this stage for debugging
 137                 let stat                =
 138                         RegAllocStatsColored
 139                         { raGraph       = graph_colored
 140                         , raCoalesced   = rmCoalesce
 141                         , raPatched     = code_patched
 142                         , raSpillClean  = code_spillclean
 143                         , raFinal       = code_final
 144                         , raSRMs        = foldl addSRM (0, 0, 0) $ map countSRMs code_spillclean }
 145
 146                 return  ( code_final
 147                         , if dump
 148                                 then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
 149                                 else []
 150                         , graph_colored)
 151
 152          else do
 153                 -- spill the uncolored regs
 154                 (code_spilled, slotsFree', spillStats)
 155                         <- regSpill code_coalesced slotsFree rsSpill
 156
 157                 -- recalculate liveness
 158                 let code_nat    = map stripLive code_spilled
 159                 code_relive     <- mapM regLiveness code_nat
 160
 161                 -- record what happened in this stage for debugging
 162                 let stat        =
 163                         RegAllocStatsSpill
 164                         { raGraph       = graph_colored
 165                         , raCoalesced   = rmCoalesce
 166                         , raSpillStats  = spillStats
 167                         , raLifetimes   = fmLife
 168                         , raSpilled     = code_spilled }
 169
 170                 -- try again
 171                 regAlloc_spin dump (spinCount + 1) triv regsFree slotsFree'
 172                         (if dump
 173                                 then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
 174                                 else [])
 175                         code_relive
 176
 177
 178 -----
 179 -- Simple maxconflicts isn't always good, because we
 180 --      can naievely end up spilling vregs that only live for one or two instrs.
 181 --
 182 {-
 183 chooseSpill_maxConflicts
 184         :: Color.Graph Reg RegClass Reg
 185         -> Reg
 186
 187 chooseSpill_maxConflicts graph
 188  = let  node    = maximumBy
 189                         (\n1 n2 -> compare
 190                                 (sizeUniqSet $ Color.nodeConflicts n1)
 191                                 (sizeUniqSet $ Color.nodeConflicts n2))
 192                 $ eltsUFM $ Color.graphMap graph
 193
 194    in   Color.nodeId node
 195 -}
 196
 197 -----
 198 chooseSpill_maxLife
 199         :: UniqFM (Reg, Int)
 200         -> Color.Graph Reg RegClass Reg
 201         -> Reg
 202
 203 chooseSpill_maxLife life graph
 204  = let  node    = maximumBy (\n1 n2 -> compare (getLife n1) (getLife n2))
 205                 $ eltsUFM $ Color.graphMap graph
 206
 207         -- Orphan vregs die in the same instruction they are born in.
 208         --      They will be in the graph, but not in the liveness map.
 209         --      Their liveness is 0.
 210         getLife n
 211          = case lookupUFM life (Color.nodeId n) of
 212                 Just (_, l)     -> l
 213                 Nothing         -> 0
 214
 215    in   Color.nodeId node
 216
 217
 218 -- | Build a graph from the liveness and coalesce information in this code.
 219
 220 buildGraph
 221         :: [LiveCmmTop]
 222         -> UniqSM (Color.Graph Reg RegClass Reg)
 223
 224 buildGraph code
 225  = do
 226         -- Slurp out the conflicts and reg->reg moves from this code
 227         let (conflictList, moveList) =
 228                 unzip $ map slurpConflicts code
 229
 230         let conflictBag         = unionManyBags conflictList
 231         let moveBag             = unionManyBags moveList
 232
 233         -- Add the reg-reg conflicts to the graph
 234         let graph_conflict      = foldrBag graphAddConflictSet Color.initGraph conflictBag
 235
 236         -- Add the coalescences edges to the graph.
 237         let graph_coalesce      = foldrBag graphAddCoalesce graph_conflict moveBag
 238
 239         return  graph_coalesce
 240
 241
 242 -- | Add some conflict edges to the graph.
 243 --      Conflicts between virtual and real regs are recorded as exclusions.
 244 --
 245 graphAddConflictSet
 246         :: UniqSet Reg
 247         -> Color.Graph Reg RegClass Reg
 248         -> Color.Graph Reg RegClass Reg
 249
 250 graphAddConflictSet set graph
 251  = let  reals           = filterUFM isRealReg set
 252         virtuals        = filterUFM (not . isRealReg) set
 253
 254         graph1  = Color.addConflicts virtuals regClass graph
 255         graph2  = foldr (\(r1, r2) -> Color.addExclusion r1 regClass r2)
 256                         graph1
 257                         [ (a, b)
 258                                 | a <- uniqSetToList virtuals
 259                                 , b <- uniqSetToList reals]
 260
 261    in   graph2
 262
 263
 264 -- | Add some coalesence edges to the graph
 265 --      Coalesences between virtual and real regs are recorded as preferences.
 266 --
 267 graphAddCoalesce
 268         :: (Reg, Reg)
 269         -> Color.Graph Reg RegClass Reg
 270         -> Color.Graph Reg RegClass Reg
 271
 272 graphAddCoalesce (r1, r2) graph
 273         | RealReg regno <- r1
 274         = Color.addPreference (regWithClass r2) r1 graph
 275
 276         | RealReg regno <- r2
 277         = Color.addPreference (regWithClass r1) r2 graph
 278
 279         | otherwise
 280         = Color.addCoalesce (regWithClass r1) (regWithClass r2) graph
 281
 282         where   regWithClass r  = (r, regClass r)
 283
 284
 285 -- | Patch registers in code using the reg -> reg mapping in this graph.
 286 patchRegsFromGraph
 287         :: Color.Graph Reg RegClass Reg
 288         -> LiveCmmTop -> LiveCmmTop
 289
 290 patchRegsFromGraph graph code
 291  = let
 292         -- a function to lookup the hardreg for a virtual reg from the graph.
 293         patchF reg
 294                 -- leave real regs alone.
 295                 | isRealReg reg
 296                 = reg
 297
 298                 -- this virtual has a regular node in the graph.
 299                 | Just node     <- Color.lookupNode graph reg
 300                 = case Color.nodeColor node of
 301                         Just color      -> color
 302                         Nothing         -> reg
 303
 304                 -- no node in the graph for this virtual, bad news.
 305                 | otherwise
 306                 = pprPanic "patchRegsFromGraph: register mapping failed."
 307                         (  text "There is no node in the graph for register " <> ppr reg
 308                         $$ ppr code
 309                         $$ Color.dotGraph (\x -> text "white") trivColorable graph)
 310
 311    in   patchEraseLive patchF code
 312
 313
 314 plusUFMs_C  :: (elt -> elt -> elt) -> [UniqFM elt] -> UniqFM elt
 315 plusUFMs_C f maps
 316         = foldl (plusUFM_C f) emptyUFM maps
 317