X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FGraphOps.hs;h=1fa4199aa22c9b2ac99ca9cda8c1b68adb2761f5;hp=414abe4efce0489ebd138c563615252aaac166e5;hb=7b5b3b0cab463e108a0132435a28ef19d17cb32b;hpb=b01110d1352de5d972d8fb63f28c244d2c1ff99b diff --git a/compiler/utils/GraphOps.hs b/compiler/utils/GraphOps.hs index 414abe4..1fa4199 100644 --- a/compiler/utils/GraphOps.hs +++ b/compiler/utils/GraphOps.hs @@ -1,8 +1,6 @@ +{-# OPTIONS -fno-warn-missing-signatures #-} -- | Basic operations on graphs. -- --- TODO: refine coalescing crieteria - -{-# OPTIONS -fno-warn-missing-signatures #-} module GraphOps ( addNode, delNode, getNode, lookupNode, modNode, @@ -10,7 +8,7 @@ module GraphOps ( union, addConflict, delConflict, addConflicts, addCoalesce, delCoalesce, - addExclusion, + addExclusion, addExclusions, addPreference, coalesceNodes, coalesceGraph, freezeNode, freezeOneInGraph, freezeAllInGraph, @@ -63,14 +61,14 @@ addNode k node graph -- add back conflict edges from other nodes to this one map_conflict = foldUniqSet - (adjustUFM (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k})) + (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 (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k})) + (adjustUFM_C (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k})) map_conflict (nodeCoalesce node) @@ -215,6 +213,14 @@ addExclusion u getClass 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 + +addExclusions u getClass colors graph + = 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. @@ -273,7 +279,9 @@ coalesceGraph -- less colorable (aggressive coalescing) -> Triv k cls color -> Graph k cls color - -> (Graph k cls color, [(k, k)]) + -> ( 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 [] @@ -301,11 +309,11 @@ coalesceGraph' aggressive triv graph kkPairsAcc -- 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) + [] -> (graph', reverse kkPairsAcc) + pairs -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc) --- | Coalesce this pair of nodes unconditionally / agressively. +-- | 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 @@ -335,6 +343,9 @@ coalesceNodes aggressive triv graph (k1, k2) , not $ elementOfUniqSet kMin (nodeConflicts nMax) , not $ elementOfUniqSet kMax (nodeConflicts nMin) + -- can't coalesce the same node + , nodeId nMin /= nodeId nMax + = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax -- don't do the coalescing after all @@ -350,9 +361,6 @@ coalesceNodes_merge aggressive triv graph kMin kMax nMin 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 @@ -412,8 +420,7 @@ freezeNode freezeNode k = graphMapModify $ \fm -> - let - -- freeze all the edges in the node to be frozen + let -- freeze all the edges in the node to be frozen Just node = lookupUFM fm k node' = node { nodeCoalesce = emptyUniqSet } @@ -423,11 +430,11 @@ freezeNode k -- 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" + 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 (freezeEdge k)) fm1 + fm2 = foldUniqSet (adjustUFM_C (freezeEdge k)) fm1 $ nodeCoalesce node in fm2 @@ -443,7 +450,7 @@ freezeNode k -- 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. +-- right here, and add it to a worklist if known triv\/non-move nodes. -- freezeOneInGraph :: (Uniquable k, Outputable k) @@ -499,30 +506,76 @@ scanGraph match graph -- | validate the internal structure of a graph -- all its edges should point to valid nodes --- if they don't then throw an error +-- If they don't then throw an error -- validateGraph - :: (Uniquable k, Outputable k) - => SDoc - -> Graph k cls color - -> Graph k cls color + :: (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 -validateGraph doc graph - = let edges = unionManyUniqSets - ( (map nodeConflicts $ eltsUFM $ graphMap graph) - ++ (map nodeCoalesce $ eltsUFM $ graphMap graph)) - nodes = mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph +-- | If this node is colored, check that all the nodes which +-- 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 - badEdges = minusUniqSet edges nodes +checkNode graph node + | Just color <- nodeColor node + , Just neighbors <- sequence $ map (lookupNode graph) + $ uniqSetToList $ nodeConflicts node + + , neighbourColors <- catMaybes $ map nodeColor neighbors + , elem color neighbourColors + = False - in if isEmptyUniqSet badEdges - then graph - else pprPanic "GraphOps.validateGraph" - ( text "-- bad edges" - $$ vcat (map ppr $ uniqSetToList badEdges) - $$ text "----------------------------" - $$ doc) + | otherwise + = True + -- | Slurp out a map of how many nodes had a certain number of conflict neighbours @@ -551,7 +604,7 @@ setColor setColor u color = graphMapModify - $ adjustUFM + $ adjustUFM_C (\n -> n { nodeColor = Just color }) u @@ -568,13 +621,14 @@ adjustWithDefaultUFM f def k map map k def -{-# INLINE adjustUFM #-} -adjustUFM +-- Argument order different from UniqFM's adjustUFM +{-# INLINE adjustUFM_C #-} +adjustUFM_C :: Uniquable k => (a -> a) -> k -> UniqFM a -> UniqFM a -adjustUFM f k map +adjustUFM_C f k map = case lookupUFM map k of Nothing -> map Just a -> addToUFM map k (f a)