diff options
| -rw-r--r-- | compiler/main/DynFlags.hs | 4 | ||||
| -rw-r--r-- | compiler/nativeGen/AsmCodeGen.lhs | 30 | ||||
| -rw-r--r-- | compiler/nativeGen/GraphBase.hs | 3 | ||||
| -rw-r--r-- | compiler/nativeGen/GraphColor.hs | 203 | ||||
| -rw-r--r-- | compiler/nativeGen/GraphOps.hs | 142 | ||||
| -rw-r--r-- | compiler/nativeGen/RegAllocColor.hs | 25 |
6 files changed, 272 insertions, 135 deletions
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index c3d9c5dcc6..38591f02ac 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -246,7 +246,8 @@ data DynFlag | Opt_DictsCheap | Opt_RewriteRules | Opt_Vectorise - | Opt_RegsGraph + | Opt_RegsGraph -- do graph coloring register allocation + | Opt_RegsIterative -- do iterative coalescing graph coloring register allocation -- misc opts | Opt_Cpp @@ -1195,6 +1196,7 @@ fFlags = [ ( "convert-to-zipper-and-back", Opt_ConvertToZipCfgAndBack), ( "vectorise", Opt_Vectorise ), ( "regs-graph", Opt_RegsGraph), + ( "regs-iterative", Opt_RegsIterative), -- Deprecated in favour of -XTemplateHaskell: ( "th", Opt_TemplateHaskell ), -- Deprecated in favour of -XForeignFunctionInterface: diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 0966404da9..507d96b0cb 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -196,9 +196,9 @@ cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc then native else [] - -- force evaulation of imports and lsPprNative to avoid space leak + -- force evaulation all this stuff to avoid space leaks seqString (showSDoc $ vcat $ map ppr imports) `seq` return () - lsPprNative `seq` return () + lsPprNative `seq` return () cmmNativeGens dflags h us' cmms (imports : impAcc) @@ -214,15 +214,16 @@ cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc cmmNativeGen :: DynFlags -> UniqSupply - -> RawCmmTop + -> RawCmmTop -- ^ the cmm to generate code for -> IO ( UniqSupply - , [NatCmmTop] - , [CLabel] - , Maybe [Color.RegAllocStats] - , Maybe [Linear.RegAllocStats]) + , [NatCmmTop] -- native code + , [CLabel] -- things imported by this cmm + , Maybe [Color.RegAllocStats] -- stats for the coloring register allocator + , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators cmmNativeGen dflags us cmm = do + -- rewrite assignments to global regs let (fixed_cmm, usFix) = {-# SCC "fixAssignsTop" #-} @@ -259,7 +260,8 @@ cmmNativeGen dflags us cmm -- allocate registers (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <- - if dopt Opt_RegsGraph dflags + if ( dopt Opt_RegsGraph dflags + || dopt Opt_RegsIterative dflags) then do -- the regs usable for allocation let alloc_regs @@ -268,20 +270,12 @@ cmmNativeGen dflags us cmm emptyUFM $ map RealReg allocatableRegs - -- 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 generateRegAllocStats = or - [ dopt Opt_D_dump_asm_regalloc_stages dflags - , dopt Opt_D_dump_asm_stats dflags - , dopt Opt_D_dump_asm_conflicts dflags ] - -- graph coloring register allocation let ((alloced, regAllocStats), usAlloc) = {-# SCC "RegAlloc" #-} initUs usLive $ Color.regAlloc - generateRegAllocStats + dflags alloc_regs (mkUniqSet [0..maxSpillSlots]) withLiveness @@ -294,7 +288,7 @@ cmmNativeGen dflags us cmm dumpIfSet_dyn dflags Opt_D_dump_asm_regalloc_stages "Build/spill stages" (vcat $ map (\(stage, stats) - -> text "-- Stage " <> int stage + -> text " Stage " <> int stage $$ ppr stats) $ zip [0..] regAllocStats) diff --git a/compiler/nativeGen/GraphBase.hs b/compiler/nativeGen/GraphBase.hs index b980ba2261..04eda96120 100644 --- a/compiler/nativeGen/GraphBase.hs +++ b/compiler/nativeGen/GraphBase.hs @@ -16,6 +16,7 @@ where import UniqSet import UniqFM + -- | A fn to check if a node is trivially colorable -- For graphs who's color classes are disjoint then a node is 'trivially colorable' -- when it has less neighbors and exclusions than available colors for that node. @@ -45,6 +46,7 @@ data Graph k cls color -- | All active nodes in the graph. graphMap :: UniqFM (Node k cls color) } + -- | An empty graph. initGraph :: Graph k cls color initGraph @@ -106,3 +108,4 @@ newNode k cls + diff --git a/compiler/nativeGen/GraphColor.hs b/compiler/nativeGen/GraphColor.hs index c33286b54f..6956c8d5b5 100644 --- a/compiler/nativeGen/GraphColor.hs +++ b/compiler/nativeGen/GraphColor.hs @@ -38,7 +38,8 @@ colorGraph :: ( Uniquable k, Uniquable cls, Uniquable color , Eq color, Eq cls, Ord k , Outputable k, Outputable cls, Outputable color) - => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + => Bool -- ^ whether to do iterative coalescing + -> UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable. -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. -> Graph k cls color -- ^ the graph to color. @@ -48,27 +49,42 @@ colorGraph , UniqFM k ) -- map of regs (r1 -> r2) that were coaleced -- r1 should be replaced by r2 in the source -colorGraph colors triv spill graph0 +colorGraph iterative colors triv spill graph0 = let - -- do aggressive coalesing on the graph - (graph_coalesced, rsCoalesce) - = coalesceGraph triv graph0 + -- if we're not doing iterative coalescing, then just do a single coalescing + -- pass at the front. This won't be as good but should still eat up a + -- lot of the reg-reg moves. + (graph_coalesced, kksCoalesce1) + = if not iterative + then coalesceGraph False triv graph0 + else (graph0, []) -- run the scanner to slurp out all the trivially colorable nodes - (ksTriv, ksProblems) - = colorScan triv spill graph_coalesced + -- (and do coalescing if iterative coalescing is enabled) + (ksTriv, ksProblems, kksCoalesce2) + = colorScan iterative triv spill graph_coalesced + + -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business. + -- We need to apply all the coalescences found by the scanner to the original + -- graph before doing assignColors. + (graph_scan_coalesced, _) + = mapAccumL (coalesceNodes False triv) graph_coalesced kksCoalesce2 -- color the trivially colorable nodes - -- as the keys were added to the front of the list while they were scanned, - -- this colors them in the reverse order they were found, as required by the algorithm. + -- during scanning, keys of triv nodes were added to the front of the list as they were found + -- this colors them in the reverse order, as required by the algorithm. (graph_triv, ksNoTriv) - = assignColors colors graph_coalesced ksTriv + = assignColors colors graph_scan_coalesced ksTriv -- try and color the problem nodes - (graph_prob, ksNoColor) = assignColors colors graph_triv ksProblems + -- problem nodes are the ones that were left uncolored because they weren't triv. + -- theres a change we can color them here anyway. + (graph_prob, ksNoColor) + = assignColors colors graph_triv ksProblems - -- if the trivially colorable nodes didn't color then something is wrong + -- if the trivially colorable nodes didn't color then something is probably wrong -- with the provided triv function. + -- in if not $ null ksNoTriv then pprPanic "colorGraph: trivially colorable nodes didn't color!" empty {- ( empty @@ -78,8 +94,10 @@ colorGraph colors triv spill graph0 $$ dotGraph (\x -> text "white") triv graph1) -} else ( graph_prob - , mkUniqSet ksNoColor - , listToUFM rsCoalesce) + , mkUniqSet ksNoColor -- the nodes that didn't color (spills) + , if iterative + then (listToUFM kksCoalesce2) + else (listToUFM kksCoalesce1)) -- | Scan through the conflict graph separating out trivially colorable and @@ -94,100 +112,99 @@ colorGraph colors triv spill graph0 -- at once the more likely it is that nodes we've already checked will become trivially colorable -- for the next pass. -- +-- TODO: add work lists to finding triv nodes is easier. +-- If we've just scanned the graph, and removed triv nodes, then the only +-- nodes that we need to rescan are the ones we've removed edges from. + colorScan - :: ( Uniquable k, Uniquable cls, Uniquable color) - => Triv k cls color -- ^ fn to decide whether a node is trivially colorable + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable color) + => Bool -- ^ whether to do iterative coalescing + -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. -> Graph k cls color -- ^ the graph to scan - -> ([k], [k]) -- triv colorable, problem nodes + -> ([k], [k], [(k, k)]) -- triv colorable nodes, problem nodes, pairs of nodes to coalesce -colorScan triv spill graph - = colorScan' triv spill graph - [] [] - [] - (eltsUFM $ graphMap graph) +colorScan iterative triv spill graph + = colorScan_spin iterative triv spill graph [] [] [] --- we've reached the end of the candidates list -colorScan' triv spill graph - ksTriv ksTrivFound - ksSpill - [] +colorScan_spin iterative triv spill graph + ksTriv ksSpill kksCoalesce -- if the graph is empty then we're done | isNullUFM $ graphMap graph - = (ksTrivFound ++ ksTriv, ksSpill) - - -- if we haven't found a trivially colorable node then we'll have to - -- choose a spill candidate and leave it uncolored - | [] <- ksTrivFound - , kSpill <- spill graph -- choose a spill candiate - , graph' <- delNode kSpill graph -- remove it from the graph - , nsRest' <- eltsUFM $ graphMap graph' -- graph has changed, so get new node list - - = colorScan' triv spill graph' - ksTriv ksTrivFound - (kSpill : ksSpill) - nsRest' - - -- we're at the end of the candidates list but we've found some triv nodes - -- along the way. We can delete them from the graph and go back for more. - | graph' <- foldr delNode graph ksTrivFound - , nsRest' <- eltsUFM $ graphMap graph' - - = colorScan' triv spill graph' - (ksTrivFound ++ ksTriv) [] - ksSpill - nsRest' - --- check if the current node is triv colorable -colorScan' triv spill graph - ksTriv ksTrivFound - ksSpill - (node : nsRest) - - -- node is trivially colorable - -- add it to the found nodes list and carry on. - | k <- nodeId node - , triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) - - = colorScan' triv spill graph - ksTriv (k : ksTrivFound) + = (ksTriv, ksSpill, kksCoalesce) + + -- Simplify: + -- Look for trivially colorable nodes. + -- If we can find some then remove them from the graph and go back for more. + -- + | nsTrivFound@(_:_) + <- scanGraph (\node -> triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) + + -- for iterative coalescing we only want non-move related + -- nodes here + && (not iterative || isEmptyUniqSet (nodeCoalesce node))) + $ graph + + , ksTrivFound <- map nodeId nsTrivFound + , graph3 <- foldr delNode graph ksTrivFound + = colorScan_spin iterative triv spill graph3 + (ksTrivFound ++ ksTriv) ksSpill - nsRest - - -- node wasn't trivially colorable, skip over it and look in the rest of the list + kksCoalesce + + -- Coalesce: + -- If we're doing iterative coalescing and no triv nodes are avaliable + -- then it's type for a coalescing pass. + | iterative + = case coalesceGraph False triv graph of + + -- we were able to coalesce something + -- go back and see if this frees up more nodes to be trivially colorable. + (graph2, kksCoalesceFound @(_:_)) + -> colorScan_spin iterative triv spill graph2 + ksTriv ksSpill (kksCoalesceFound ++ kksCoalesce) + + -- Freeze: + -- nothing could be coalesced (or was triv), + -- time to choose a node to freeze and give up on ever coalescing it. + (graph2, []) + -> case freezeOneInGraph graph2 of + + -- we were able to freeze something + -- hopefully this will free up something for Simplify + (graph3, True) + -> colorScan_spin iterative triv spill graph3 + ksTriv ksSpill kksCoalesce + + -- we couldn't find something to freeze either + -- time for a spill + (graph3, False) + -> colorScan_spill iterative triv spill graph3 + ksTriv ksSpill kksCoalesce + + -- spill time | otherwise - = colorScan' triv spill graph - ksTriv ksTrivFound - ksSpill - nsRest + = colorScan_spill iterative triv spill graph + ksTriv ksSpill kksCoalesce -{- -- This is cute and easy to understand, but too slow.. BL 2007/09 -colorScan colors triv spill safe prob graph +-- Select: +-- we couldn't find any triv nodes or things to freeze or coalesce, +-- and the graph isn't empty yet.. We'll have to choose a spill +-- candidate and leave it uncolored. +-- +colorScan_spill iterative triv spill graph + ksTriv ksSpill kksCoalesce - -- empty graphs are easy to color. - | isNullUFM $ graphMap graph - = (safe, prob) - - -- Try and find a trivially colorable node. - | Just node <- find (\node -> triv (nodeClass node) - (nodeConflicts node) - (nodeExclusions node)) - $ eltsUFM $ graphMap graph - , k <- nodeId node - = colorScan colors triv spill - (k : safe) prob (delNode k graph) + = let kSpill = spill graph + graph' = delNode kSpill graph + in colorScan_spin iterative triv spill graph' + ksTriv (kSpill : ksSpill) kksCoalesce - -- There was no trivially colorable node, - -- Choose one to potentially leave uncolored. We /might/ be able to find - -- a color for this later on, but no guarantees. - | k <- spill graph - = colorScan colors triv spill - safe (addOneToUniqSet prob k) (delNode k graph) --} - -- | Try to assign a color to all these nodes. diff --git a/compiler/nativeGen/GraphOps.hs b/compiler/nativeGen/GraphOps.hs index 308cae0467..c494e633f1 100644 --- a/compiler/nativeGen/GraphOps.hs +++ b/compiler/nativeGen/GraphOps.hs @@ -1,5 +1,7 @@ -- | Basic operations on graphs. -- +-- TODO: refine coalescing crieteria + {-# OPTIONS -fno-warn-missing-signatures #-} module GraphOps ( @@ -10,8 +12,9 @@ module GraphOps ( addCoalesce, delCoalesce, addExclusion, addPreference, - coalesceGraph, - coalesceNodes, + coalesceNodes, coalesceGraph, + freezeNode, freezeOneInGraph, freezeAllInGraph, + scanGraph, setColor, validateGraph, slurpNodeConflictCount @@ -117,6 +120,7 @@ modNode f k graph Nothing -> Nothing + -- | Get the size of the graph, O(n) size :: Uniquable k => Graph k cls color -> Int @@ -132,8 +136,6 @@ union :: Uniquable k union graph1 graph2 = Graph { graphMap = plusUFM (graphMap graph1) (graphMap graph2) } - - -- | Add a conflict between nodes to the graph, creating the nodes required. @@ -267,11 +269,16 @@ addPreference (u, c) color -- coalesceGraph :: (Uniquable k, Ord k, Eq cls, Outputable k) - => Triv k cls color + => Bool -- ^ If True, coalesce nodes even if this might make the graph + -- less colorable (aggressive coalescing) + -> Triv k cls color -> Graph k cls color -> (Graph k cls color, [(k, k)]) -coalesceGraph triv graph +coalesceGraph aggressive triv graph + = coalesceGraph' aggressive triv graph [] + +coalesceGraph' aggressive triv graph kkPairsAcc = let -- find all the nodes that have coalescence edges cNodes = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) @@ -290,9 +297,12 @@ coalesceGraph triv graph -- do the coalescing, returning the new graph and a list of pairs of keys -- that got coalesced together. (graph', mPairs) - = mapAccumL (coalesceNodes False triv) graph cList + = mapAccumL (coalesceNodes aggressive triv) graph cList - in (graph', catMaybes mPairs) + -- keep running until there are no more coalesces can be found + in case catMaybes mPairs of + [] -> (graph', kkPairsAcc) + pairs -> coalesceGraph' aggressive triv graph' (pairs ++ kkPairsAcc) -- | Coalesce this pair of nodes unconditionally / agressively. @@ -318,8 +328,8 @@ coalesceNodes aggressive triv graph (k1, k2) else (k2, k1) -- the nodes being coalesced must be in the graph - , Just nMin <- lookupNode graph kMin - , Just nMax <- lookupNode graph kMax + , Just nMin <- lookupNode graph kMin + , Just nMax <- lookupNode graph kMax -- can't coalesce conflicting modes , not $ elementOfUniqSet kMin (nodeConflicts nMax) @@ -384,7 +394,107 @@ coalesceNodes_check aggressive triv graph kMin kMax node in (graph', Just (kMax, kMin)) - + +-- | Freeze a node +-- This is for the iterative coalescer. +-- By freezing a node we give up on ever coalescing it. +-- Move all its coalesce edges into the frozen set - and update +-- back edges from other nodes. +-- +freezeNode + :: Uniquable k + => k -- ^ key of the node to freeze + -> Graph k cls color -- ^ the graph + -> Graph k cls color -- ^ graph with that node frozen + +freezeNode k + = graphMapModify + $ \fm -> + let + -- freeze all the edges in the node to be frozen + Just node = lookupUFM fm k + node' = node + { nodeCoalesce = emptyUniqSet } + + fm1 = addToUFM fm k node' + + -- update back edges pointing to this node + freezeEdge k node + = if elementOfUniqSet k (nodeCoalesce node) + then node + { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k } + else panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set" + + fm2 = foldUniqSet (adjustUFM (freezeEdge k)) fm1 + $ nodeCoalesce node + + in fm2 + + +-- | Freeze one node in the graph +-- This if for the iterative coalescer. +-- Look for a move related node of low degree and freeze it. +-- +-- We probably don't need to scan the whole graph looking for the node of absolute +-- lowest degree. Just sample the first few and choose the one with the lowest +-- degree out of those. Also, we don't make any distinction between conflicts of different +-- classes.. this is just a heuristic, after all. +-- +-- IDEA: freezing a node might free it up for Simplify.. would be good to check for triv +-- right here, and add it to a worklist if known triv/non-move nodes. +-- +freezeOneInGraph + :: (Uniquable k, Outputable k) + => Graph k cls color + -> ( Graph k cls color -- the new graph + , Bool ) -- whether we found a node to freeze + +freezeOneInGraph graph + = let compareNodeDegree n1 n2 + = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2) + + candidates + = sortBy compareNodeDegree + $ take 5 -- 5 isn't special, it's just a small number. + $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph + + in case candidates of + + -- there wasn't anything available to freeze + [] -> (graph, False) + + -- we found something to freeze + (n : _) + -> ( freezeNode (nodeId n) graph + , True) + + +-- | Freeze all the nodes in the graph +-- for debugging the iterative allocator. +-- +freezeAllInGraph + :: (Uniquable k, Outputable k) + => Graph k cls color + -> Graph k cls color + +freezeAllInGraph graph + = foldr freezeNode graph + $ map nodeId + $ eltsUFM $ graphMap graph + + +-- | Find all the nodes in the graph that meet some criteria +-- +scanGraph + :: Uniquable k + => (Node k cls color -> Bool) + -> Graph k cls color + -> [Node k cls color] + +scanGraph match graph + = filter match $ eltsUFM $ graphMap graph + + -- | validate the internal structure of a graph -- all its edges should point to valid nodes -- if they don't then throw an error @@ -396,12 +506,10 @@ validateGraph -> Graph k cls color validateGraph doc graph - = let edges = unionUniqSets - (unionManyUniqSets - (map nodeConflicts $ eltsUFM $ graphMap graph)) - (unionManyUniqSets - (map nodeCoalesce $ eltsUFM $ graphMap graph)) - + = let edges = unionManyUniqSets + ( (map nodeConflicts $ eltsUFM $ graphMap graph) + ++ (map nodeCoalesce $ eltsUFM $ graphMap graph)) + nodes = mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph badEdges = minusUniqSet edges nodes diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs index 45e51b927f..c2cefc3da4 100644 --- a/compiler/nativeGen/RegAllocColor.hs +++ b/compiler/nativeGen/RegAllocColor.hs @@ -27,6 +27,7 @@ import UniqSet import UniqFM import Bag import Outputable +import DynFlags import Data.List import Data.Maybe @@ -43,7 +44,7 @@ maxSpinCount = 10 -- | The top level of the graph coloring register allocator. -- regAlloc - :: Bool -- ^ whether to generate RegAllocStats, or not. + :: DynFlags -> UniqFM (UniqSet Reg) -- ^ the registers we can use for allocation -> UniqSet Int -- ^ the set of available spill slots. -> [LiveCmmTop] -- ^ code annotated with liveness information. @@ -51,16 +52,25 @@ regAlloc ( [NatCmmTop] -- ^ code with registers allocated. , [RegAllocStats] ) -- ^ stats for each stage of allocation -regAlloc dump regsFree slotsFree code +regAlloc dflags regsFree slotsFree code = do (code_final, debug_codeGraphs, _) - <- regAlloc_spin dump 0 trivColorable regsFree slotsFree [] code + <- regAlloc_spin dflags 0 trivColorable regsFree slotsFree [] code return ( code_final , reverse debug_codeGraphs ) -regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code +regAlloc_spin dflags (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code = do + -- 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." @@ -102,7 +112,10 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c -- try and color the graph let (graph_colored, rsSpill, rmCoalesce) - = {-# SCC "ColorGraph" #-} Color.colorGraph regsFree triv spill graph + = {-# SCC "ColorGraph" #-} + Color.colorGraph + (dopt Opt_RegsIterative dflags) + regsFree triv spill graph -- rewrite regs in the code that have been coalesced let patchF reg = case lookupUFM rmCoalesce reg of @@ -176,7 +189,7 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c -- space leak avoidance seqList statList `seq` return () - regAlloc_spin dump (spinCount + 1) triv regsFree slotsFree' + regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree' statList code_relive |