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