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