compiler/nativeGen/RegAllocColor.hs

   1 {-# OPTIONS -fno-warn-missing-signatures #-}
   2 -- | Graph coloring register allocator.
   3 --
   4 -- TODO: The colors in graphviz graphs for x86_64 and ppc could be nicer.
   5 --
   6
   7 module RegAllocColor (
   8         regAlloc,
   9         regDotColor
  10 )
  11
  12 where
  13
  14 import qualified GraphColor     as Color
  15 import RegLiveness
  16 import RegSpill
  17 import RegSpillClean
  18 import RegSpillCost
  19 import RegAllocStats
  20 -- import RegCoalesce
  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 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         -- check that we're not running off down the garden path.
  74         when (spinCount > maxSpinCount)
  75          $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded."
  76                 (  text "It looks like the register allocator is stuck in an infinite loop."
  77                 $$ text "max cycles  = " <> int maxSpinCount
  78                 $$ text "regsFree    = " <> (hcat       $ punctuate space $ map (docToSDoc . pprUserReg)
  79                                                 $ uniqSetToList $ unionManyUniqSets $ eltsUFM regsFree)
  80                 $$ text "slotsFree   = " <> ppr (sizeUniqSet slotsFree))
  81
  82         -- build a conflict graph from the code.
  83         graph           <- {-# SCC "BuildGraph" #-} buildGraph code
  84
  85         -- VERY IMPORTANT:
  86         --      We really do want the graph to be fully evaluated _before_ we start coloring.
  87         --      If we don't do this now then when the call to Color.colorGraph forces bits of it,
  88         --      the heap will be filled with half evaluated pieces of graph and zillions of apply thunks.
  89         --
  90         seqGraph graph `seq` return ()
  91
  92
  93         -- build a map of the cost of spilling each instruction
  94         --      this will only actually be computed if we have to spill something.
  95         let spillCosts  = foldl' plusSpillCostInfo zeroSpillCostInfo
  96                         $ map slurpSpillCostInfo code
  97
  98         -- the function to choose regs to leave uncolored
  99         let spill       = chooseSpill spillCosts
 100
 101         -- record startup state
 102         let stat1       =
 103                 if spinCount == 0
 104                  then   Just $ RegAllocStatsStart
 105                         { raLiveCmm     = code
 106                         , raGraph       = graph
 107                         , raSpillCosts  = spillCosts }
 108                  else   Nothing
 109
 110         -- try and color the graph
 111         let (graph_colored, rsSpill, rmCoalesce)
 112                         = {-# SCC "ColorGraph" #-}
 113                            Color.colorGraph
 114                                 (dopt Opt_RegsIterative dflags)
 115                                 spinCount
 116                                 regsFree triv spill graph
 117
 118         -- rewrite regs in the code that have been coalesced
 119         let patchF reg  = case lookupUFM rmCoalesce reg of
 120                                 Just reg'       -> patchF reg'
 121                                 Nothing         -> reg
 122         let code_coalesced
 123                         = map (patchEraseLive patchF) code
 124
 125
 126         -- see if we've found a coloring
 127         if isEmptyUniqSet rsSpill
 128          then do
 129                 -- if -fasm-lint is turned on then validate the graph
 130                 let graph_colored_lint  =
 131                         if dopt Opt_DoAsmLinting dflags
 132                                 then Color.validateGraph (text "")
 133                                         True    -- require all nodes to be colored
 134                                         graph_colored
 135                                 else graph_colored
 136
 137                 -- patch the registers using the info in the graph
 138                 let code_patched        = map (patchRegsFromGraph graph_colored_lint) code_coalesced
 139
 140                 -- clean out unneeded SPILL/RELOADs
 141                 let code_spillclean     = map cleanSpills code_patched
 142
 143                 -- strip off liveness information
 144                 let code_nat            = map stripLive code_spillclean
 145
 146                 -- rewrite SPILL/RELOAD pseudos into real instructions
 147                 let spillNatTop         = mapGenBlockTop spillNatBlock
 148                 let code_final          = map spillNatTop code_nat
 149
 150                 -- record what happened in this stage for debugging
 151                 let stat                =
 152                         RegAllocStatsColored
 153                         { raGraph               = graph
 154                         , raGraphColored        = graph_colored_lint
 155                         , raCoalesced           = rmCoalesce
 156                         , raPatched             = code_patched
 157                         , raSpillClean          = code_spillclean
 158                         , raFinal               = code_final
 159                         , raSRMs                = foldl' addSRM (0, 0, 0) $ map countSRMs code_spillclean }
 160
 161
 162                 let statList =
 163                         if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
 164                                 else []
 165
 166                 -- space leak avoidance
 167                 seqList statList `seq` return ()
 168
 169                 return  ( code_final
 170                         , statList
 171                         , graph_colored_lint)
 172
 173          -- we couldn't find a coloring, time to spill something
 174          else do
 175                 -- if -fasm-lint is turned on then validate the graph
 176                 let graph_colored_lint  =
 177                         if dopt Opt_DoAsmLinting dflags
 178                                 then Color.validateGraph (text "")
 179                                         False   -- don't require nodes to be colored
 180                                         graph_colored
 181                                 else graph_colored
 182
 183                 -- spill the uncolored regs
 184                 (code_spilled, slotsFree', spillStats)
 185                         <- regSpill code_coalesced slotsFree rsSpill
 186
 187                 -- recalculate liveness
 188                 let code_nat    = map stripLive code_spilled
 189                 code_relive     <- mapM regLiveness code_nat
 190
 191                 -- record what happened in this stage for debugging
 192                 let stat        =
 193                         RegAllocStatsSpill
 194                         { raGraph       = graph_colored_lint
 195                         , raCoalesced   = rmCoalesce
 196                         , raSpillStats  = spillStats
 197                         , raSpillCosts  = spillCosts
 198                         , raSpilled     = code_spilled }
 199
 200                 let statList =
 201                         if dump
 202                                 then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
 203                                 else []
 204
 205                 -- space leak avoidance
 206                 seqList statList `seq` return ()
 207
 208                 regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree'
 209                         statList
 210                         code_relive
 211
 212
 213
 214 -- | Build a graph from the liveness and coalesce information in this code.
 215
 216 buildGraph
 217         :: [LiveCmmTop]
 218         -> UniqSM (Color.Graph Reg RegClass Reg)
 219
 220 buildGraph code
 221  = do
 222         -- Slurp out the conflicts and reg->reg moves from this code
 223         let (conflictList, moveList) =
 224                 unzip $ map slurpConflicts code
 225
 226         -- Slurp out the spill/reload coalesces
 227         let moveList2           = map slurpReloadCoalesce code
 228
 229         -- Add the reg-reg conflicts to the graph
 230         let conflictBag         = unionManyBags conflictList
 231         let graph_conflict      = foldrBag graphAddConflictSet Color.initGraph conflictBag
 232
 233         -- Add the coalescences edges to the graph.
 234         let moveBag             = unionBags (unionManyBags moveList2) (unionManyBags moveList)
 235         let graph_coalesce      = foldrBag graphAddCoalesce graph_conflict moveBag
 236
 237         return  graph_coalesce
 238
 239
 240 -- | Add some conflict edges to the graph.
 241 --      Conflicts between virtual and real regs are recorded as exclusions.
 242 --
 243 graphAddConflictSet
 244         :: UniqSet Reg
 245         -> Color.Graph Reg RegClass Reg
 246         -> Color.Graph Reg RegClass Reg
 247
 248 graphAddConflictSet set graph
 249  = let  reals           = filterUFM isRealReg set
 250         virtuals        = filterUFM (not . isRealReg) set
 251
 252         graph1  = Color.addConflicts virtuals regClass graph
 253         graph2  = foldr (\(r1, r2) -> Color.addExclusion r1 regClass r2)
 254                         graph1
 255                         [ (a, b)
 256                                 | a <- uniqSetToList virtuals
 257                                 , b <- uniqSetToList reals]
 258
 259    in   graph2
 260
 261
 262 -- | Add some coalesence edges to the graph
 263 --      Coalesences between virtual and real regs are recorded as preferences.
 264 --
 265 graphAddCoalesce
 266         :: (Reg, Reg)
 267         -> Color.Graph Reg RegClass Reg
 268         -> Color.Graph Reg RegClass Reg
 269
 270 graphAddCoalesce (r1, r2) graph
 271         | RealReg _ <- r1
 272         = Color.addPreference (regWithClass r2) r1 graph
 273
 274         | RealReg _ <- r2
 275         = Color.addPreference (regWithClass r1) r2 graph
 276
 277         | otherwise
 278         = Color.addCoalesce (regWithClass r1) (regWithClass r2) graph
 279
 280         where   regWithClass r  = (r, regClass r)
 281
 282
 283 -- | Patch registers in code using the reg -> reg mapping in this graph.
 284 patchRegsFromGraph
 285         :: Color.Graph Reg RegClass Reg
 286         -> LiveCmmTop -> LiveCmmTop
 287
 288 patchRegsFromGraph graph code
 289  = let
 290         -- a function to lookup the hardreg for a virtual reg from the graph.
 291         patchF reg
 292                 -- leave real regs alone.
 293                 | isRealReg reg
 294                 = reg
 295
 296                 -- this virtual has a regular node in the graph.
 297                 | Just node     <- Color.lookupNode graph reg
 298                 = case Color.nodeColor node of
 299                         Just color      -> color
 300                         Nothing         -> reg
 301
 302                 -- no node in the graph for this virtual, bad news.
 303                 | otherwise
 304                 = pprPanic "patchRegsFromGraph: register mapping failed."
 305                         (  text "There is no node in the graph for register " <> ppr reg
 306                         $$ ppr code
 307                         $$ Color.dotGraph (\_ -> text "white") trivColorable graph)
 308
 309    in   patchEraseLive patchF code
 310
 311
 312 -----
 313 -- for when laziness just isn't what you wanted...
 314 --
 315 seqGraph :: Color.Graph Reg RegClass Reg -> ()
 316 seqGraph graph          = seqNodes (eltsUFM (Color.graphMap graph))
 317
 318 seqNodes :: [Color.Node Reg RegClass Reg] -> ()
 319 seqNodes ns
 320  = case ns of
 321         []              -> ()
 322         (n : ns)        -> seqNode n `seq` seqNodes ns
 323
 324 seqNode :: Color.Node Reg RegClass Reg -> ()
 325 seqNode node
 326         =     seqReg      (Color.nodeId node)
 327         `seq` seqRegClass (Color.nodeClass node)
 328         `seq` seqMaybeReg (Color.nodeColor node)
 329         `seq` (seqRegList (uniqSetToList (Color.nodeConflicts node)))
 330         `seq` (seqRegList (uniqSetToList (Color.nodeExclusions node)))
 331         `seq` (seqRegList (Color.nodePreference node))
 332         `seq` (seqRegList (uniqSetToList (Color.nodeCoalesce node)))
 333
 334 seqReg :: Reg -> ()
 335 seqReg reg
 336  = case reg of
 337         RealReg _       -> ()
 338         VirtualRegI _   -> ()
 339         VirtualRegHi _  -> ()
 340         VirtualRegF _   -> ()
 341         VirtualRegD _   -> ()
 342
 343 seqRegClass :: RegClass -> ()
 344 seqRegClass c
 345  = case c of
 346         RcInteger       -> ()
 347         RcFloat         -> ()
 348         RcDouble        -> ()
 349
 350 seqMaybeReg :: Maybe Reg -> ()
 351 seqMaybeReg mr
 352  = case mr of
 353         Nothing         -> ()
 354         Just r          -> seqReg r
 355
 356 seqRegList :: [Reg] -> ()
 357 seqRegList rs
 358  = case rs of
 359         []              -> ()
 360         (r : rs)        -> seqReg r `seq` seqRegList rs
 361
 362 seqList :: [a] -> ()
 363 seqList ls
 364  = case ls of
 365         []              -> ()
 366         (r : rs)        -> r `seq` seqList rs
 367
 368