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