From 1dd44153dac634be2e6af2b68eff2ceb74a8c64c Mon Sep 17 00:00:00 2001 From: "Ben.Lippmeier@anu.edu.au" Date: Wed, 5 Sep 2007 16:44:01 +0000 Subject: [PATCH] Improve GraphColor.colorScan Testing whether a node in the conflict graph is trivially colorable (triv) is still a somewhat expensive operation. When we find a triv node during scanning, even though we remove it and its edges from the graph, this is unlikely to to make the nodes we've just scanned become triv - so there's not much point re-scanning them right away. Scanning now takes place in passes. We scan the whole graph for triv nodes and remove all the ones found in a batch before rescanning old nodes. Register allocation for SHA1.lhs now takes (just) 40% of total compile time with -O2 -fregs-graph on x86 --- compiler/nativeGen/AsmCodeGen.lhs | 4 +- compiler/nativeGen/GraphColor.hs | 93 +++++++++++++++++++++++++++++++++-- compiler/nativeGen/RegAllocColor.hs | 29 ++++++++--- 3 files changed, 113 insertions(+), 13 deletions(-) diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index c9f11d5..8598e7e 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -278,7 +278,7 @@ cmmNativeGen dflags us cmm -- graph coloring register allocation let ((alloced, regAllocStats), usAlloc) - = {-# SCC "RegAlloc(color)" #-} + = {-# SCC "RegAlloc" #-} initUs usLive $ Color.regAlloc generateRegAllocStats @@ -312,7 +312,7 @@ cmmNativeGen dflags us cmm else do -- do linear register allocation let ((alloced, regAllocStats), usAlloc) - = {-# SCC "RegAlloc(linear)" #-} + = {-# SCC "RegAlloc" #-} initUs usLive $ liftM unzip $ mapUs Linear.regAlloc withLiveness diff --git a/compiler/nativeGen/GraphColor.hs b/compiler/nativeGen/GraphColor.hs index c60c12d..c6aea25 100644 --- a/compiler/nativeGen/GraphColor.hs +++ b/compiler/nativeGen/GraphColor.hs @@ -56,14 +56,16 @@ colorGraph colors triv spill graph0 -- run the scanner to slurp out all the trivially colorable nodes (ksTriv, ksProblems) - = colorScan colors triv spill [] emptyUniqSet graph_coalesced + = colorScan triv spill graph_coalesced -- 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. (graph_triv, ksNoTriv) = assignColors colors graph_coalesced ksTriv -- try and color the problem nodes - (graph_prob, ksNoColor) = assignColors colors graph_triv (uniqSetToList ksProblems) + (graph_prob, ksNoColor) = assignColors colors graph_triv ksProblems -- if the trivially colorable nodes didn't color then something is wrong -- with the provided triv function. @@ -79,6 +81,90 @@ colorGraph colors triv spill graph0 , mkUniqSet ksNoColor , listToUFM rsCoalesce) + +-- | Scan through the conflict graph separating out trivially colorable and +-- potentially uncolorable (problem) nodes. +-- +-- Checking whether a node is trivially colorable or not is a resonably expensive operation, +-- so after a triv node is found and removed from the graph it's no good to return to the 'start' +-- of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable. +-- +-- To ward against this, during each pass through the graph we collect up a list of triv nodes +-- that were found, and only remove them once we've finished the pass. The more nodes we can delete +-- at once the more likely it is that nodes we've already checked will become trivially colorable +-- for the next pass. +-- +colorScan + :: ( Uniquable k, Uniquable cls, Uniquable color) + => 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 + + +colorScan triv spill graph + = colorScan' triv spill graph + [] [] + [] + (eltsUFM $ graphMap graph) + +-- we've reached the end of the candidates list +colorScan' triv spill graph + ksTriv ksTrivFound + ksSpill + [] + + -- 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) + ksSpill + nsRest + + -- node wasn't trivially colorable, skip over it and look in the rest of the list + | otherwise + = colorScan' triv spill graph + ksTriv ksTrivFound + ksSpill + nsRest + +{- -- This is cute and easy to understand, but too slow.. BL 2007/09 + colorScan colors triv spill safe prob graph -- empty graphs are easy to color. @@ -100,7 +186,8 @@ colorScan colors triv spill safe prob graph | 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/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs index 0cd3923..8449b5e 100644 --- a/compiler/nativeGen/RegAllocColor.hs +++ b/compiler/nativeGen/RegAllocColor.hs @@ -35,6 +35,7 @@ import UniqSet import UniqFM import Bag import Outputable +import Util import Data.List import Data.Maybe @@ -124,7 +125,7 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c -- strip off liveness information let code_nat = map stripLive code_patched - -- rewrite SPILL/REALOAD pseudos into real instructions + -- rewrite SPILL/RELOAD pseudos into real instructions let spillNatTop = mapGenBlockTop spillNatBlock let code_final = map spillNatTop code_nat @@ -138,10 +139,16 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c , raFinal = code_final , raSRMs = foldl addSRM (0, 0, 0) $ map countSRMs code_spillclean } - return ( code_final - , if dump - then [stat] ++ maybeToList stat1 ++ debug_codeGraphs + + let statList = + if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs else [] + + -- space leak avoidance + seqList statList $! return () + + return ( code_final + , statList , graph_colored) else do @@ -162,11 +169,16 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c , raLifetimes = fmLife , raSpilled = code_spilled } - -- try again - regAlloc_spin dump (spinCount + 1) triv regsFree slotsFree' - (if dump + let statList = + if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs - else []) + else [] + + -- space leak avoidance + seqList statList $! return () + + regAlloc_spin dump (spinCount + 1) triv regsFree slotsFree' + statList code_relive @@ -310,3 +322,4 @@ plusUFMs_C :: (elt -> elt -> elt) -> [UniqFM elt] -> UniqFM elt plusUFMs_C f maps = foldl (plusUFM_C f) emptyUFM maps + -- 1.7.10.4