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