+++ /dev/null
--- | Basic operations on graphs.
---
--- TODO: refine coalescing crieteria
-
-{-# OPTIONS -fno-warn-missing-signatures #-}
-
-module GraphOps (
- addNode, delNode, getNode, lookupNode, modNode,
- size,
- union,
- addConflict, delConflict, addConflicts,
- addCoalesce, delCoalesce,
- addExclusion,
- addPreference,
- coalesceNodes, coalesceGraph,
- freezeNode, freezeOneInGraph, freezeAllInGraph,
- scanGraph,
- setColor,
- validateGraph,
- slurpNodeConflictCount
-)
-where
-
-import GraphBase
-
-import Outputable
-import Unique
-import UniqSet
-import UniqFM
-
-import Data.List hiding (union)
-import Data.Maybe
-
--- | Lookup a node from the graph.
-lookupNode
- :: Uniquable k
- => Graph k cls color
- -> k -> Maybe (Node k cls color)
-
-lookupNode graph k
- = lookupUFM (graphMap graph) k
-
-
--- | Get a node from the graph, throwing an error if it's not there
-getNode
- :: Uniquable k
- => Graph k cls color
- -> k -> Node k cls color
-
-getNode graph k
- = case lookupUFM (graphMap graph) k of
- Just node -> node
- Nothing -> panic "ColorOps.getNode: not found"
-
-
--- | Add a node to the graph, linking up its edges
-addNode :: Uniquable k
- => k -> Node k cls color
- -> Graph k cls color -> Graph k cls color
-
-addNode k node graph
- = let
- -- add back conflict edges from other nodes to this one
- map_conflict
- = foldUniqSet
- (adjustUFM (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k}))
- (graphMap graph)
- (nodeConflicts node)
-
- -- add back coalesce edges from other nodes to this one
- map_coalesce
- = foldUniqSet
- (adjustUFM (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k}))
- map_conflict
- (nodeCoalesce node)
-
- in graph
- { graphMap = addToUFM map_coalesce k node}
-
-
--- | Delete a node and all its edges from the graph.
-delNode :: (Uniquable k, Outputable k)
- => k -> Graph k cls color -> Maybe (Graph k cls color)
-
-delNode k 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
- $ uniqSetToList (nodeCoalesce node)
-
- -- delete the node
- graph3 = graphMapModify (\fm -> delFromUFM fm k) graph2
-
- in Just graph3
-
- | otherwise
- = Nothing
-
-
--- | Modify a node in the graph.
--- returns Nothing if the node isn't present.
---
-modNode :: Uniquable k
- => (Node k cls color -> Node k cls color)
- -> k -> Graph k cls color -> Maybe (Graph k cls color)
-
-modNode f k graph
- = case lookupNode graph k of
- Just Node{}
- -> Just
- $ graphMapModify
- (\fm -> let Just node = lookupUFM fm k
- node' = f node
- in addToUFM fm k node')
- graph
-
- Nothing -> Nothing
-
-
--- | Get the size of the graph, O(n)
-size :: Uniquable k
- => Graph k cls color -> Int
-
-size graph
- = sizeUFM $ graphMap graph
-
-
--- | Union two graphs together.
-union :: Uniquable k
- => Graph k cls color -> Graph k cls color -> Graph k cls color
-
-union graph1 graph2
- = Graph
- { graphMap = plusUFM (graphMap graph1) (graphMap graph2) }
-
-
--- | Add a conflict between nodes to the graph, creating the nodes required.
--- Conflicts are virtual regs which need to be colored differently.
-addConflict
- :: Uniquable k
- => (k, cls) -> (k, cls)
- -> Graph k cls color -> Graph k cls color
-
-addConflict (u1, c1) (u2, c2)
- = let addNeighbor u c u'
- = adjustWithDefaultUFM
- (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' })
- (newNode u c) { nodeConflicts = unitUniqSet u' }
- u
-
- in graphMapModify
- ( addNeighbor u1 c1 u2
- . addNeighbor u2 c2 u1)
-
-
--- | Delete a conflict edge. k1 -> k2
--- returns Nothing if the node isn't in the graph
-delConflict
- :: Uniquable k
- => k -> k
- -> Graph k cls color -> Maybe (Graph k cls color)
-
-delConflict k1 k2
- = modNode
- (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 })
- k1
-
-
--- | Add some conflicts to the graph, creating nodes if required.
--- All the nodes in the set are taken to conflict with each other.
-addConflicts
- :: Uniquable k
- => UniqSet k -> (k -> cls)
- -> Graph k cls color -> Graph k cls color
-
-addConflicts conflicts getClass
-
- -- just a single node, but no conflicts, create the node anyway.
- | (u : []) <- uniqSetToList conflicts
- = graphMapModify
- $ adjustWithDefaultUFM
- id
- (newNode u (getClass u))
- u
-
- | otherwise
- = graphMapModify
- $ (\fm -> foldl' (\g u -> addConflictSet1 u getClass conflicts g) fm
- $ uniqSetToList conflicts)
-
-
-addConflictSet1 u getClass set
- = case delOneFromUniqSet set u of
- set' -> adjustWithDefaultUFM
- (\node -> node { nodeConflicts = unionUniqSets set' (nodeConflicts node) } )
- (newNode u (getClass u)) { nodeConflicts = set' }
- u
-
-
--- | Add an exclusion to the graph, creating nodes if required.
--- These are extra colors that the node cannot use.
-addExclusion
- :: (Uniquable k, Uniquable color)
- => k -> (k -> cls) -> color
- -> Graph k cls color -> Graph k cls color
-
-addExclusion u getClass color
- = graphMapModify
- $ adjustWithDefaultUFM
- (\node -> node { nodeExclusions = addOneToUniqSet (nodeExclusions node) color })
- (newNode u (getClass u)) { nodeExclusions = unitUniqSet color }
- u
-
-
--- | Add a coalescence edge to the graph, creating nodes if requried.
--- It is considered adventageous to assign the same color to nodes in a coalesence.
-addCoalesce
- :: Uniquable k
- => (k, cls) -> (k, cls)
- -> Graph k cls color -> Graph k cls color
-
-addCoalesce (u1, c1) (u2, c2)
- = let addCoalesce u c u'
- = adjustWithDefaultUFM
- (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' })
- (newNode u c) { nodeCoalesce = unitUniqSet u' }
- u
-
- in graphMapModify
- ( addCoalesce u1 c1 u2
- . addCoalesce u2 c2 u1)
-
-
--- | Delete a coalescence edge (k1 -> k2) from the graph.
-delCoalesce
- :: Uniquable k
- => k -> k
- -> Graph k cls color -> Maybe (Graph k cls color)
-
-delCoalesce k1 k2
- = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 })
- k1
-
-
--- | Add a color preference to the graph, creating nodes if required.
--- The most recently added preference is the most prefered.
--- The algorithm tries to assign a node it's prefered color if possible.
---
-addPreference
- :: Uniquable k
- => (k, cls) -> color
- -> Graph k cls color -> Graph k cls color
-
-addPreference (u, c) color
- = graphMapModify
- $ adjustWithDefaultUFM
- (\node -> node { nodePreference = color : (nodePreference node) })
- (newNode u c) { nodePreference = [color] }
- u
-
-
--- | Do agressive coalescing on this graph.
--- returns the new graph and the list of pairs of nodes that got coaleced together.
--- for each pair, the resulting node will have the least key and be second in the pair.
---
-coalesceGraph
- :: (Uniquable k, Ord k, Eq cls, Outputable k)
- => 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 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))
- $ eltsUFM $ graphMap graph
-
- -- build a list of pairs of keys for node's we'll try and coalesce
- -- every pair of nodes will appear twice in this list
- -- ie [(k1, k2), (k2, k1) ... ]
- -- This is ok, GrapOps.coalesceNodes handles this and it's convenient for
- -- build a list of what nodes get coalesced together for later on.
- --
- cList = [ (nodeId node1, k2)
- | node1 <- cNodes
- , k2 <- uniqSetToList $ nodeCoalesce node1 ]
-
- -- do the coalescing, returning the new graph and a list of pairs of keys
- -- that got coalesced together.
- (graph', mPairs)
- = mapAccumL (coalesceNodes aggressive triv) graph cList
-
- -- 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.
--- The resulting node is the one with the least key.
---
--- returns: Just the pair of keys if the nodes were coalesced
--- the second element of the pair being the least one
---
--- Nothing if either of the nodes weren't in the graph
-
-coalesceNodes
- :: (Uniquable k, Ord k, Eq cls, Outputable k)
- => 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 aggressive triv graph (k1, k2)
- | (kMin, kMax) <- if k1 < k2
- then (k1, k2)
- else (k2, k1)
-
- -- the nodes being coalesced must be in the graph
- , Just nMin <- lookupNode graph kMin
- , Just nMax <- lookupNode graph kMax
-
- -- can't coalesce conflicting modes
- , not $ elementOfUniqSet kMin (nodeConflicts nMax)
- , not $ elementOfUniqSet kMax (nodeConflicts nMin)
-
- = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
-
- -- don't do the coalescing after all
- | otherwise
- = (graph, Nothing)
-
-coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
-
- -- sanity checks
- | nodeClass nMin /= nodeClass nMax
- = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes."
-
- | 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
- -- the new node gets all the edges from its two components
- node =
- Node { nodeId = kMin
- , nodeClass = nodeClass nMin
- , nodeColor = Nothing
-
- -- nodes don't conflict with themselves..
- , nodeConflicts
- = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax))
- `delOneFromUniqSet` kMin
- `delOneFromUniqSet` kMax
-
- , nodeExclusions = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax)
- , nodePreference = nodePreference nMin ++ nodePreference nMax
-
- -- nodes don't coalesce with themselves..
- , nodeCoalesce
- = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax))
- `delOneFromUniqSet` kMin
- `delOneFromUniqSet` kMax
- }
-
- 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
-
-
--- | validate the internal structure of a graph
--- all its edges should point to valid nodes
--- if they don't then throw an error
---
-validateGraph
- :: (Uniquable k, Outputable k)
- => SDoc
- -> Graph k cls color
- -> Graph k cls color
-
-validateGraph doc 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
-
- in if isEmptyUniqSet badEdges
- then graph
- else pprPanic "GraphOps.validateGraph"
- ( text "-- bad edges"
- $$ vcat (map ppr $ uniqSetToList badEdges)
- $$ text "----------------------------"
- $$ doc)
-
-
--- | Slurp out a map of how many nodes had a certain number of conflict neighbours
-
-slurpNodeConflictCount
- :: Uniquable k
- => Graph k cls color
- -> UniqFM (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts)
-
-slurpNodeConflictCount graph
- = addListToUFM_C
- (\(c1, n1) (_, n2) -> (c1, n1 + n2))
- emptyUFM
- $ map (\node
- -> let count = sizeUniqSet $ nodeConflicts node
- in (count, (count, 1)))
- $ eltsUFM
- $ graphMap graph
-
-
--- | Set the color of a certain node
-setColor
- :: Uniquable k
- => k -> color
- -> Graph k cls color -> Graph k cls color
-
-setColor u color
- = graphMapModify
- $ adjustUFM
- (\n -> n { nodeColor = Just color })
- u
-
-
-{-# INLINE adjustWithDefaultUFM #-}
-adjustWithDefaultUFM
- :: Uniquable k
- => (a -> a) -> a -> k
- -> UniqFM a -> UniqFM a
-
-adjustWithDefaultUFM f def k map
- = addToUFM_C
- (\old _ -> f old)
- map
- k def
-
-{-# INLINE adjustUFM #-}
-adjustUFM
- :: Uniquable k
- => (a -> a)
- -> k -> UniqFM a -> UniqFM a
-
-adjustUFM f k map
- = case lookupUFM map k of
- Nothing -> map
- Just a -> addToUFM map k (f a)
-
projects / ghc-hetmet.git / blobdiff