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