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