diff options
| -rw-r--r-- | compiler/utils/GraphOps.hs | 865 |
1 files changed, 432 insertions, 433 deletions
diff --git a/compiler/utils/GraphOps.hs b/compiler/utils/GraphOps.hs index 69d4943fb0..2c7a4daaa9 100644 --- a/compiler/utils/GraphOps.hs +++ b/compiler/utils/GraphOps.hs @@ -1,5 +1,4 @@ {-# OPTIONS -fno-warn-missing-signatures #-} -{-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See @@ -10,19 +9,19 @@ -- module GraphOps ( - addNode, delNode, getNode, lookupNode, modNode, - size, - union, - addConflict, delConflict, addConflicts, - addCoalesce, delCoalesce, - addExclusion, addExclusions, - addPreference, - coalesceNodes, coalesceGraph, - freezeNode, freezeOneInGraph, freezeAllInGraph, - scanGraph, - setColor, - validateGraph, - slurpNodeConflictCount + addNode, delNode, getNode, lookupNode, modNode, + size, + union, + addConflict, delConflict, addConflicts, + addCoalesce, delCoalesce, + addExclusion, addExclusions, + addPreference, + coalesceNodes, coalesceGraph, + freezeNode, freezeOneInGraph, freezeAllInGraph, + scanGraph, + setColor, + validateGraph, + slurpNodeConflictCount ) where @@ -33,610 +32,610 @@ import Unique import UniqSet import UniqFM -import Data.List hiding (union) +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 + :: Uniquable k + => Graph k cls color + -> k -> Maybe (Node k cls color) -lookupNode graph k - = lookupUFM (graphMap graph) k +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 + :: 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" + 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 - + => 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_C (\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_C (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k})) - map_conflict - (nodeCoalesce node) - - in graph - { graphMap = addToUFM map_coalesce k node} - + = let + -- add back conflict edges from other nodes to this one + map_conflict + = foldUniqSet + (adjustUFM_C (\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_C (\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) + => 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 + | 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. +-- 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) + => (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 + Just Node{} + -> Just + $ graphMapModify + (\fm -> let Just node = lookupUFM fm k + node' = f node + in addToUFM fm k node') + graph - Nothing -> Nothing + Nothing -> Nothing -- | Get the size of the graph, O(n) -size :: Uniquable k - => Graph k cls color -> Int - -size graph - = sizeUFM $ graphMap graph - +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) } +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. +-- 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 + :: 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) - - + = 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) - +-- 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 + = 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. +-- 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 - + :: 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 + -- 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) + | otherwise + = graphMapModify + $ (\fm -> foldl' (\g u -> addConflictSet1 u getClass conflicts g) fm + $ uniqSetToList conflicts) -addConflictSet1 u getClass set +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 + (\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. +-- 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 + :: (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 addExclusions - :: (Uniquable k, Uniquable color) - => k -> (k -> cls) -> [color] - -> Graph k cls color -> Graph k cls color + :: (Uniquable k, Uniquable color) + => k -> (k -> cls) -> [color] + -> Graph k cls color -> Graph k cls color addExclusions u getClass colors graph - = foldr (addExclusion u getClass) graph colors + = foldr (addExclusion u getClass) graph colors -- | 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 +-- 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) + :: 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 + = 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. +-- 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 +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. +-- 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)]) -- pairs of nodes that were coalesced, in the order that the - -- coalescing was applied. + :: (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)]) -- pairs of nodes that were coalesced, in the order that the + -- coalescing was applied. coalesceGraph aggressive 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)) - $ 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', reverse kkPairsAcc) - pairs -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc) + -- 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', reverse kkPairsAcc) + pairs -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc) -- | Coalesce this pair of nodes unconditionally \/ agressively. --- The resulting node is the one with the least key. +-- 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 +-- 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 +-- 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)) + :: (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) + | (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 + -- 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) + -- can't coalesce conflicting modes + , not $ elementOfUniqSet kMin (nodeConflicts nMax) + , not $ elementOfUniqSet kMax (nodeConflicts nMin) - -- can't coalesce the same node - , nodeId nMin /= nodeId nMax + -- can't coalesce the same node + , nodeId nMin /= nodeId nMax - = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax + = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax - -- don't do the coalescing after all - | otherwise - = (graph, Nothing) + -- 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." + -- 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." + | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax)) + = error "GraphOps.coalesceNodes: can't coalesce colored nodes." - --- - | otherwise - = let - -- the new node gets all the edges from its two components - node = - Node { nodeId = kMin - , nodeClass = nodeClass nMin - , nodeColor = Nothing + --- + | 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 + -- 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 + , 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 - } + -- 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 + 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) + -- 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 + | 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)) + 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. +-- 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 + :: 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 } + 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' + 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 node -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set" - -- If the edge isn't actually in the coelesce set then just ignore it. + -- update back edges pointing to this node + freezeEdge k node + = if elementOfUniqSet k (nodeCoalesce node) + then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k } + else node -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set" + -- If the edge isn't actually in the coelesce set then just ignore it. - fm2 = foldUniqSet (adjustUFM_C (freezeEdge k)) fm1 - $ nodeCoalesce node + fm2 = foldUniqSet (adjustUFM_C (freezeEdge k)) fm1 + $ nodeCoalesce node - in fm2 + 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. +-- 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. +-- 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. +-- 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 + :: (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) + = 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 + 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 + in case candidates of - -- there wasn't anything available to freeze - [] -> (graph, False) + -- there wasn't anything available to freeze + [] -> (graph, False) - -- we found something to freeze - (n : _) - -> ( freezeNode (nodeId n) graph - , True) + -- we found something to freeze + (n : _) + -> ( freezeNode (nodeId n) graph + , True) -- | Freeze all the nodes in the graph --- for debugging the iterative allocator. +-- for debugging the iterative allocator. -- freezeAllInGraph - :: (Uniquable k, Outputable k) - => Graph k cls color - -> Graph k cls color + :: (Uniquable k, Outputable k) + => Graph k cls color + -> Graph k cls color freezeAllInGraph graph - = foldr freezeNode graph - $ map nodeId - $ eltsUFM $ graphMap 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] + :: Uniquable k + => (Node k cls color -> Bool) + -> Graph k cls color + -> [Node k cls color] scanGraph match graph - = filter match $ eltsUFM $ graphMap 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 +-- all its edges should point to valid nodes +-- If they don't then throw an error -- validateGraph - :: (Uniquable k, Outputable k, Eq color) - => SDoc -- ^ extra debugging info to display on error - -> Bool -- ^ whether this graph is supposed to be colored. - -> Graph k cls color -- ^ graph to validate - -> Graph k cls color -- ^ validated graph + :: (Uniquable k, Outputable k, Eq color) + => SDoc -- ^ extra debugging info to display on error + -> Bool -- ^ whether this graph is supposed to be colored. + -> Graph k cls color -- ^ graph to validate + -> Graph k cls color -- ^ validated graph validateGraph doc isColored graph - -- Check that all edges point to valid nodes. - | edges <- unionManyUniqSets - ( (map nodeConflicts $ eltsUFM $ graphMap graph) - ++ (map nodeCoalesce $ eltsUFM $ graphMap graph)) - - , nodes <- mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph - , badEdges <- minusUniqSet edges nodes - , not $ isEmptyUniqSet badEdges - = pprPanic "GraphOps.validateGraph" - ( text "Graph has edges that point to non-existant nodes" - $$ text " bad edges: " <> vcat (map ppr $ uniqSetToList badEdges) - $$ doc ) - - -- Check that no conflicting nodes have the same color - | badNodes <- filter (not . (checkNode graph)) - $ eltsUFM $ graphMap graph - , not $ null badNodes - = pprPanic "GraphOps.validateGraph" - ( text "Node has same color as one of it's conflicts" - $$ text " bad nodes: " <> hcat (map (ppr . nodeId) badNodes) - $$ doc) - - -- If this is supposed to be a colored graph, - -- check that all nodes have a color. - | isColored - , badNodes <- filter (\n -> isNothing $ nodeColor n) - $ eltsUFM $ graphMap graph - , not $ null badNodes - = pprPanic "GraphOps.validateGraph" - ( text "Supposably colored graph has uncolored nodes." - $$ text " uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes) - $$ doc ) - - - -- graph looks ok - | otherwise - = graph + -- Check that all edges point to valid nodes. + | edges <- unionManyUniqSets + ( (map nodeConflicts $ eltsUFM $ graphMap graph) + ++ (map nodeCoalesce $ eltsUFM $ graphMap graph)) + + , nodes <- mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph + , badEdges <- minusUniqSet edges nodes + , not $ isEmptyUniqSet badEdges + = pprPanic "GraphOps.validateGraph" + ( text "Graph has edges that point to non-existant nodes" + $$ text " bad edges: " <> vcat (map ppr $ uniqSetToList badEdges) + $$ doc ) + + -- Check that no conflicting nodes have the same color + | badNodes <- filter (not . (checkNode graph)) + $ eltsUFM $ graphMap graph + , not $ null badNodes + = pprPanic "GraphOps.validateGraph" + ( text "Node has same color as one of it's conflicts" + $$ text " bad nodes: " <> hcat (map (ppr . nodeId) badNodes) + $$ doc) + + -- If this is supposed to be a colored graph, + -- check that all nodes have a color. + | isColored + , badNodes <- filter (\n -> isNothing $ nodeColor n) + $ eltsUFM $ graphMap graph + , not $ null badNodes + = pprPanic "GraphOps.validateGraph" + ( text "Supposably colored graph has uncolored nodes." + $$ text " uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes) + $$ doc ) + + + -- graph looks ok + | otherwise + = graph -- | If this node is colored, check that all the nodes which --- conflict with it have different colors. +-- conflict with it have different colors. checkNode - :: (Uniquable k, Eq color) - => Graph k cls color - -> Node k cls color - -> Bool -- ^ True if this node is ok - + :: (Uniquable k, Eq color) + => Graph k cls color + -> Node k cls color + -> Bool -- ^ True if this node is ok + checkNode graph node - | Just color <- nodeColor node - , Just neighbors <- sequence $ map (lookupNode graph) - $ uniqSetToList $ nodeConflicts node + | Just color <- nodeColor node + , Just neighbors <- sequence $ map (lookupNode graph) + $ uniqSetToList $ nodeConflicts node + + , neighbourColors <- catMaybes $ map nodeColor neighbors + , elem color neighbourColors + = False - , neighbourColors <- catMaybes $ map nodeColor neighbors - , elem color neighbourColors - = False - - | otherwise - = True + | otherwise + = True -- | 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) + :: 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 + = 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 + :: Uniquable k + => k -> color + -> Graph k cls color -> Graph k cls color + setColor u color - = graphMapModify - $ adjustUFM_C - (\n -> n { nodeColor = Just color }) - u - - -{-# INLINE adjustWithDefaultUFM #-} -adjustWithDefaultUFM - :: Uniquable k - => (a -> a) -> a -> k - -> UniqFM a -> UniqFM a + = graphMapModify + $ adjustUFM_C + (\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 - + = addToUFM_C + (\old _ -> f old) + map + k def + -- Argument order different from UniqFM's adjustUFM {-# INLINE adjustUFM_C #-} -adjustUFM_C - :: Uniquable k - => (a -> a) - -> k -> UniqFM a -> UniqFM a +adjustUFM_C + :: Uniquable k + => (a -> a) + -> k -> UniqFM a -> UniqFM a adjustUFM_C f k map = case lookupUFM map k of - Nothing -> map - Just a -> addToUFM map k (f a) + Nothing -> map + Just a -> addToUFM map k (f a) |