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_colored_lint
 167                         , raCoalesced   = rmCoalesce
 168                         , raPatched     = code_patched
 169                         , raSpillClean  = code_spillclean
 170                         , raFinal       = code_final
 171                         , raSRMs        = foldl' addSRM (0, 0, 0) $ map countSRMs code_spillclean }
 172
 173
 174                 let statList =
 175                         if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
 176                                 else []
 177
 178                 -- space leak avoidance
 179                 seqList statList `seq` return ()
 180
 181                 return  ( code_final
 182                         , statList
 183                         , graph_colored_lint)
 184
 185          -- we couldn't find a coloring, time to spill something
 186          else do
 187                 -- if -fasm-lint is turned on then validate the graph
 188                 let graph_colored_lint  =
 189                         if dopt Opt_DoAsmLinting dflags
 190                                 then Color.validateGraph (text "")
 191                                         False   -- don't require nodes to be colored
 192                                         graph_colored
 193                                 else graph_colored
 194
 195                 -- spill the uncolored regs
 196                 (code_spilled, slotsFree', spillStats)
 197                         <- regSpill code_coalesced2 slotsFree rsSpill
 198
 199                 -- recalculate liveness
 200                 let code_nat    = map stripLive code_spilled
 201                 code_relive     <- mapM regLiveness code_nat
 202
 203                 -- record what happened in this stage for debugging
 204                 let stat        =
 205                         RegAllocStatsSpill
 206                         { raGraph       = graph_colored_lint
 207                         , raCoalesced   = rmCoalesce
 208                         , raSpillStats  = spillStats
 209                         , raSpillCosts  = spillCosts
 210                         , raSpilled     = code_spilled }
 211
 212                 let statList =
 213                         if dump
 214                                 then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
 215                                 else []
 216
 217                 -- space leak avoidance
 218                 seqList statList `seq` return ()
 219
 220                 regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree'
 221                         statList
 222                         code_relive
 223
 224
 225
 226 -- | Build a graph from the liveness and coalesce information in this code.
 227
 228 buildGraph
 229         :: [LiveCmmTop]
 230         -> UniqSM (Color.Graph Reg RegClass Reg)
 231
 232 buildGraph code
 233  = do
 234         -- Slurp out the conflicts and reg->reg moves from this code
 235         let (conflictList, moveList) =
 236                 unzip $ map slurpConflicts code
 237
 238         -- Slurp out the spill/reload coalesces
 239         let moveList2           = map slurpReloadCoalesce code
 240
 241         -- Add the reg-reg conflicts to the graph
 242         let conflictBag         = unionManyBags conflictList
 243         let graph_conflict      = foldrBag graphAddConflictSet Color.initGraph conflictBag
 244
 245         -- Add the coalescences edges to the graph.
 246         let moveBag             = unionBags (unionManyBags moveList2) (unionManyBags moveList)
 247         let graph_coalesce      = foldrBag graphAddCoalesce graph_conflict moveBag
 248
 249         return  graph_coalesce
 250
 251
 252 -- | Add some conflict edges to the graph.
 253 --      Conflicts between virtual and real regs are recorded as exclusions.
 254 --
 255 graphAddConflictSet
 256         :: UniqSet Reg
 257         -> Color.Graph Reg RegClass Reg
 258         -> Color.Graph Reg RegClass Reg
 259
 260 graphAddConflictSet set graph
 261  = let  reals           = filterUFM isRealReg set
 262         virtuals        = filterUFM (not . isRealReg) set
 263
 264         graph1  = Color.addConflicts virtuals regClass graph
 265         graph2  = foldr (\(r1, r2) -> Color.addExclusion r1 regClass r2)
 266                         graph1
 267                         [ (a, b)
 268                                 | a <- uniqSetToList virtuals
 269                                 , b <- uniqSetToList reals]
 270
 271    in   graph2
 272
 273
 274 -- | Add some coalesence edges to the graph
 275 --      Coalesences between virtual and real regs are recorded as preferences.
 276 --
 277 graphAddCoalesce
 278         :: (Reg, Reg)
 279         -> Color.Graph Reg RegClass Reg
 280         -> Color.Graph Reg RegClass Reg
 281
 282 graphAddCoalesce (r1, r2) graph
 283         | RealReg _ <- r1
 284         = Color.addPreference (regWithClass r2) r1 graph
 285
 286         | RealReg _ <- r2
 287         = Color.addPreference (regWithClass r1) r2 graph
 288
 289         | otherwise
 290         = Color.addCoalesce (regWithClass r1) (regWithClass r2) graph
 291
 292         where   regWithClass r  = (r, regClass r)
 293
 294
 295 -- | Patch registers in code using the reg -> reg mapping in this graph.
 296 patchRegsFromGraph
 297         :: Color.Graph Reg RegClass Reg
 298         -> LiveCmmTop -> LiveCmmTop
 299
 300 patchRegsFromGraph graph code
 301  = let
 302         -- a function to lookup the hardreg for a virtual reg from the graph.
 303         patchF reg
 304                 -- leave real regs alone.
 305                 | isRealReg reg
 306                 = reg
 307
 308                 -- this virtual has a regular node in the graph.
 309                 | Just node     <- Color.lookupNode graph reg
 310                 = case Color.nodeColor node of
 311                         Just color      -> color
 312                         Nothing         -> reg
 313
 314                 -- no node in the graph for this virtual, bad news.
 315                 | otherwise
 316                 = pprPanic "patchRegsFromGraph: register mapping failed."
 317                         (  text "There is no node in the graph for register " <> ppr reg
 318                         $$ ppr code
 319                         $$ Color.dotGraph (\_ -> text "white") trivColorable graph)
 320
 321    in   patchEraseLive patchF code
 322
 323
 324 -----
 325 -- for when laziness just isn't what you wanted...
 326 --
 327 seqGraph :: Color.Graph Reg RegClass Reg -> ()
 328 seqGraph graph          = seqNodes (eltsUFM (Color.graphMap graph))
 329
 330 seqNodes :: [Color.Node Reg RegClass Reg] -> ()
 331 seqNodes ns
 332  = case ns of
 333         []              -> ()
 334         (n : ns)        -> seqNode n `seq` seqNodes ns
 335
 336 seqNode :: Color.Node Reg RegClass Reg -> ()
 337 seqNode node
 338         =     seqReg      (Color.nodeId node)
 339         `seq` seqRegClass (Color.nodeClass node)
 340         `seq` seqMaybeReg (Color.nodeColor node)
 341         `seq` (seqRegList (uniqSetToList (Color.nodeConflicts node)))
 342         `seq` (seqRegList (uniqSetToList (Color.nodeExclusions node)))
 343         `seq` (seqRegList (Color.nodePreference node))
 344         `seq` (seqRegList (uniqSetToList (Color.nodeCoalesce node)))
 345
 346 seqReg :: Reg -> ()
 347 seqReg reg
 348  = case reg of
 349         RealReg _       -> ()
 350         VirtualRegI _   -> ()
 351         VirtualRegHi _  -> ()
 352         VirtualRegF _   -> ()
 353         VirtualRegD _   -> ()
 354
 355 seqRegClass :: RegClass -> ()
 356 seqRegClass c
 357  = case c of
 358         RcInteger       -> ()
 359         RcFloat         -> ()
 360         RcDouble        -> ()
 361
 362 seqMaybeReg :: Maybe Reg -> ()
 363 seqMaybeReg mr
 364  = case mr of
 365         Nothing         -> ()
 366         Just r          -> seqReg r
 367
 368 seqRegList :: [Reg] -> ()
 369 seqRegList rs
 370  = case rs of
 371         []              -> ()
 372         (r : rs)        -> seqReg r `seq` seqRegList rs
 373
 374 seqList :: [a] -> ()
 375 seqList ls
 376  = case ls of
 377         []              -> ()
 378         (r : rs)        -> r `seq` seqList rs
 379
 380