ghc /compiler/nativeGen/RegAlloc/Graph/Main.hs

Language Haskell Lines 421
MD5 Hash ecd6e0d6c9d68c138227f700a264f114 Estimated Cost $6,912 (why?)
Repository https://bitbucket.org/carter/ghc.git View Raw File View Project SPDX
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
-- | Graph coloring register allocator.
--
-- TODO: The colors in graphviz graphs for x86_64 and ppc could be nicer.
--

module RegAlloc.Graph.Main (
        regAlloc
)

where

import qualified GraphColor as Color
import RegAlloc.Liveness
import RegAlloc.Graph.Spill
import RegAlloc.Graph.SpillClean
import RegAlloc.Graph.SpillCost
import RegAlloc.Graph.Stats
import RegAlloc.Graph.TrivColorable
import Instruction
import TargetReg
import RegClass
import Reg


import UniqSupply
import UniqSet
import UniqFM
import Bag
import Outputable
import Platform
import DynFlags

import Data.List
import Data.Maybe
import Control.Monad

-- | The maximum number of build\/spill cycles we'll allow.
--      We should only need 3 or 4 cycles tops.
--      If we run for any longer than this we're probably in an infinite loop,
--      It's probably better just to bail out and report a bug at this stage.
maxSpinCount    :: Int
maxSpinCount    = 10


-- | The top level of the graph coloring register allocator.
regAlloc
        :: (Outputable statics, Outputable instr, Instruction instr)
        => DynFlags
        -> UniqFM (UniqSet RealReg)     -- ^ the registers we can use for allocation
        -> UniqSet Int                  -- ^ the set of available spill slots.
        -> [LiveCmmDecl statics instr]  -- ^ code annotated with liveness information.
        -> UniqSM ( [NatCmmDecl statics instr], [RegAllocStats statics instr] )
           -- ^ code with registers allocated and stats for each stage of
           -- allocation

regAlloc dflags regsFree slotsFree code
 = do
        -- TODO: the regClass function is currently hard coded to the default target
        --       architecture. Would prefer to determine this from dflags.
        --       There are other uses of targetRegClass later in this module.
        let platform = targetPlatform dflags
            triv = trivColorable platform
                        (targetVirtualRegSqueeze platform)
                        (targetRealRegSqueeze platform)

        (code_final, debug_codeGraphs, _)
                <- regAlloc_spin dflags 0
                        triv
                        regsFree slotsFree [] code

        return  ( code_final
                , reverse debug_codeGraphs )

regAlloc_spin :: (Instruction instr,
                  Outputable instr,
                  Outputable statics)
              => DynFlags
              -> Int
              -> Color.Triv VirtualReg RegClass RealReg
              -> UniqFM (UniqSet RealReg)
              -> UniqSet Int
              -> [RegAllocStats statics instr]
              -> [LiveCmmDecl statics instr]
              -> UniqSM ([NatCmmDecl statics instr],
                         [RegAllocStats statics instr],
                         Color.Graph VirtualReg RegClass RealReg)
regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code
 = do
        let platform = targetPlatform dflags
        -- if any of these dump flags are turned on we want to hang on to
        --      intermediate structures in the allocator - otherwise tell the
        --      allocator to ditch them early so we don't end up creating space leaks.
        let dump = or
                [ dopt Opt_D_dump_asm_regalloc_stages dflags
                , dopt Opt_D_dump_asm_stats dflags
                , dopt Opt_D_dump_asm_conflicts dflags ]

        -- check that we're not running off down the garden path.
        when (spinCount > maxSpinCount)
         $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded."
                (  text "It looks like the register allocator is stuck in an infinite loop."
                $$ text "max cycles  = " <> int maxSpinCount
                $$ text "regsFree    = " <> (hcat       $ punctuate space $ map ppr
                                                $ uniqSetToList $ unionManyUniqSets $ eltsUFM regsFree)
                $$ text "slotsFree   = " <> ppr (sizeUniqSet slotsFree))

        -- build a conflict graph from the code.
        (graph  :: Color.Graph VirtualReg RegClass RealReg)
                <- {-# SCC "BuildGraph" #-} buildGraph code

        -- VERY IMPORTANT:
        --      We really do want the graph to be fully evaluated _before_ we start coloring.
        --      If we don't do this now then when the call to Color.colorGraph forces bits of it,
        --      the heap will be filled with half evaluated pieces of graph and zillions of apply thunks.
        --
        seqGraph graph `seq` return ()


        -- build a map of the cost of spilling each instruction
        --      this will only actually be computed if we have to spill something.
        let spillCosts  = foldl' plusSpillCostInfo zeroSpillCostInfo
                        $ map (slurpSpillCostInfo platform) code

        -- the function to choose regs to leave uncolored
        let spill       = chooseSpill spillCosts

        -- record startup state
        let stat1       =
                if spinCount == 0
                 then   Just $ RegAllocStatsStart
                        { raLiveCmm     = code
                        , raGraph       = graph
                        , raSpillCosts  = spillCosts }
                 else   Nothing

        -- try and color the graph
        let (graph_colored, rsSpill, rmCoalesce)
                        = {-# SCC "ColorGraph" #-}
                           Color.colorGraph
                                (dopt Opt_RegsIterative dflags)
                                spinCount
                                regsFree triv spill graph

        -- rewrite regs in the code that have been coalesced
        let patchF reg
                | RegVirtual vr <- reg
                = case lookupUFM rmCoalesce vr of
                        Just vr'        -> patchF (RegVirtual vr')
                        Nothing         -> reg

                | otherwise
                = reg

        let code_coalesced
                        = map (patchEraseLive patchF) code


        -- see if we've found a coloring
        if isEmptyUniqSet rsSpill
         then do
                -- if -fasm-lint is turned on then validate the graph
                let graph_colored_lint  =
                        if dopt Opt_DoAsmLinting dflags
                                then Color.validateGraph (text "")
                                        True    -- require all nodes to be colored
                                        graph_colored
                                else graph_colored

                -- patch the registers using the info in the graph
                let code_patched        = map (patchRegsFromGraph platform graph_colored_lint) code_coalesced

                -- clean out unneeded SPILL/RELOADs
                let code_spillclean     = map (cleanSpills platform) code_patched

                -- strip off liveness information,
                --      and rewrite SPILL/RELOAD pseudos into real instructions along the way
                let code_final          = map (stripLive dflags) code_spillclean

                -- record what happened in this stage for debugging
                let stat                =
                        RegAllocStatsColored
                        { raCode                = code
                        , raGraph               = graph
                        , raGraphColored        = graph_colored_lint
                        , raCoalesced           = rmCoalesce
                        , raCodeCoalesced       = code_coalesced
                        , raPatched             = code_patched
                        , raSpillClean          = code_spillclean
                        , raFinal               = code_final
                        , raSRMs                = foldl' addSRM (0, 0, 0) $ map countSRMs code_spillclean }


                let statList =
                        if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
                                else []

                -- space leak avoidance
                seqList statList `seq` return ()

                return  ( code_final
                        , statList
                        , graph_colored_lint)

         -- we couldn't find a coloring, time to spill something
         else do
                -- if -fasm-lint is turned on then validate the graph
                let graph_colored_lint  =
                        if dopt Opt_DoAsmLinting dflags
                                then Color.validateGraph (text "")
                                        False   -- don't require nodes to be colored
                                        graph_colored
                                else graph_colored

                -- spill the uncolored regs
                (code_spilled, slotsFree', spillStats)
                        <- regSpill platform code_coalesced slotsFree rsSpill

                -- recalculate liveness
                -- NOTE: we have to reverse the SCCs here to get them back into the reverse-dependency
                --       order required by computeLiveness. If they're not in the correct order
                --       that function will panic.
                code_relive     <- mapM (regLiveness platform . reverseBlocksInTops) code_spilled

                -- record what happened in this stage for debugging
                let stat        =
                        RegAllocStatsSpill
                        { raCode        = code
                        , raGraph       = graph_colored_lint
                        , raCoalesced   = rmCoalesce
                        , raSpillStats  = spillStats
                        , raSpillCosts  = spillCosts
                        , raSpilled     = code_spilled }

                let statList =
                        if dump
                                then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
                                else []

                -- space leak avoidance
                seqList statList `seq` return ()

                regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree'
                        statList
                        code_relive


-- | Build a graph from the liveness and coalesce information in this code.
buildGraph
        :: Instruction instr
        => [LiveCmmDecl statics instr]
        -> UniqSM (Color.Graph VirtualReg RegClass RealReg)

buildGraph code
 = do
        -- Slurp out the conflicts and reg->reg moves from this code
        let (conflictList, moveList) =
                unzip $ map slurpConflicts code

        -- Slurp out the spill/reload coalesces
        let moveList2           = map slurpReloadCoalesce code

        -- Add the reg-reg conflicts to the graph
        let conflictBag         = unionManyBags conflictList
        let graph_conflict      = foldrBag graphAddConflictSet Color.initGraph conflictBag

        -- Add the coalescences edges to the graph.
        let moveBag             = unionBags (unionManyBags moveList2) (unionManyBags moveList)
        let graph_coalesce      = foldrBag graphAddCoalesce graph_conflict moveBag

        return  graph_coalesce


-- | Add some conflict edges to the graph.
--      Conflicts between virtual and real regs are recorded as exclusions.
graphAddConflictSet
        :: UniqSet Reg
        -> Color.Graph VirtualReg RegClass RealReg
        -> Color.Graph VirtualReg RegClass RealReg

graphAddConflictSet set graph
 = let  virtuals        = mkUniqSet
                        [ vr | RegVirtual vr <- uniqSetToList set ]

        graph1  = Color.addConflicts virtuals classOfVirtualReg graph

        graph2  = foldr (\(r1, r2) -> Color.addExclusion r1 classOfVirtualReg r2)
                        graph1
                        [ (vr, rr)
                                | RegVirtual vr <- uniqSetToList set
                                , RegReal    rr <- uniqSetToList set]

   in   graph2


-- | Add some coalesence edges to the graph
--      Coalesences between virtual and real regs are recorded as preferences.
graphAddCoalesce
        :: (Reg, Reg)
        -> Color.Graph VirtualReg RegClass RealReg
        -> Color.Graph VirtualReg RegClass RealReg

graphAddCoalesce (r1, r2) graph
        | RegReal rr            <- r1
        , RegVirtual vr         <- r2
        = Color.addPreference (vr, classOfVirtualReg vr) rr graph

        | RegReal rr            <- r2
        , RegVirtual vr         <- r1
        = Color.addPreference (vr, classOfVirtualReg vr) rr graph

        | RegVirtual vr1        <- r1
        , RegVirtual vr2        <- r2
        = Color.addCoalesce
                (vr1, classOfVirtualReg vr1)
                (vr2, classOfVirtualReg vr2)
                graph

        -- We can't coalesce two real regs, but there could well be existing
        --      hreg,hreg moves in the input code. We'll just ignore these
        --      for coalescing purposes.
        | RegReal _             <- r1
        , RegReal _             <- r2
        = graph

graphAddCoalesce _ _
        = panic "graphAddCoalesce: bogus"


-- | Patch registers in code using the reg -> reg mapping in this graph.
patchRegsFromGraph
        :: (Outputable statics, Outputable instr, Instruction instr)
        => Platform -> Color.Graph VirtualReg RegClass RealReg
        -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr

patchRegsFromGraph platform graph code
 = let
        -- a function to lookup the hardreg for a virtual reg from the graph.
        patchF reg
                -- leave real regs alone.
                | RegReal{}     <- reg
                = reg

                -- this virtual has a regular node in the graph.
                | RegVirtual vr <- reg
                , Just node     <- Color.lookupNode graph vr
                = case Color.nodeColor node of
                        Just color      -> RegReal    color
                        Nothing         -> RegVirtual vr

                -- no node in the graph for this virtual, bad news.
                | otherwise
                = pprPanic "patchRegsFromGraph: register mapping failed."
                        (  text "There is no node in the graph for register " <> ppr reg
                        $$ ppr code
                        $$ Color.dotGraph
                                (\_ -> text "white")
                                (trivColorable platform
                                        (targetVirtualRegSqueeze platform)
                                        (targetRealRegSqueeze platform))
                                graph)

   in   patchEraseLive patchF code


-----
-- for when laziness just isn't what you wanted...
--
seqGraph :: Color.Graph VirtualReg RegClass RealReg -> ()
seqGraph graph          = seqNodes (eltsUFM (Color.graphMap graph))

seqNodes :: [Color.Node VirtualReg RegClass RealReg] -> ()
seqNodes ns
 = case ns of
        []              -> ()
        (n : ns)        -> seqNode n `seq` seqNodes ns

seqNode :: Color.Node VirtualReg RegClass RealReg -> ()
seqNode node
        =     seqVirtualReg     (Color.nodeId node)
        `seq` seqRegClass       (Color.nodeClass node)
        `seq` seqMaybeRealReg   (Color.nodeColor node)
        `seq` (seqVirtualRegList (uniqSetToList (Color.nodeConflicts node)))
        `seq` (seqRealRegList    (uniqSetToList (Color.nodeExclusions node)))
        `seq` (seqRealRegList (Color.nodePreference node))
        `seq` (seqVirtualRegList (uniqSetToList (Color.nodeCoalesce node)))

seqVirtualReg :: VirtualReg -> ()
seqVirtualReg reg = reg `seq` ()

seqRealReg :: RealReg -> ()
seqRealReg reg = reg `seq` ()

seqRegClass :: RegClass -> ()
seqRegClass c = c `seq` ()

seqMaybeRealReg :: Maybe RealReg -> ()
seqMaybeRealReg mr
 = case mr of
        Nothing         -> ()
        Just r          -> seqRealReg r

seqVirtualRegList :: [VirtualReg] -> ()
seqVirtualRegList rs
 = case rs of
        []              -> ()
        (r : rs)        -> seqVirtualReg r `seq` seqVirtualRegList rs

seqRealRegList :: [RealReg] -> ()
seqRealRegList rs
 = case rs of
        []              -> ()
        (r : rs)        -> seqRealReg r `seq` seqRealRegList rs

seqList :: [a] -> ()
seqList ls
 = case ls of
        []              -> ()
        (r : rs)        -> r `seq` seqList rs
Back to Top