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
  31 import Data.List
  32 import Data.Maybe
  33 import Control.Monad
  34
  35 -- | The maximum number of build/spill cycles we'll allow.
  36 --      We should only need 3 or 4 cycles tops.
  37 --      If we run for any longer than this we're probably in an infinite loop,
  38 --      It's probably better just to bail out and report a bug at this stage.
  39 maxSpinCount    :: Int
  40 maxSpinCount    = 10
  41
  42
  43 -- | The top level of the graph coloring register allocator.
  44 --
  45 regAlloc
  46         :: Bool                         -- ^ whether to generate RegAllocStats, or not.
  47         -> UniqFM (UniqSet Reg)         -- ^ the registers we can use for allocation
  48         -> UniqSet Int                  -- ^ the set of available spill slots.
  49         -> [LiveCmmTop]                 -- ^ code annotated with liveness information.
  50         -> UniqSM
  51                 ( [NatCmmTop]           -- ^ code with registers allocated.
  52                 , [RegAllocStats] )     -- ^ stats for each stage of allocation
  53
  54 regAlloc dump regsFree slotsFree code
  55  = do
  56         (code_final, debug_codeGraphs, _)
  57                 <- regAlloc_spin dump 0 trivColorable regsFree slotsFree [] code
  58
  59         return  ( code_final
  60                 , reverse debug_codeGraphs )
  61
  62 regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
  63  = do
  64         -- check that we're not running off down the garden path.
  65         when (spinCount > maxSpinCount)
  66          $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded."
  67                 (  text "It looks like the register allocator is stuck in an infinite loop."
  68                 $$ text "max cycles  = " <> int maxSpinCount
  69                 $$ text "regsFree    = " <> (hcat       $ punctuate space $ map (docToSDoc . pprUserReg)
  70                                                 $ uniqSetToList $ unionManyUniqSets $ eltsUFM regsFree)
  71                 $$ text "slotsFree   = " <> ppr (sizeUniqSet slotsFree))
  72
  73         -- build a conflict graph from the code.
  74         graph           <- {-# SCC "BuildGraph" #-} buildGraph code
  75
  76         -- VERY IMPORTANT:
  77         --      We really do want the graph to be fully evaluated _before_ we start coloring.
  78         --      If we don't do this now then when the call to Color.colorGraph forces bits of it,
  79         --      the heap will be filled with half evaluated pieces of graph and zillions of apply thunks.
  80         --
  81         seqGraph graph `seq` return ()
  82
  83
  84         -- build a map of how many instructions each reg lives for.
  85         --      this is lazy, it won't be computed unless we need to spill
  86
  87         let fmLife      = {-# SCC "LifetimeCount" #-} plusUFMs_C (\(r1, l1) (_, l2) -> (r1, l1 + l2))
  88                         $ map lifetimeCount code
  89
  90         -- record startup state
  91         let stat1       =
  92                 if spinCount == 0
  93                  then   Just $ RegAllocStatsStart
  94                         { raLiveCmm     = code
  95                         , raGraph       = graph
  96                         , raLifetimes   = fmLife }
  97                  else   Nothing
  98
  99
 100         -- the function to choose regs to leave uncolored
 101         let spill       = chooseSpill_maxLife fmLife
 102
 103         -- try and color the graph
 104         let (graph_colored, rsSpill, rmCoalesce)
 105                         = {-# SCC "ColorGraph" #-} Color.colorGraph regsFree triv spill graph
 106
 107         -- rewrite regs in the code that have been coalesced
 108         let patchF reg  = case lookupUFM rmCoalesce reg of
 109                                 Just reg'       -> reg'
 110                                 Nothing         -> reg
 111         let code_coalesced
 112                         = map (patchEraseLive patchF) code
 113
 114
 115         -- see if we've found a coloring
 116         if isEmptyUniqSet rsSpill
 117          then do
 118                 -- patch the registers using the info in the graph
 119                 let code_patched        = map (patchRegsFromGraph graph_colored) code_coalesced
 120
 121                 -- clean out unneeded SPILL/RELOADs
 122                 let code_spillclean     = map cleanSpills code_patched
 123
 124                 -- strip off liveness information
 125                 let code_nat            = map stripLive code_patched
 126
 127                 -- rewrite SPILL/RELOAD pseudos into real instructions
 128                 let spillNatTop         = mapGenBlockTop spillNatBlock
 129                 let code_final          = map spillNatTop code_nat
 130
 131                 -- record what happened in this stage for debugging
 132                 let stat                =
 133                         RegAllocStatsColored
 134                         { raGraph       = graph_colored
 135                         , raCoalesced   = rmCoalesce
 136                         , raPatched     = code_patched
 137                         , raSpillClean  = code_spillclean
 138                         , raFinal       = code_final
 139                         , raSRMs        = foldl' addSRM (0, 0, 0) $ map countSRMs code_spillclean }
 140
 141
 142                 let statList =
 143                         if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
 144                                 else []
 145
 146                 -- space leak avoidance
 147                 seqList statList `seq` return ()
 148
 149                 return  ( code_final
 150                         , statList
 151                         , graph_colored)
 152
 153          else do
 154                 -- spill the uncolored regs
 155                 (code_spilled, slotsFree', spillStats)
 156                         <- regSpill code_coalesced slotsFree rsSpill
 157
 158                 -- recalculate liveness
 159                 let code_nat    = map stripLive code_spilled
 160                 code_relive     <- mapM regLiveness code_nat
 161
 162                 -- record what happened in this stage for debugging
 163                 let stat        =
 164                         RegAllocStatsSpill
 165                         { raGraph       = graph_colored
 166                         , raCoalesced   = rmCoalesce
 167                         , raSpillStats  = spillStats
 168                         , raLifetimes   = fmLife
 169                         , raSpilled     = code_spilled }
 170
 171                 let statList =
 172                         if dump
 173                                 then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
 174                                 else []
 175
 176                 -- space leak avoidance
 177                 seqList statList `seq` return ()
 178
 179                 regAlloc_spin dump (spinCount + 1) triv regsFree slotsFree'
 180                         statList
 181                         code_relive
 182
 183
 184 -----
 185 -- Simple maxconflicts isn't always good, because we
 186 --      can naievely end up spilling vregs that only live for one or two instrs.
 187 --
 188 {-
 189 chooseSpill_maxConflicts
 190         :: Color.Graph Reg RegClass Reg
 191         -> Reg
 192
 193 chooseSpill_maxConflicts graph
 194  = let  node    = maximumBy
 195                         (\n1 n2 -> compare
 196                                 (sizeUniqSet $ Color.nodeConflicts n1)
 197                                 (sizeUniqSet $ Color.nodeConflicts n2))
 198                 $ eltsUFM $ Color.graphMap graph
 199
 200    in   Color.nodeId node
 201 -}
 202
 203 -----
 204 chooseSpill_maxLife
 205         :: UniqFM (Reg, Int)
 206         -> Color.Graph Reg RegClass Reg
 207         -> Reg
 208
 209 chooseSpill_maxLife life graph
 210  = let  node    = maximumBy (\n1 n2 -> compare (getLife n1) (getLife n2))
 211                 $ eltsUFM $ Color.graphMap graph
 212
 213         -- Orphan vregs die in the same instruction they are born in.
 214         --      They will be in the graph, but not in the liveness map.
 215         --      Their liveness is 0.
 216         getLife n
 217          = case lookupUFM life (Color.nodeId n) of
 218                 Just (_, l)     -> l
 219                 Nothing         -> 0
 220
 221    in   Color.nodeId node
 222
 223
 224 -- | Build a graph from the liveness and coalesce information in this code.
 225
 226 buildGraph
 227         :: [LiveCmmTop]
 228         -> UniqSM (Color.Graph Reg RegClass Reg)
 229
 230 buildGraph code
 231  = do
 232         -- Slurp out the conflicts and reg->reg moves from this code
 233         let (conflictList, moveList) =
 234                 unzip $ map slurpConflicts code
 235
 236         let conflictBag         = unionManyBags conflictList
 237         let moveBag             = unionManyBags moveList
 238
 239         -- Add the reg-reg conflicts to the graph
 240         let graph_conflict      = foldrBag graphAddConflictSet Color.initGraph conflictBag
 241
 242         -- Add the coalescences edges to the graph.
 243         let graph_coalesce      = foldrBag graphAddCoalesce graph_conflict moveBag
 244
 245         return  graph_coalesce
 246
 247
 248 -- | Add some conflict edges to the graph.
 249 --      Conflicts between virtual and real regs are recorded as exclusions.
 250 --
 251 graphAddConflictSet
 252         :: UniqSet Reg
 253         -> Color.Graph Reg RegClass Reg
 254         -> Color.Graph Reg RegClass Reg
 255
 256 graphAddConflictSet set graph
 257  = let  reals           = filterUFM isRealReg set
 258         virtuals        = filterUFM (not . isRealReg) set
 259
 260         graph1  = Color.addConflicts virtuals regClass graph
 261         graph2  = foldr (\(r1, r2) -> Color.addExclusion r1 regClass r2)
 262                         graph1
 263                         [ (a, b)
 264                                 | a <- uniqSetToList virtuals
 265                                 , b <- uniqSetToList reals]
 266
 267    in   graph2
 268
 269
 270 -- | Add some coalesence edges to the graph
 271 --      Coalesences between virtual and real regs are recorded as preferences.
 272 --
 273 graphAddCoalesce
 274         :: (Reg, Reg)
 275         -> Color.Graph Reg RegClass Reg
 276         -> Color.Graph Reg RegClass Reg
 277
 278 graphAddCoalesce (r1, r2) graph
 279         | RealReg _ <- r1
 280         = Color.addPreference (regWithClass r2) r1 graph
 281
 282         | RealReg _ <- r2
 283         = Color.addPreference (regWithClass r1) r2 graph
 284
 285         | otherwise
 286         = Color.addCoalesce (regWithClass r1) (regWithClass r2) graph
 287
 288         where   regWithClass r  = (r, regClass r)
 289
 290
 291 -- | Patch registers in code using the reg -> reg mapping in this graph.
 292 patchRegsFromGraph
 293         :: Color.Graph Reg RegClass Reg
 294         -> LiveCmmTop -> LiveCmmTop
 295
 296 patchRegsFromGraph graph code
 297  = let
 298         -- a function to lookup the hardreg for a virtual reg from the graph.
 299         patchF reg
 300                 -- leave real regs alone.
 301                 | isRealReg reg
 302                 = reg
 303
 304                 -- this virtual has a regular node in the graph.
 305                 | Just node     <- Color.lookupNode graph reg
 306                 = case Color.nodeColor node of
 307                         Just color      -> color
 308                         Nothing         -> reg
 309
 310                 -- no node in the graph for this virtual, bad news.
 311                 | otherwise
 312                 = pprPanic "patchRegsFromGraph: register mapping failed."
 313                         (  text "There is no node in the graph for register " <> ppr reg
 314                         $$ ppr code
 315                         $$ Color.dotGraph (\_ -> text "white") trivColorable graph)
 316
 317    in   patchEraseLive patchF code
 318
 319
 320 plusUFMs_C  :: (elt -> elt -> elt) -> [UniqFM elt] -> UniqFM elt
 321 plusUFMs_C f maps
 322         = foldl' (plusUFM_C f) emptyUFM maps
 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