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
parent 8155ba50
......@@ -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
......
......@@ -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.
......
......@@ -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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment