PageRenderTime 33ms CodeModel.GetById 13ms app.highlight 16ms RepoModel.GetById 1ms app.codeStats 0ms

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

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