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