X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FDigraph.lhs;h=c36e7058fc9c9da8c0fb8cfe41875b0b6ebe08dd;hb=b56fa72c006e7dfd850729cb8dd28552bc4e041e;hp=958769c12ac2144524634c271434e439bc1d79b7;hpb=6378e8dbc2b3401e951ad1d0d6b9f450c31f9a05;p=ghc-hetmet.git diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs index 958769c..c36e705 100644 --- a/compiler/utils/Digraph.lhs +++ b/compiler/utils/Digraph.lhs @@ -24,7 +24,9 @@ module Digraph( bcc ) where -# include "HsVersions.h" +-- XXX This define is a bit of a hack, and should be done more nicely +#define FAST_STRING_NOT_NEEDED 1 +#include "HsVersions.h" ------------------------------------------------------------------------------ -- A version of the graph algorithms described in: @@ -47,7 +49,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 ) @@ -68,6 +70,7 @@ data SCC vertex = AcyclicSCC vertex flattenSCCs :: [SCC a] -> [a] flattenSCCs = concatMap flattenSCC +flattenSCC :: SCC a -> [a] flattenSCC (AcyclicSCC v) = [v] flattenSCC (CyclicSCC vs) = vs @@ -76,6 +79,16 @@ 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 @@ -104,8 +117,8 @@ stronglyConnCompR [] = [] -- added to avoid creating empty array in graphFromEd 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) decode other = CyclicSCC (dec other []) @@ -150,7 +163,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 @@ -175,7 +188,7 @@ graphFromEdges' edges 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 } + (_,k1,_) `le` (_,k2,_) = (k1 `compare` k2) /= GT in sortLe le edges edges1 = zipWith (,) [0..] sorted_edges @@ -217,7 +230,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 @@ -228,6 +241,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 ++ " " @@ -237,6 +251,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 @@ -280,7 +295,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 @@ -304,7 +319,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] @@ -323,17 +338,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} @@ -404,16 +419,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