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                 let code_nat            = map stripLive code_patched
 110
 111                 -- record what happened in this stage for debugging
 112                 let stat                =
 113                         RegAllocStatsColored
 114                         { raGraph       = graph_colored
 115                         , raPatchedCmm  = code_patched }
 116
 117                 return  ( code_nat
 118                         , [stat] ++ maybeToList stat1 ++ debug_codeGraphs
 119                         , graph_colored)
 120
 121          else do
 122                 -- spill the uncolored regs
 123                 (code_spilled, slotsFree', spillStats)
 124                         <- regSpill code slotsFree rsSpill
 125
 126                 -- recalculate liveness
 127                 let code_nat    = map stripLive code_spilled
 128                 code_relive     <- mapM regLiveness code_nat
 129
 130                 -- record what happened in this stage for debugging
 131                 let stat        =
 132                         RegAllocStatsSpill
 133                         { raGraph       = graph_colored
 134                         , raSpillStats  = spillStats
 135                         , raLifetimes   = fmLife
 136                         , raSpilled     = code_spilled }
 137
 138                 -- try again
 139                 regAlloc_spin (spinCount + 1) triv regsFree slotsFree'
 140                         ([stat] ++ maybeToList stat1 ++ debug_codeGraphs)
 141                         code_relive
 142
 143
 144 -----
 145 -- Simple maxconflicts isn't always good, because we
 146 --      can naievely end up spilling vregs that only live for one or two instrs.
 147 --
 148 {-
 149 chooseSpill_maxConflicts
 150         :: Color.Graph Reg RegClass Reg
 151         -> Reg
 152
 153 chooseSpill_maxConflicts graph
 154  = let  node    = maximumBy
 155                         (\n1 n2 -> compare
 156                                 (sizeUniqSet $ Color.nodeConflicts n1)
 157                                 (sizeUniqSet $ Color.nodeConflicts n2))
 158                 $ eltsUFM $ Color.graphMap graph
 159
 160    in   Color.nodeId node
 161 -}
 162
 163 -----
 164 chooseSpill_maxLife
 165         :: UniqFM (Reg, Int)
 166         -> Color.Graph Reg RegClass Reg
 167         -> Reg
 168
 169 chooseSpill_maxLife life graph
 170  = let  node    = maximumBy (\n1 n2 -> compare (getLife n1) (getLife n2))
 171                 $ eltsUFM $ Color.graphMap graph
 172
 173         -- Orphan vregs die in the same instruction they are born in.
 174         --      They will be in the graph, but not in the liveness map.
 175         --      Their liveness is 0.
 176         getLife n
 177          = case lookupUFM life (Color.nodeId n) of
 178                 Just (_, l)     -> l
 179                 Nothing         -> 0
 180
 181    in   Color.nodeId node
 182
 183
 184 -- | Build a graph from the liveness and coalesce information in this code.
 185
 186 buildGraph
 187         :: [LiveCmmTop]
 188         -> UniqSM (Color.Graph Reg RegClass Reg)
 189
 190 buildGraph code
 191  = do
 192         -- Add the reg-reg conflicts to the graph
 193         let conflictSets        = unionManyBags (map slurpConflicts code)
 194         let graph_conflict      = foldrBag graphAddConflictSet Color.initGraph conflictSets
 195
 196
 197         -- Add the coalescences edges to the graph.
 198         let coalesce            = unionManyBags (map slurpJoinMovs code)
 199         let graph_coalesce      = foldrBag graphAddCoalesce graph_conflict coalesce
 200
 201         return  $ graph_coalesce
 202
 203
 204 -- | Add some conflict edges to the graph.
 205 --      Conflicts between virtual and real regs are recorded as exclusions.
 206 --
 207 graphAddConflictSet
 208         :: UniqSet Reg
 209         -> Color.Graph Reg RegClass Reg
 210         -> Color.Graph Reg RegClass Reg
 211
 212 graphAddConflictSet set graph
 213  = let  reals           = filterUFM isRealReg set
 214         virtuals        = filterUFM (not . isRealReg) set
 215
 216         graph1  = Color.addConflicts virtuals regClass graph
 217         graph2  = foldr (\(r1, r2) -> Color.addExclusion r1 regClass r2)
 218                         graph1
 219                         [ (a, b)
 220                                 | a <- uniqSetToList virtuals
 221                                 , b <- uniqSetToList reals]
 222
 223    in   graph2
 224
 225
 226 -- | Add some coalesence edges to the graph
 227 --      Coalesences between virtual and real regs are recorded as preferences.
 228 --
 229 graphAddCoalesce
 230         :: (Reg, Reg)
 231         -> Color.Graph Reg RegClass Reg
 232         -> Color.Graph Reg RegClass Reg
 233
 234 graphAddCoalesce (r1, r2) graph
 235         | RealReg regno <- r1
 236         = Color.addPreference (regWithClass r2) r1 graph
 237
 238         | RealReg regno <- r2
 239         = Color.addPreference (regWithClass r1) r2 graph
 240
 241         | otherwise
 242         = Color.addCoalesce (regWithClass r1) (regWithClass r2) graph
 243
 244         where   regWithClass r  = (r, regClass r)
 245
 246
 247 -- | Patch registers in code using the reg -> reg mapping in this graph.
 248 patchRegsFromGraph
 249         :: Color.Graph Reg RegClass Reg
 250         -> LiveCmmTop -> LiveCmmTop
 251
 252 patchRegsFromGraph graph code
 253  = let
 254         -- a function to lookup the hardreg for a virtual reg from the graph.
 255         patchF reg
 256                 -- leave real regs alone.
 257                 | isRealReg reg
 258                 = reg
 259
 260                 -- this virtual has a regular node in the graph.
 261                 | Just node     <- Color.lookupNode graph reg
 262                 = case Color.nodeColor node of
 263                         Just color      -> color
 264                         Nothing         -> reg
 265
 266                 -- no node in the graph for this virtual, bad news.
 267                 | otherwise
 268                 = pprPanic "patchRegsFromGraph: register mapping failed."
 269                         (  text "There is no node in the graph for register " <> ppr reg
 270                         $$ ppr code
 271                         $$ Color.dotGraph (\x -> text "white") trivColorable graph)
 272
 273    in   patchEraseLive patchF code
 274
 275
 276 plusUFMs_C  :: (elt -> elt -> elt) -> [UniqFM elt] -> UniqFM elt
 277 plusUFMs_C f maps
 278         = foldl (plusUFM_C f) emptyUFM maps
 279