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 regAlloc
  47         :: (Outputable instr, Instruction instr)
  48         => DynFlags
  49         -> UniqFM (UniqSet RealReg)     -- ^ the registers we can use for allocation
  50         -> UniqSet Int                  -- ^ the set of available spill slots.
  51         -> [LiveCmmTop instr]           -- ^ code annotated with liveness information.
  52         -> UniqSM ( [NatCmmTop instr], [RegAllocStats instr] )
  53            -- ^ code with registers allocated and stats for each stage of
  54            -- allocation
  55
  56 regAlloc dflags regsFree slotsFree code
  57  = do
  58         -- TODO: the regClass function is currently hard coded to the default target
  59         --       architecture. Would prefer to determine this from dflags.
  60         --       There are other uses of targetRegClass later in this module.
  61         let triv = trivColorable
  62                         targetVirtualRegSqueeze
  63                         targetRealRegSqueeze
  64
  65         (code_final, debug_codeGraphs, _)
  66                 <- regAlloc_spin dflags 0
  67                         triv
  68                         regsFree slotsFree [] code
  69
  70         return  ( code_final
  71                 , reverse debug_codeGraphs )
  72
  73 regAlloc_spin
  74         dflags
  75         spinCount
  76         (triv           :: Color.Triv VirtualReg RegClass RealReg)
  77         (regsFree       :: UniqFM (UniqSet RealReg))
  78         slotsFree
  79         debug_codeGraphs
  80         code
  81  = do
  82         -- if any of these dump flags are turned on we want to hang on to
  83         --      intermediate structures in the allocator - otherwise tell the
  84         --      allocator to ditch them early so we don't end up creating space leaks.
  85         let dump = or
  86                 [ dopt Opt_D_dump_asm_regalloc_stages dflags
  87                 , dopt Opt_D_dump_asm_stats dflags
  88                 , dopt Opt_D_dump_asm_conflicts dflags ]
  89
  90         -- check that we're not running off down the garden path.
  91         when (spinCount > maxSpinCount)
  92          $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded."
  93                 (  text "It looks like the register allocator is stuck in an infinite loop."
  94                 $$ text "max cycles  = " <> int maxSpinCount
  95                 $$ text "regsFree    = " <> (hcat       $ punctuate space $ map ppr
  96                                                 $ uniqSetToList $ unionManyUniqSets $ eltsUFM regsFree)
  97                 $$ text "slotsFree   = " <> ppr (sizeUniqSet slotsFree))
  98
  99         -- build a conflict graph from the code.
 100         (graph  :: Color.Graph VirtualReg RegClass RealReg)
 101                 <- {-# SCC "BuildGraph" #-} buildGraph code
 102
 103         -- VERY IMPORTANT:
 104         --      We really do want the graph to be fully evaluated _before_ we start coloring.
 105         --      If we don't do this now then when the call to Color.colorGraph forces bits of it,
 106         --      the heap will be filled with half evaluated pieces of graph and zillions of apply thunks.
 107         --
 108         seqGraph graph `seq` return ()
 109
 110
 111         -- build a map of the cost of spilling each instruction
 112         --      this will only actually be computed if we have to spill something.
 113         let spillCosts  = foldl' plusSpillCostInfo zeroSpillCostInfo
 114                         $ map slurpSpillCostInfo code
 115
 116         -- the function to choose regs to leave uncolored
 117         let spill       = chooseSpill spillCosts
 118
 119         -- record startup state
 120         let stat1       =
 121                 if spinCount == 0
 122                  then   Just $ RegAllocStatsStart
 123                         { raLiveCmm     = code
 124                         , raGraph       = graph
 125                         , raSpillCosts  = spillCosts }
 126                  else   Nothing
 127
 128         -- try and color the graph
 129         let (graph_colored, rsSpill, rmCoalesce)
 130                         = {-# SCC "ColorGraph" #-}
 131                            Color.colorGraph
 132                                 (dopt Opt_RegsIterative dflags)
 133                                 spinCount
 134                                 regsFree triv spill graph
 135
 136         -- rewrite regs in the code that have been coalesced
 137         let patchF reg
 138                 | RegVirtual vr <- reg
 139                 = case lookupUFM rmCoalesce vr of
 140                         Just vr'        -> patchF (RegVirtual vr')
 141                         Nothing         -> reg
 142
 143                 | otherwise
 144                 = reg
 145
 146         let code_coalesced
 147                         = map (patchEraseLive patchF) code
 148
 149
 150         -- see if we've found a coloring
 151         if isEmptyUniqSet rsSpill
 152          then do
 153                 -- if -fasm-lint is turned on then validate the graph
 154                 let graph_colored_lint  =
 155                         if dopt Opt_DoAsmLinting dflags
 156                                 then Color.validateGraph (text "")
 157                                         True    -- require all nodes to be colored
 158                                         graph_colored
 159                                 else graph_colored
 160
 161                 -- patch the registers using the info in the graph
 162                 let code_patched        = map (patchRegsFromGraph graph_colored_lint) code_coalesced
 163
 164                 -- clean out unneeded SPILL/RELOADs
 165                 let code_spillclean     = map cleanSpills code_patched
 166
 167                 -- strip off liveness information,
 168                 --      and rewrite SPILL/RELOAD pseudos into real instructions along the way
 169                 let code_final          = map stripLive code_spillclean
 170
 171                 -- record what happened in this stage for debugging
 172                 let stat                =
 173                         RegAllocStatsColored
 174                         { raCode                = code
 175                         , raGraph               = graph
 176                         , raGraphColored        = graph_colored_lint
 177                         , raCoalesced           = rmCoalesce
 178                         , raCodeCoalesced       = code_coalesced
 179                         , raPatched             = code_patched
 180                         , raSpillClean          = code_spillclean
 181                         , raFinal               = code_final
 182                         , raSRMs                = foldl' addSRM (0, 0, 0) $ map countSRMs code_spillclean }
 183
 184
 185                 let statList =
 186                         if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
 187                                 else []
 188
 189                 -- space leak avoidance
 190                 seqList statList `seq` return ()
 191
 192                 return  ( code_final
 193                         , statList
 194                         , graph_colored_lint)
 195
 196          -- we couldn't find a coloring, time to spill something
 197          else do
 198                 -- if -fasm-lint is turned on then validate the graph
 199                 let graph_colored_lint  =
 200                         if dopt Opt_DoAsmLinting dflags
 201                                 then Color.validateGraph (text "")
 202                                         False   -- don't require nodes to be colored
 203                                         graph_colored
 204                                 else graph_colored
 205
 206                 -- spill the uncolored regs
 207                 (code_spilled, slotsFree', spillStats)
 208                         <- regSpill code_coalesced slotsFree rsSpill
 209
 210                 -- recalculate liveness
 211                 -- NOTE: we have to reverse the SCCs here to get them back into the reverse-dependency
 212                 --       order required by computeLiveness. If they're not in the correct order
 213                 --       that function will panic.
 214                 code_relive     <- mapM (regLiveness . reverseBlocksInTops) code_spilled
 215
 216                 -- record what happened in this stage for debugging
 217                 let stat        =
 218                         RegAllocStatsSpill
 219                         { raCode        = code
 220                         , raGraph       = graph_colored_lint
 221                         , raCoalesced   = rmCoalesce
 222                         , raSpillStats  = spillStats
 223                         , raSpillCosts  = spillCosts
 224                         , raSpilled     = code_spilled }
 225
 226                 let statList =
 227                         if dump
 228                                 then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
 229                                 else []
 230
 231                 -- space leak avoidance
 232                 seqList statList `seq` return ()
 233
 234                 regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree'
 235                         statList
 236                         code_relive
 237
 238
 239 -- | Build a graph from the liveness and coalesce information in this code.
 240 buildGraph
 241         :: Instruction instr
 242         => [LiveCmmTop instr]
 243         -> UniqSM (Color.Graph VirtualReg RegClass RealReg)
 244
 245 buildGraph code
 246  = do
 247         -- Slurp out the conflicts and reg->reg moves from this code
 248         let (conflictList, moveList) =
 249                 unzip $ map slurpConflicts code
 250
 251         -- Slurp out the spill/reload coalesces
 252         let moveList2           = map slurpReloadCoalesce code
 253
 254         -- Add the reg-reg conflicts to the graph
 255         let conflictBag         = unionManyBags conflictList
 256         let graph_conflict      = foldrBag graphAddConflictSet Color.initGraph conflictBag
 257
 258         -- Add the coalescences edges to the graph.
 259         let moveBag             = unionBags (unionManyBags moveList2) (unionManyBags moveList)
 260         let graph_coalesce      = foldrBag graphAddCoalesce graph_conflict moveBag
 261
 262         return  graph_coalesce
 263
 264
 265 -- | Add some conflict edges to the graph.
 266 --      Conflicts between virtual and real regs are recorded as exclusions.
 267 graphAddConflictSet
 268         :: UniqSet Reg
 269         -> Color.Graph VirtualReg RegClass RealReg
 270         -> Color.Graph VirtualReg RegClass RealReg
 271
 272 graphAddConflictSet set graph
 273  = let  virtuals        = mkUniqSet
 274                         [ vr | RegVirtual vr <- uniqSetToList set ]
 275
 276         graph1  = Color.addConflicts virtuals classOfVirtualReg graph
 277
 278         graph2  = foldr (\(r1, r2) -> Color.addExclusion r1 classOfVirtualReg r2)
 279                         graph1
 280                         [ (vr, rr)
 281                                 | RegVirtual vr <- uniqSetToList set
 282                                 , RegReal    rr <- uniqSetToList set]
 283
 284    in   graph2
 285
 286
 287 -- | Add some coalesence edges to the graph
 288 --      Coalesences between virtual and real regs are recorded as preferences.
 289 graphAddCoalesce
 290         :: (Reg, Reg)
 291         -> Color.Graph VirtualReg RegClass RealReg
 292         -> Color.Graph VirtualReg RegClass RealReg
 293
 294 graphAddCoalesce (r1, r2) graph
 295         | RegReal rr            <- r1
 296         , RegVirtual vr         <- r2
 297         = Color.addPreference (vr, classOfVirtualReg vr) rr graph
 298
 299         | RegReal rr            <- r2
 300         , RegVirtual vr         <- r1
 301         = Color.addPreference (vr, classOfVirtualReg vr) rr graph
 302
 303         | RegVirtual vr1        <- r1
 304         , RegVirtual vr2        <- r2
 305         = Color.addCoalesce
 306                 (vr1, classOfVirtualReg vr1)
 307                 (vr2, classOfVirtualReg vr2)
 308                 graph
 309
 310         -- We can't coalesce two real regs, but there could well be existing
 311         --      hreg,hreg moves in the input code. We'll just ignore these
 312         --      for coalescing purposes.
 313         | RegReal _             <- r1
 314         , RegReal _             <- r2
 315         = graph
 316
 317 graphAddCoalesce _ _
 318         = panic "graphAddCoalesce: bogus"
 319
 320
 321 -- | Patch registers in code using the reg -> reg mapping in this graph.
 322 patchRegsFromGraph
 323         :: (Outputable instr, Instruction instr)
 324         => Color.Graph VirtualReg RegClass RealReg
 325         -> LiveCmmTop instr -> LiveCmmTop instr
 326
 327 patchRegsFromGraph graph code
 328  = let
 329         -- a function to lookup the hardreg for a virtual reg from the graph.
 330         patchF reg
 331                 -- leave real regs alone.
 332                 | RegReal{}     <- reg
 333                 = reg
 334
 335                 -- this virtual has a regular node in the graph.
 336                 | RegVirtual vr <- reg
 337                 , Just node     <- Color.lookupNode graph vr
 338                 = case Color.nodeColor node of
 339                         Just color      -> RegReal    color
 340                         Nothing         -> RegVirtual vr
 341
 342                 -- no node in the graph for this virtual, bad news.
 343                 | otherwise
 344                 = pprPanic "patchRegsFromGraph: register mapping failed."
 345                         (  text "There is no node in the graph for register " <> ppr reg
 346                         $$ ppr code
 347                         $$ Color.dotGraph
 348                                 (\_ -> text "white")
 349                                 (trivColorable
 350                                         targetVirtualRegSqueeze
 351                                         targetRealRegSqueeze)
 352                                 graph)
 353
 354    in   patchEraseLive patchF code
 355
 356
 357 -----
 358 -- for when laziness just isn't what you wanted...
 359 --
 360 seqGraph :: Color.Graph VirtualReg RegClass RealReg -> ()
 361 seqGraph graph          = seqNodes (eltsUFM (Color.graphMap graph))
 362
 363 seqNodes :: [Color.Node VirtualReg RegClass RealReg] -> ()
 364 seqNodes ns
 365  = case ns of
 366         []              -> ()
 367         (n : ns)        -> seqNode n `seq` seqNodes ns
 368
 369 seqNode :: Color.Node VirtualReg RegClass RealReg -> ()
 370 seqNode node
 371         =     seqVirtualReg     (Color.nodeId node)
 372         `seq` seqRegClass       (Color.nodeClass node)
 373         `seq` seqMaybeRealReg   (Color.nodeColor node)
 374         `seq` (seqVirtualRegList (uniqSetToList (Color.nodeConflicts node)))
 375         `seq` (seqRealRegList    (uniqSetToList (Color.nodeExclusions node)))
 376         `seq` (seqRealRegList (Color.nodePreference node))
 377         `seq` (seqVirtualRegList (uniqSetToList (Color.nodeCoalesce node)))
 378
 379 seqVirtualReg :: VirtualReg -> ()
 380 seqVirtualReg reg = reg `seq` ()
 381
 382 seqRealReg :: RealReg -> ()
 383 seqRealReg reg = reg `seq` ()
 384
 385 seqRegClass :: RegClass -> ()
 386 seqRegClass c = c `seq` ()
 387
 388 seqMaybeRealReg :: Maybe RealReg -> ()
 389 seqMaybeRealReg mr
 390  = case mr of
 391         Nothing         -> ()
 392         Just r          -> seqRealReg r
 393
 394 seqVirtualRegList :: [VirtualReg] -> ()
 395 seqVirtualRegList rs
 396  = case rs of
 397         []              -> ()
 398         (r : rs)        -> seqVirtualReg r `seq` seqVirtualRegList rs
 399
 400 seqRealRegList :: [RealReg] -> ()
 401 seqRealRegList rs
 402  = case rs of
 403         []              -> ()
 404         (r : rs)        -> seqRealReg r `seq` seqRealRegList rs
 405
 406 seqList :: [a] -> ()
 407 seqList ls
 408  = case ls of
 409         []              -> ()
 410         (r : rs)        -> r `seq` seqList rs
 411
 412