-
-- | Basic operations on graphs.
--
+-- TODO: refine coalescing crieteria
-{-# OPTIONS_GHC -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
--- for details
+{-# OPTIONS -fno-warn-missing-signatures #-}
module GraphOps (
addNode, delNode, getNode, lookupNode, modNode,
addCoalesce, delCoalesce,
addExclusion,
addPreference,
- coalesceGraph,
- coalesceNodes,
+ coalesceNodes, coalesceGraph,
+ freezeNode, freezeOneInGraph, freezeAllInGraph,
+ scanGraph,
setColor,
validateGraph,
slurpNodeConflictCount
import Data.List hiding (union)
import Data.Maybe
-
-- | Lookup a node from the graph.
lookupNode
:: Uniquable k
{ graphMap = addToUFM map_coalesce k node}
-
-- | Delete a node and all its edges from the graph.
--- Throws an error if it's not there.
-delNode :: Uniquable k
- => k -> Graph k cls color -> Graph k cls color
+delNode :: (Uniquable k, Outputable k)
+ => k -> Graph k cls color -> Maybe (Graph k cls color)
delNode k graph
- = let Just node = lookupNode graph k
-
- -- delete conflict edges from other nodes to this one.
- graph1 = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph
+ | Just node <- lookupNode graph k
+ = let -- delete conflict edges from other nodes to this one.
+ graph1 = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph
$ uniqSetToList (nodeConflicts node)
- -- delete coalesce edge from other nodes to this one.
- graph2 = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1
+ -- delete coalesce edge from other nodes to this one.
+ graph2 = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1
$ uniqSetToList (nodeCoalesce node)
- -- delete the node
- graph3 = graphMapModify (\fm -> delFromUFM fm k) graph2
+ -- delete the node
+ graph3 = graphMapModify (\fm -> delFromUFM fm k) graph2
- in graph3
+ in Just graph3
+ | otherwise
+ = Nothing
+
-- | Modify a node in the graph.
-- returns Nothing if the node isn't present.
Nothing -> Nothing
+
-- | Get the size of the graph, O(n)
size :: Uniquable k
=> Graph k cls color -> Int
union graph1 graph2
= Graph
{ graphMap = plusUFM (graphMap graph1) (graphMap graph2) }
-
-
-- | Add a conflict between nodes to the graph, creating the nodes required.
| otherwise
= graphMapModify
- $ (\fm -> foldr (\u -> addConflictSet1 u getClass conflicts) fm
+ $ (\fm -> foldl' (\g u -> addConflictSet1 u getClass conflicts g) fm
$ uniqSetToList conflicts)
addConflictSet1 u getClass set
- = let set' = delOneFromUniqSet set u
- in adjustWithDefaultUFM
+ = case delOneFromUniqSet set u of
+ set' -> adjustWithDefaultUFM
(\node -> node { nodeConflicts = unionUniqSets set' (nodeConflicts node) } )
(newNode u (getClass u)) { nodeConflicts = set' }
u
--
coalesceGraph
:: (Uniquable k, Ord k, Eq cls, Outputable k)
- => Graph 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 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))
-- do the coalescing, returning the new graph and a list of pairs of keys
-- that got coalesced together.
(graph', mPairs)
- = mapAccumL coalesceNodes 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.
coalesceNodes
:: (Uniquable k, Ord k, Eq cls, Outputable k)
- => Graph 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
-> (k, k) -- ^ keys of the nodes to be coalesced
-> (Graph k cls color, Maybe (k, k))
-coalesceNodes graph (k1, k2)
+coalesceNodes aggressive triv graph (k1, k2)
| (kMin, kMax) <- if k1 < k2
then (k1, k2)
else (k2, k1)
- -- nodes must be in the graph
+ -- the nodes being coalesced must be in the graph
, Just nMin <- lookupNode graph kMin
, Just nMax <- lookupNode graph kMax
- -- can't coalesce conflicting nodes
+ -- can't coalesce conflicting modes
, not $ elementOfUniqSet kMin (nodeConflicts nMax)
, not $ elementOfUniqSet kMax (nodeConflicts nMin)
- = coalesceNodes' graph kMin kMax nMin nMax
+ = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
-
-
- -- one of the nodes wasn't in the graph anymore
+ -- don't do the coalescing after all
| otherwise
= (graph, Nothing)
-coalesceNodes' graph kMin kMax nMin nMax
+coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
-- sanity checks
| nodeClass nMin /= nodeClass nMax
| not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax))
= error "GraphOps.coalesceNodes: can't coalesce colored nodes."
+ | nodeId nMin == nodeId nMax
+ = error "GraphOps.coalesceNodes: can't coalesce the same node."
+
---
| otherwise
= let
`delOneFromUniqSet` kMax
}
- -- delete the old nodes from the graph and add the new one
- graph' = addNode kMin node
- $ delNode kMin
- $ delNode kMax
- $ graph
+ in coalesceNodes_check aggressive triv graph kMin kMax node
+
+coalesceNodes_check aggressive triv graph kMin kMax node
+
+ -- Unless we're coalescing aggressively, if the result node is not trivially
+ -- colorable then don't do the coalescing.
+ | not aggressive
+ , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
+ = (graph, Nothing)
+
+ | otherwise
+ = let -- delete the old nodes from the graph and add the new one
+ Just graph1 = delNode kMax graph
+ Just graph2 = delNode kMin graph1
+ graph3 = addNode kMin node graph2
+
+ in (graph3, 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
- in (graph', Just (kMax, kMin))
-
-- | validate the internal structure of a graph
-- all its edges should point to valid nodes
-- if they don't then throw an error
-> 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
slurpNodeConflictCount graph
= addListToUFM_C
- (\(c1, n1) (c2, n2) -> (c1, n1 + n2))
+ (\(c1, n1) (_, n2) -> (c1, n1 + n2))
emptyUFM
$ map (\node
-> let count = sizeUniqSet $ nodeConflicts node
u
+{-# INLINE adjustWithDefaultUFM #-}
adjustWithDefaultUFM
:: Uniquable k
=> (a -> a) -> a -> k
adjustWithDefaultUFM f def k map
= addToUFM_C
- (\old new -> f old)
+ (\old _ -> f old)
map
k def
-
+{-# INLINE adjustUFM #-}
adjustUFM
:: Uniquable k
=> (a -> a)
= case lookupUFM map k of
Nothing -> map
Just a -> addToUFM map k (f a)
-
projects / ghc-hetmet.git / blobdiff