X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FDigraph.lhs;h=6d1d8d4639b5bf218aa074150853fa133d601111;hp=9129d9d929bff35374630af6abaeaea21fa2d9fc;hb=30c122df62ec75f9ed7f392f24c2925675bf1d06;hpb=317fc69d18eda68fd65f5ba634feafbe4a3923da diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs index 9129d9d..6d1d8d4 100644 --- a/compiler/utils/Digraph.lhs +++ b/compiler/utils/Digraph.lhs @@ -5,39 +5,38 @@ \begin{code} module Digraph( - -- At present the only one with a "nice" external interface - stronglyConnComp, stronglyConnCompR, SCC(..), flattenSCC, flattenSCCs, - - Graph, Vertex, - graphFromEdges, graphFromEdges', - buildG, transposeG, reverseE, outdegree, indegree, - - Tree(..), Forest, - showTree, showForest, - - dfs, dff, - topSort, - components, - scc, - back, cross, forward, - reachable, path, - bcc - + -- At present the only one with a "nice" external interface + stronglyConnComp, stronglyConnCompR, SCC(..), flattenSCC, flattenSCCs, + + Graph, Vertex, + graphFromEdges, graphFromEdges', + buildG, transposeG, reverseE, outdegree, indegree, + + Tree(..), Forest, + showTree, showForest, + + dfs, dff, + topSort, + components, + scc, + back, cross, forward, + reachable, path, + bcc ) where -# include "HsVersions.h" +#include "HsVersions.h" ------------------------------------------------------------------------------ -- A version of the graph algorithms described in: --- +-- -- ``Lazy Depth-First Search and Linear Graph Algorithms in Haskell'' -- by David King and John Launchbury --- +-- -- Also included is some additional code for printing tree structures ... ------------------------------------------------------------------------------ -import Util ( sortLe ) +import Util ( sortLe ) import Outputable -- Extensions @@ -48,7 +47,7 @@ import Data.Maybe import Data.Array import Data.List -#if __GLASGOW_HASKELL__ > 604 +#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ > 604 import Data.Array.ST #else import Data.Array.ST hiding ( indices, bounds ) @@ -57,18 +56,19 @@ import Data.Array.ST hiding ( indices, bounds ) %************************************************************************ -%* * -%* External interface -%* * +%* * +%* External interface +%* * %************************************************************************ \begin{code} data SCC vertex = AcyclicSCC vertex - | CyclicSCC [vertex] + | CyclicSCC [vertex] flattenSCCs :: [SCC a] -> [a] flattenSCCs = concatMap flattenSCC +flattenSCC :: SCC a -> [a] flattenSCC (AcyclicSCC v) = [v] flattenSCC (CyclicSCC vs) = vs @@ -77,14 +77,24 @@ instance Outputable a => Outputable (SCC a) where ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs))) \end{code} +Note [Nodes, keys, vertices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * A 'node' is a big blob of client-stuff + + * Each 'node' has a unique (client) 'key', but the latter + is in Ord and has fast comparison + + * Digraph then maps each 'key' to a Vertex (Int) which is + arranged densely in 0.n + \begin{code} stronglyConnComp - :: Ord key - => [(node, key, [key])] -- The graph; its ok for the - -- out-list to contain keys which arent - -- a vertex key, they are ignored - -> [SCC node] -- Returned in topologically sorted order - -- Later components depend on earlier ones, but not vice versa + :: Ord key + => [(node, key, [key])] -- The graph; its ok for the + -- out-list to contain keys which arent + -- a vertex key, they are ignored + -> [SCC node] -- Returned in topologically sorted order + -- Later components depend on earlier ones, but not vice versa stronglyConnComp edges = map get_node (stronglyConnCompR edges) @@ -95,30 +105,30 @@ stronglyConnComp edges -- The "R" interface is used when you expect to apply SCC to -- the (some of) the result of SCC, so you dont want to lose the dependency info stronglyConnCompR - :: Ord key - => [(node, key, [key])] -- The graph; its ok for the - -- out-list to contain keys which arent - -- a vertex key, they are ignored - -> [SCC (node, key, [key])] -- Topologically sorted + :: Ord key + => [(node, key, [key])] -- The graph; its ok for the + -- out-list to contain keys which arent + -- a vertex key, they are ignored + -> [SCC (node, key, [key])] -- Topologically sorted stronglyConnCompR [] = [] -- added to avoid creating empty array in graphFromEdges -- SOF stronglyConnCompR edges = map decode forest where - (graph, vertex_fn) = _scc_ "graphFromEdges" graphFromEdges edges - forest = _scc_ "Digraph.scc" scc graph + (graph, vertex_fn) = {-# SCC "graphFromEdges" #-} graphFromEdges edges + forest = {-# SCC "Digraph.scc" #-} scc graph decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v] - | otherwise = AcyclicSCC (vertex_fn v) + | otherwise = AcyclicSCC (vertex_fn v) decode other = CyclicSCC (dec other []) - where - dec (Node v ts) vs = vertex_fn v : foldr dec vs ts + where + dec (Node v ts) vs = vertex_fn v : foldr dec vs ts mentions_itself v = v `elem` (graph ! v) \end{code} %************************************************************************ -%* * -%* Graphs -%* * +%* * +%* Graphs +%* * %************************************************************************ @@ -138,7 +148,7 @@ edges :: Graph -> [Edge] edges g = [ (v, w) | v <- vertices g, w <- g!v ] mapT :: (Vertex -> a -> b) -> Table a -> Table b -mapT f t = array (bounds t) [ (,) v (f v (t!v)) | v <- indices t ] +mapT f t = array (bounds t) [ (v, f v (t ! v)) | v <- indices t ] buildG :: Bounds -> [Edge] -> Graph buildG bounds edges = accumArray (flip (:)) [] bounds edges @@ -151,7 +161,7 @@ reverseE g = [ (w, v) | (v, w) <- edges g ] outdegree :: Graph -> Table Int outdegree = mapT numEdges - where numEdges v ws = length ws + where numEdges _ ws = length ws indegree :: Graph -> Table Int indegree = outdegree . transposeG @@ -159,51 +169,53 @@ indegree = outdegree . transposeG \begin{code} -graphFromEdges - :: Ord key - => [(node, key, [key])] - -> (Graph, Vertex -> (node, key, [key])) -graphFromEdges edges = - case graphFromEdges' edges of (graph, vertex_fn, _) -> (graph, vertex_fn) +graphFromEdges + :: Ord key + => [(node, key, [key])] + -> (Graph, Vertex -> (node, key, [key])) +graphFromEdges edges = + case graphFromEdges' edges of (graph, vertex_fn, _) -> (graph, vertex_fn) graphFromEdges' - :: Ord key - => [(node, key, [key])] - -> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex) + :: Ord key + => [(node, key, [key])] + -> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex) graphFromEdges' edges = (graph, \v -> vertex_map ! v, key_vertex) where - max_v = length edges - 1 + max_v = length edges - 1 bounds = (0,max_v) :: (Vertex, Vertex) sorted_edges = let - (_,k1,_) `le` (_,k2,_) = case k1 `compare` k2 of { GT -> False; other -> True } - in - sortLe le edges - edges1 = zipWith (,) [0..] sorted_edges + (_,k1,_) `le` (_,k2,_) = (k1 `compare` k2) /= GT + in + sortLe le edges + edges1 = zipWith (,) [0..] sorted_edges - graph = array bounds [(,) v (mapMaybe key_vertex ks) | (,) v (_, _, ks) <- edges1] - key_map = array bounds [(,) v k | (,) v (_, k, _ ) <- edges1] - vertex_map = array bounds edges1 + graph = array bounds [ (v, mapMaybe key_vertex ks) + | (v, (_, _, ks)) <- edges1] + key_map = array bounds [ (v, k) + | (v, (_, k, _ )) <- edges1] + vertex_map = array bounds edges1 -- key_vertex :: key -> Maybe Vertex - -- returns Nothing for non-interesting vertices - key_vertex k = find 0 max_v - where - find a b | a > b - = Nothing - find a b = case compare k (key_map ! mid) of - LT -> find a (mid-1) - EQ -> Just mid - GT -> find (mid+1) b - where - mid = (a + b) `div` 2 + -- returns Nothing for non-interesting vertices + key_vertex k = find 0 max_v + where + find a b | a > b + = Nothing + find a b = case compare k (key_map ! mid) of + LT -> find a (mid-1) + EQ -> Just mid + GT -> find (mid+1) b + where + mid = (a + b) `div` 2 \end{code} %************************************************************************ -%* * -%* Trees and forests -%* * +%* * +%* Trees and forests +%* * %************************************************************************ \begin{code} @@ -216,7 +228,7 @@ mapTree f (Node x ts) = Node (f x) (map (mapTree f) ts) \begin{code} instance Show a => Show (Tree a) where - showsPrec p t s = showTree t ++ s + showsPrec _ t s = showTree t ++ s showTree :: Show a => Tree a -> String showTree = drawTree . mapTree show @@ -227,6 +239,7 @@ showForest = unlines . map showTree drawTree :: Tree String -> String drawTree = unlines . draw +draw :: Tree String -> [String] draw (Node x ts) = grp this (space (length this)) (stLoop ts) where this = s1 ++ x ++ " " @@ -236,6 +249,7 @@ draw (Node x ts) = grp this (space (length this)) (stLoop ts) stLoop [t] = grp s2 " " (draw t) stLoop (t:ts) = grp s3 s4 (draw t) ++ [s4] ++ rsLoop ts + rsLoop [] = [] rsLoop [t] = grp s5 " " (draw t) rsLoop (t:ts) = grp s6 s4 (draw t) ++ [s4] ++ rsLoop ts @@ -246,9 +260,9 @@ draw (Node x ts) = grp this (space (length this)) (stLoop ts) %************************************************************************ -%* * -%* Depth first search -%* * +%* * +%* Depth first search +%* * %************************************************************************ \begin{code} @@ -279,7 +293,7 @@ prune bnds ts = runST (mkEmpty bnds >>= \m -> chop m ts) chop :: Set s -> Forest Vertex -> ST s (Forest Vertex) -chop m [] = return [] +chop _ [] = return [] chop m (Node v ts : us) = contains m v >>= \visited -> if visited then @@ -293,9 +307,9 @@ chop m (Node v ts : us) %************************************************************************ -%* * -%* Algorithms -%* * +%* * +%* Algorithms +%* * %************************************************************************ ------------------------------------------------------------ @@ -303,7 +317,7 @@ chop m (Node v ts : us) ------------------------------------------------------------ \begin{code} ---preorder :: Tree a -> [a] +preorder :: Tree a -> [a] preorder (Node a ts) = a : preorderF ts preorderF :: Forest a -> [a] @@ -322,17 +336,17 @@ preArr bnds = tabulate bnds . preorderF ------------------------------------------------------------ \begin{code} ---postorder :: Tree a -> [a] -postorder (Node a ts) = postorderF ts ++ [a] +postorder :: Tree a -> [a] -> [a] +postorder (Node a ts) = postorderF ts . (a :) -postorderF :: Forest a -> [a] -postorderF ts = concat (map postorder ts) +postorderF :: Forest a -> [a] -> [a] +postorderF ts = foldr (.) id $ map postorder ts -postOrd :: Graph -> [Vertex] -postOrd = postorderF . dff +postOrd :: Graph -> [Vertex] +postOrd g = postorderF (dff g) [] -topSort :: Graph -> [Vertex] -topSort = reverse . postOrd +topSort :: Graph -> [Vertex] +topSort = reverse . postOrd \end{code} @@ -403,16 +417,16 @@ do_label :: Graph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int) do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us where us = map (do_label g dnum) ts lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v] - ++ [lu | Node (u,du,lu) xs <- us]) + ++ [lu | Node (_,_,lu) _ <- us]) bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex] -bicomps (Node (v,dv,lv) ts) - = [ Node (v:vs) us | (l,Node vs us) <- map collect ts] +bicomps (Node (v,_,_) ts) + = [ Node (v:vs) us | (_,Node vs us) <- map collect ts] collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex]) collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs) where collected = map collect ts - vs = concat [ ws | (lw, Node ws us) <- collected, lw