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