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