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