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