compiler/nativeGen/RegAllocColor.hs

   1 -- | Graph coloring register allocator.
   2 --
   3 -- TODO:
   4 --      The function that choosing the potential spills could be a bit cleverer.
   5 --      Colors in graphviz graphs could be nicer.
   6 --
   7 {-# OPTIONS -fno-warn-missing-signatures #-}
   8
   9 module RegAllocColor (
  10         regAlloc,
  11         regDotColor
  12 )
  13
  14 where
  15
  16 import qualified GraphColor     as Color
  17 import RegLiveness
  18 import RegSpill
  19 import RegSpillClean
  20 import RegAllocStats
  21 -- import RegCoalesce
  22 import MachRegs
  23 import MachInstrs
  24 import PprMach
  25
  26 import UniqSupply
  27 import UniqSet
  28 import UniqFM
  29 import Bag
  30 import Outputable
  31 import DynFlags
  32
  33 import Data.List
  34 import Data.Maybe
  35 import Control.Monad
  36
  37 -- | The maximum number of build/spill cycles we'll allow.
  38 --      We should only need 3 or 4 cycles tops.
  39 --      If we run for any longer than this we're probably in an infinite loop,
  40 --      It's probably better just to bail out and report a bug at this stage.
  41 maxSpinCount    :: Int
  42 maxSpinCount    = 10
  43
  44
  45 -- | The top level of the graph coloring register allocator.
  46 --
  47 regAlloc
  48         :: DynFlags
  49         -> UniqFM (UniqSet Reg)         -- ^ the registers we can use for allocation
  50         -> UniqSet Int                  -- ^ the set of available spill slots.
  51         -> [LiveCmmTop]                 -- ^ code annotated with liveness information.
  52         -> UniqSM
  53                 ( [NatCmmTop]           -- ^ code with registers allocated.
  54                 , [RegAllocStats] )     -- ^ stats for each stage of allocation
  55
  56 regAlloc dflags regsFree slotsFree code
  57  = do
  58         (code_final, debug_codeGraphs, _)
  59                 <- regAlloc_spin dflags 0 trivColorable regsFree slotsFree [] code
  60
  61         return  ( code_final
  62                 , reverse debug_codeGraphs )
  63
  64 regAlloc_spin dflags (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
  65  = do
  66         -- if any of these dump flags are turned on we want to hang on to
  67         --      intermediate structures in the allocator - otherwise tell the
  68         --      allocator to ditch them early so we don't end up creating space leaks.
  69         let dump = or
  70                 [ dopt Opt_D_dump_asm_regalloc_stages dflags
  71                 , dopt Opt_D_dump_asm_stats dflags
  72                 , dopt Opt_D_dump_asm_conflicts dflags ]
  73
  74         -- check that we're not running off down the garden path.
  75         when (spinCount > maxSpinCount)
  76          $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded."
  77                 (  text "It looks like the register allocator is stuck in an infinite loop."
  78                 $$ text "max cycles  = " <> int maxSpinCount
  79                 $$ text "regsFree    = " <> (hcat       $ punctuate space $ map (docToSDoc . pprUserReg)
  80                                                 $ uniqSetToList $ unionManyUniqSets $ eltsUFM regsFree)
  81                 $$ text "slotsFree   = " <> ppr (sizeUniqSet slotsFree))
  82
  83
  84         -- Brig's algorithm does reckless coalescing for all but the first allocation stage
  85         --      Doing this seems to reduce the number of reg-reg moves, but at the cost-
  86         --      of creating more spills. Probably better just to stick with conservative
  87         --      coalescing in Color.colorGraph for now.
  88         --
  89         {- code_coalesced1      <- if (spinCount > 0)
  90                                 then regCoalesce code
  91                                 else return code -}
  92
  93         let code_coalesced1     = code
  94
  95
  96         -- build a conflict graph from the code.
  97         graph           <- {-# SCC "BuildGraph" #-} buildGraph code_coalesced1
  98
  99         -- VERY IMPORTANT:
 100         --      We really do want the graph to be fully evaluated _before_ we start coloring.
 101         --      If we don't do this now then when the call to Color.colorGraph forces bits of it,
 102         --      the heap will be filled with half evaluated pieces of graph and zillions of apply thunks.
 103         --
 104         seqGraph graph `seq` return ()
 105
 106
 107         -- build a map of how many instructions each reg lives for.
 108         --      this is lazy, it won't be computed unless we need to spill
 109
 110         let fmLife      = {-# SCC "LifetimeCount" #-} plusUFMs_C (\(r1, l1) (_, l2) -> (r1, l1 + l2))
 111                         $ map lifetimeCount code_coalesced1
 112
 113         -- record startup state
 114         let stat1       =
 115                 if spinCount == 0
 116                  then   Just $ RegAllocStatsStart
 117                         { raLiveCmm     = code
 118                         , raGraph       = graph
 119                         , raLifetimes   = fmLife }
 120                  else   Nothing
 121
 122
 123         -- the function to choose regs to leave uncolored
 124         let spill       = chooseSpill_maxLife fmLife
 125
 126         -- try and color the graph
 127         let (graph_colored, rsSpill, rmCoalesce)
 128                         = {-# SCC "ColorGraph" #-}
 129                            Color.colorGraph
 130                                 (dopt Opt_RegsIterative dflags)
 131                                 spinCount
 132                                 regsFree triv spill graph
 133
 134         -- rewrite regs in the code that have been coalesced
 135         let patchF reg  = case lookupUFM rmCoalesce reg of
 136                                 Just reg'       -> patchF reg'
 137                                 Nothing         -> reg
 138         let code_coalesced2
 139                         = map (patchEraseLive patchF) code_coalesced1
 140
 141
 142         -- see if we've found a coloring
 143         if isEmptyUniqSet rsSpill
 144          then do
 145                 -- patch the registers using the info in the graph
 146                 let code_patched        = map (patchRegsFromGraph graph_colored) code_coalesced2
 147
 148                 -- clean out unneeded SPILL/RELOADs
 149                 let code_spillclean     = map cleanSpills code_patched
 150
 151                 -- strip off liveness information
 152                 let code_nat            = map stripLive code_spillclean
 153
 154                 -- rewrite SPILL/RELOAD pseudos into real instructions
 155                 let spillNatTop         = mapGenBlockTop spillNatBlock
 156                 let code_final          = map spillNatTop code_nat
 157
 158                 -- record what happened in this stage for debugging
 159                 let stat                =
 160                         RegAllocStatsColored
 161                         { raGraph       = graph_colored
 162                         , raCoalesced   = rmCoalesce
 163                         , raPatched     = code_patched
 164                         , raSpillClean  = code_spillclean
 165                         , raFinal       = code_final
 166                         , raSRMs        = foldl' addSRM (0, 0, 0) $ map countSRMs code_spillclean }
 167
 168
 169                 let statList =
 170                         if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
 171                                 else []
 172
 173                 -- space leak avoidance
 174                 seqList statList `seq` return ()
 175
 176                 return  ( code_final
 177                         , statList
 178                         , graph_colored)
 179
 180          else do
 181                 -- spill the uncolored regs
 182                 (code_spilled, slotsFree', spillStats)
 183                         <- regSpill code_coalesced2 slotsFree rsSpill
 184
 185                 -- recalculate liveness
 186                 let code_nat    = map stripLive code_spilled
 187                 code_relive     <- mapM regLiveness code_nat
 188
 189                 -- record what happened in this stage for debugging
 190                 let stat        =
 191                         RegAllocStatsSpill
 192                         { raGraph       = graph_colored
 193                         , raCoalesced   = rmCoalesce
 194                         , raSpillStats  = spillStats
 195                         , raLifetimes   = fmLife
 196                         , raSpilled     = code_spilled }
 197
 198                 let statList =
 199                         if dump
 200                                 then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
 201                                 else []
 202
 203                 -- space leak avoidance
 204                 seqList statList `seq` return ()
 205
 206                 regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree'
 207                         statList
 208                         code_relive
 209
 210
 211 -----
 212 -- Simple maxconflicts isn't always good, because we
 213 --      can naievely end up spilling vregs that only live for one or two instrs.
 214 --
 215 {-
 216 chooseSpill_maxConflicts
 217         :: Color.Graph Reg RegClass Reg
 218         -> Reg
 219
 220 chooseSpill_maxConflicts graph
 221  = let  node    = maximumBy
 222                         (\n1 n2 -> compare
 223                                 (sizeUniqSet $ Color.nodeConflicts n1)
 224                                 (sizeUniqSet $ Color.nodeConflicts n2))
 225                 $ eltsUFM $ Color.graphMap graph
 226
 227    in   Color.nodeId node
 228 -}
 229
 230 -----
 231 chooseSpill_maxLife
 232         :: UniqFM (Reg, Int)
 233         -> Color.Graph Reg RegClass Reg
 234         -> Reg
 235
 236 chooseSpill_maxLife life graph
 237  = let  node    = maximumBy (\n1 n2 -> compare (getLife n1) (getLife n2))
 238                 $ eltsUFM $ Color.graphMap graph
 239
 240         -- Orphan vregs die in the same instruction they are born in.
 241         --      They will be in the graph, but not in the liveness map.
 242         --      Their liveness is 0.
 243         getLife n
 244          = case lookupUFM life (Color.nodeId n) of
 245                 Just (_, l)     -> l
 246                 Nothing         -> 0
 247
 248    in   Color.nodeId node
 249
 250
 251 -- | Build a graph from the liveness and coalesce information in this code.
 252
 253 buildGraph
 254         :: [LiveCmmTop]
 255         -> UniqSM (Color.Graph Reg RegClass Reg)
 256
 257 buildGraph code
 258  = do
 259         -- Slurp out the conflicts and reg->reg moves from this code
 260         let (conflictList, moveList) =
 261                 unzip $ map slurpConflicts code
 262
 263         -- Slurp out the spill/reload coalesces
 264         let moveList2           = map slurpReloadCoalesce code
 265
 266         -- Add the reg-reg conflicts to the graph
 267         let conflictBag         = unionManyBags conflictList
 268         let graph_conflict      = foldrBag graphAddConflictSet Color.initGraph conflictBag
 269
 270         -- Add the coalescences edges to the graph.
 271         let moveBag             = unionBags (unionManyBags moveList2) (unionManyBags moveList)
 272         let graph_coalesce      = foldrBag graphAddCoalesce graph_conflict moveBag
 273
 274         return  graph_coalesce
 275
 276
 277 -- | Add some conflict edges to the graph.
 278 --      Conflicts between virtual and real regs are recorded as exclusions.
 279 --
 280 graphAddConflictSet
 281         :: UniqSet Reg
 282         -> Color.Graph Reg RegClass Reg
 283         -> Color.Graph Reg RegClass Reg
 284
 285 graphAddConflictSet set graph
 286  = let  reals           = filterUFM isRealReg set
 287         virtuals        = filterUFM (not . isRealReg) set
 288
 289         graph1  = Color.addConflicts virtuals regClass graph
 290         graph2  = foldr (\(r1, r2) -> Color.addExclusion r1 regClass r2)
 291                         graph1
 292                         [ (a, b)
 293                                 | a <- uniqSetToList virtuals
 294                                 , b <- uniqSetToList reals]
 295
 296    in   graph2
 297
 298
 299 -- | Add some coalesence edges to the graph
 300 --      Coalesences between virtual and real regs are recorded as preferences.
 301 --
 302 graphAddCoalesce
 303         :: (Reg, Reg)
 304         -> Color.Graph Reg RegClass Reg
 305         -> Color.Graph Reg RegClass Reg
 306
 307 graphAddCoalesce (r1, r2) graph
 308         | RealReg _ <- r1
 309         = Color.addPreference (regWithClass r2) r1 graph
 310
 311         | RealReg _ <- r2
 312         = Color.addPreference (regWithClass r1) r2 graph
 313
 314         | otherwise
 315         = Color.addCoalesce (regWithClass r1) (regWithClass r2) graph
 316
 317         where   regWithClass r  = (r, regClass r)
 318
 319
 320 -- | Patch registers in code using the reg -> reg mapping in this graph.
 321 patchRegsFromGraph
 322         :: Color.Graph Reg RegClass Reg
 323         -> LiveCmmTop -> LiveCmmTop
 324
 325 patchRegsFromGraph graph code
 326  = let
 327         -- a function to lookup the hardreg for a virtual reg from the graph.
 328         patchF reg
 329                 -- leave real regs alone.
 330                 | isRealReg reg
 331                 = reg
 332
 333                 -- this virtual has a regular node in the graph.
 334                 | Just node     <- Color.lookupNode graph reg
 335                 = case Color.nodeColor node of
 336                         Just color      -> color
 337                         Nothing         -> reg
 338
 339                 -- no node in the graph for this virtual, bad news.
 340                 | otherwise
 341                 = pprPanic "patchRegsFromGraph: register mapping failed."
 342                         (  text "There is no node in the graph for register " <> ppr reg
 343                         $$ ppr code
 344                         $$ Color.dotGraph (\_ -> text "white") trivColorable graph)
 345
 346    in   patchEraseLive patchF code
 347
 348
 349 plusUFMs_C  :: (elt -> elt -> elt) -> [UniqFM elt] -> UniqFM elt
 350 plusUFMs_C f maps
 351         = foldl' (plusUFM_C f) emptyUFM maps
 352
 353
 354 -----
 355 -- for when laziness just isn't what you wanted...
 356 --
 357 seqGraph :: Color.Graph Reg RegClass Reg -> ()
 358 seqGraph graph          = seqNodes (eltsUFM (Color.graphMap graph))
 359
 360 seqNodes :: [Color.Node Reg RegClass Reg] -> ()
 361 seqNodes ns
 362  = case ns of
 363         []              -> ()
 364         (n : ns)        -> seqNode n `seq` seqNodes ns
 365
 366 seqNode :: Color.Node Reg RegClass Reg -> ()
 367 seqNode node
 368         =     seqReg      (Color.nodeId node)
 369         `seq` seqRegClass (Color.nodeClass node)
 370         `seq` seqMaybeReg (Color.nodeColor node)
 371         `seq` (seqRegList (uniqSetToList (Color.nodeConflicts node)))
 372         `seq` (seqRegList (uniqSetToList (Color.nodeExclusions node)))
 373         `seq` (seqRegList (Color.nodePreference node))
 374         `seq` (seqRegList (uniqSetToList (Color.nodeCoalesce node)))
 375
 376 seqReg :: Reg -> ()
 377 seqReg reg
 378  = case reg of
 379         RealReg _       -> ()
 380         VirtualRegI _   -> ()
 381         VirtualRegHi _  -> ()
 382         VirtualRegF _   -> ()
 383         VirtualRegD _   -> ()
 384
 385 seqRegClass :: RegClass -> ()
 386 seqRegClass c
 387  = case c of
 388         RcInteger       -> ()
 389         RcFloat         -> ()
 390         RcDouble        -> ()
 391
 392 seqMaybeReg :: Maybe Reg -> ()
 393 seqMaybeReg mr
 394  = case mr of
 395         Nothing         -> ()
 396         Just r          -> seqReg r
 397
 398 seqRegList :: [Reg] -> ()
 399 seqRegList rs
 400  = case rs of
 401         []              -> ()
 402         (r : rs)        -> seqReg r `seq` seqRegList rs
 403
 404 seqList :: [a] -> ()
 405 seqList ls
 406  = case ls of
 407         []              -> ()
 408         (r : rs)        -> r `seq` seqList rs
 409
 410