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