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