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