X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FDigraph.lhs;h=0eff6da6980e6d87e24d3fb45c506325e61c1ed0;hb=59c796f8e77325d35f29ddd3e724bfa780466d40;hp=3196e6eefeb2d15e0da0b271d334920b06fe7370;hpb=4e7d56fde0f44d38bbb9a6fc72cf9c603264899d;p=ghc-hetmet.git diff --git a/ghc/compiler/utils/Digraph.lhs b/ghc/compiler/utils/Digraph.lhs index 3196e6e..0eff6da 100644 --- a/ghc/compiler/utils/Digraph.lhs +++ b/ghc/compiler/utils/Digraph.lhs @@ -2,7 +2,7 @@ module Digraph( -- At present the only one with a "nice" external interface - stronglyConnComp, stronglyConnCompR, SCC(..), + stronglyConnComp, stronglyConnCompR, SCC(..), flattenSCC, flattenSCCs, Graph, Vertex, graphFromEdges, buildG, transposeG, reverseE, outdegree, indegree, @@ -32,18 +32,22 @@ module Digraph( ------------------------------------------------------------------------------ -#define ARR_ELT (COMMA) +import Util ( sortLe ) -import Util ( sortLt ) - --- GHC extensions -import ST -import MutableArray +-- Extensions +import MONAD_ST -- std interfaces import Maybe import Array import List +import Outputable + +#if __GLASGOW_HASKELL__ >= 504 +import Data.Array.ST hiding ( indices, bounds ) +#else +import ST +#endif \end{code} @@ -57,12 +61,25 @@ import List data SCC vertex = AcyclicSCC vertex | CyclicSCC [vertex] +flattenSCCs :: [SCC a] -> [a] +flattenSCCs = concatMap flattenSCC + +flattenSCC (AcyclicSCC v) = [v] +flattenSCC (CyclicSCC vs) = vs + +instance Outputable a => Outputable (SCC a) where + ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v)) + ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs))) +\end{code} + +\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] + -> [SCC node] -- Returned in topologically sorted order + -- Later components depend on earlier ones, but not vice versa stronglyConnComp edges = map get_node (stronglyConnCompR edges) @@ -77,14 +94,14 @@ stronglyConnCompR => [(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])] + -> [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) = graphFromEdges edges - forest = 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) decode other = CyclicSCC (dec other []) @@ -119,11 +136,7 @@ mapT :: (Vertex -> a -> b) -> Table a -> Table b mapT f t = array (bounds t) [ (,) v (f v (t!v)) | v <- indices t ] buildG :: Bounds -> [Edge] -> Graph -#ifdef REALLY_HASKELL_1_3 buildG bounds edges = accumArray (flip (:)) [] bounds edges -#else -buildG bounds edges = accumArray (flip (:)) [] bounds [(,) k v | (k,v) <- edges] -#endif transposeG :: Graph -> Graph transposeG g = buildG (bounds g) (reverseE g) @@ -150,14 +163,16 @@ graphFromEdges edges where max_v = length edges - 1 bounds = (0,max_v) :: (Vertex, Vertex) - sorted_edges = sortLt lt edges + sorted_edges = let + (_,k1,_) `le` (_,k2,_) = case k1 `compare` k2 of { GT -> False; other -> True } + 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] + key_map = array bounds [(,) v k | (,) v (_, k, _ ) <- edges1] vertex_map = array bounds edges1 - (_,k1,_) `lt` (_,k2,_) = case k1 `compare` k2 of { LT -> True; other -> False } -- key_vertex :: key -> Maybe Vertex -- returns Nothing for non-interesting vertices @@ -203,7 +218,7 @@ drawTree = unlines . draw draw (Node x ts) = grp this (space (length this)) (stLoop ts) where this = s1 ++ x ++ " " - space n = take n (repeat ' ') + space n = replicate n ' ' stLoop [] = [""] stLoop [t] = grp s2 " " (draw t) @@ -225,16 +240,27 @@ draw (Node x ts) = grp this (space (length this)) (stLoop ts) %************************************************************************ \begin{code} -type Set s = MutableArray s Vertex Bool +#if __GLASGOW_HASKELL__ >= 504 +newSTArray :: Ix i => (i,i) -> e -> ST s (STArray s i e) +newSTArray = newArray + +readSTArray :: Ix i => STArray s i e -> i -> ST s e +readSTArray = readArray + +writeSTArray :: Ix i => STArray s i e -> i -> e -> ST s () +writeSTArray = writeArray +#endif + +type Set s = STArray s Vertex Bool mkEmpty :: Bounds -> ST s (Set s) -mkEmpty bnds = newArray bnds False +mkEmpty bnds = newSTArray bnds False contains :: Set s -> Vertex -> ST s Bool -contains m v = readArray m v +contains m v = readSTArray m v include :: Set s -> Vertex -> ST s () -include m v = writeArray m v True +include m v = writeSTArray m v True \end{code} \begin{code} @@ -282,9 +308,6 @@ preorder (Node a ts) = a : preorderF ts preorderF :: Forest a -> [a] preorderF ts = concat (map preorder ts) -preOrd :: Graph -> [Vertex] -preOrd = preorderF . dff - tabulate :: Bounds -> [Vertex] -> Table Int tabulate bnds vs = array bnds (zipWith (,) vs [1..]) @@ -338,12 +361,6 @@ scc g = dfs g (reverse (postOrd (transposeG g))) ------------------------------------------------------------ \begin{code} -tree :: Bounds -> Forest Vertex -> Graph -tree bnds ts = buildG bnds (concat (map flat ts)) - where - flat (Node v rs) = [ (v, w) | Node w us <- ts ] ++ - concat (map flat ts) - back :: Graph -> Table Int -> Graph back g post = mapT select g where select v ws = [ w | w <- ws, post!v < post!w ]