compiler/utils/Digraph.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 %
   4
   5 \begin{code}
   6 {-# OPTIONS_GHC -w #-}
   7 -- The above warning supression flag is a temporary kludge.
   8 -- While working on this module you are encouraged to remove it and fix
   9 -- any warnings in the module. See
  10 --     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
  11 -- for details
  12
  13 module Digraph(
  14
  15         -- At present the only one with a "nice" external interface
  16         stronglyConnComp, stronglyConnCompR, SCC(..), flattenSCC, flattenSCCs,
  17
  18         Graph, Vertex,
  19         graphFromEdges, graphFromEdges',
  20         buildG, transposeG, reverseE, outdegree, indegree,
  21
  22         Tree(..), Forest,
  23         showTree, showForest,
  24
  25         dfs, dff,
  26         topSort,
  27         components,
  28         scc,
  29         back, cross, forward,
  30         reachable, path,
  31         bcc
  32     ) where
  33
  34 # include "HsVersions.h"
  35
  36 ------------------------------------------------------------------------------
  37 -- A version of the graph algorithms described in:
  38 --
  39 -- ``Lazy Depth-First Search and Linear Graph Algorithms in Haskell''
  40 --   by David King and John Launchbury
  41 --
  42 -- Also included is some additional code for printing tree structures ...
  43 ------------------------------------------------------------------------------
  44
  45
  46 import Util        ( sortLe )
  47 import Outputable
  48
  49 -- Extensions
  50 import Control.Monad.ST
  51
  52 -- std interfaces
  53 import Data.Maybe
  54 import Data.Array
  55 import Data.List
  56
  57 #if __GLASGOW_HASKELL__ > 604
  58 import Data.Array.ST
  59 #else
  60 import Data.Array.ST  hiding ( indices, bounds )
  61 #endif
  62 \end{code}
  63
  64
  65 %************************************************************************
  66 %*                                                                      *
  67 %*      External interface
  68 %*                                                                      *
  69 %************************************************************************
  70
  71 \begin{code}
  72 data SCC vertex = AcyclicSCC vertex
  73                 | CyclicSCC  [vertex]
  74
  75 flattenSCCs :: [SCC a] -> [a]
  76 flattenSCCs = concatMap flattenSCC
  77
  78 flattenSCC (AcyclicSCC v) = [v]
  79 flattenSCC (CyclicSCC vs) = vs
  80
  81 instance Outputable a => Outputable (SCC a) where
  82    ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v))
  83    ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs)))
  84 \end{code}
  85
  86 \begin{code}
  87 stronglyConnComp
  88         :: Ord key
  89         => [(node, key, [key])]         -- The graph; its ok for the
  90                                         -- out-list to contain keys which arent
  91                                         -- a vertex key, they are ignored
  92         -> [SCC node]   -- Returned in topologically sorted order
  93                         -- Later components depend on earlier ones, but not vice versa
  94
  95 stronglyConnComp edges
  96   = map get_node (stronglyConnCompR edges)
  97   where
  98     get_node (AcyclicSCC (n, _, _)) = AcyclicSCC n
  99     get_node (CyclicSCC triples)     = CyclicSCC [n | (n,_,_) <- triples]
 100
 101 -- The "R" interface is used when you expect to apply SCC to
 102 -- the (some of) the result of SCC, so you dont want to lose the dependency info
 103 stronglyConnCompR
 104         :: Ord key
 105         => [(node, key, [key])]         -- The graph; its ok for the
 106                                         -- out-list to contain keys which arent
 107                                         -- a vertex key, they are ignored
 108         -> [SCC (node, key, [key])]     -- Topologically sorted
 109
 110 stronglyConnCompR [] = []  -- added to avoid creating empty array in graphFromEdges -- SOF
 111 stronglyConnCompR edges
 112   = map decode forest
 113   where
 114     (graph, vertex_fn) = {-# SCC "graphFromEdges" #-} graphFromEdges edges
 115     forest             = {-# SCC "Digraph.scc" #-} scc graph
 116     decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
 117                        | otherwise         = AcyclicSCC (vertex_fn v)
 118     decode other = CyclicSCC (dec other [])
 119                  where
 120                    dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
 121     mentions_itself v = v `elem` (graph ! v)
 122 \end{code}
 123
 124 %************************************************************************
 125 %*                                                                      *
 126 %*      Graphs
 127 %*                                                                      *
 128 %************************************************************************
 129
 130
 131 \begin{code}
 132 type Vertex  = Int
 133 type Table a = Array Vertex a
 134 type Graph   = Table [Vertex]
 135 type Bounds  = (Vertex, Vertex)
 136 type Edge    = (Vertex, Vertex)
 137 \end{code}
 138
 139 \begin{code}
 140 vertices :: Graph -> [Vertex]
 141 vertices  = indices
 142
 143 edges    :: Graph -> [Edge]
 144 edges g   = [ (v, w) | v <- vertices g, w <- g!v ]
 145
 146 mapT    :: (Vertex -> a -> b) -> Table a -> Table b
 147 mapT f t = array (bounds t) [ (v, f v (t ! v)) | v <- indices t ]
 148
 149 buildG :: Bounds -> [Edge] -> Graph
 150 buildG bounds edges = accumArray (flip (:)) [] bounds edges
 151
 152 transposeG  :: Graph -> Graph
 153 transposeG g = buildG (bounds g) (reverseE g)
 154
 155 reverseE    :: Graph -> [Edge]
 156 reverseE g   = [ (w, v) | (v, w) <- edges g ]
 157
 158 outdegree :: Graph -> Table Int
 159 outdegree  = mapT numEdges
 160              where numEdges v ws = length ws
 161
 162 indegree :: Graph -> Table Int
 163 indegree  = outdegree . transposeG
 164 \end{code}
 165
 166
 167 \begin{code}
 168 graphFromEdges
 169         :: Ord key
 170         => [(node, key, [key])]
 171         -> (Graph, Vertex -> (node, key, [key]))
 172 graphFromEdges edges =
 173   case graphFromEdges' edges of (graph, vertex_fn, _) -> (graph, vertex_fn)
 174
 175 graphFromEdges'
 176         :: Ord key
 177         => [(node, key, [key])]
 178         -> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)
 179 graphFromEdges' edges
 180   = (graph, \v -> vertex_map ! v, key_vertex)
 181   where
 182     max_v           = length edges - 1
 183     bounds          = (0,max_v) :: (Vertex, Vertex)
 184     sorted_edges    = let
 185                          (_,k1,_) `le` (_,k2,_) = case k1 `compare` k2 of { GT -> False; other -> True }
 186                       in
 187                         sortLe le edges
 188     edges1          = zipWith (,) [0..] sorted_edges
 189
 190     graph           = array bounds [ (v, mapMaybe key_vertex ks)
 191                                | (v, (_,    _, ks)) <- edges1]
 192     key_map         = array bounds [ (v, k)
 193                                | (v, (_,    k, _ )) <- edges1]
 194     vertex_map      = array bounds edges1
 195
 196
 197     -- key_vertex :: key -> Maybe Vertex
 198     --  returns Nothing for non-interesting vertices
 199     key_vertex k   = find 0 max_v
 200                    where
 201                      find a b | a > b
 202                               = Nothing
 203                      find a b = case compare k (key_map ! mid) of
 204                                    LT -> find a (mid-1)
 205                                    EQ -> Just mid
 206                                    GT -> find (mid+1) b
 207                               where
 208                                 mid = (a + b) `div` 2
 209 \end{code}
 210
 211 %************************************************************************
 212 %*                                                                      *
 213 %*      Trees and forests
 214 %*                                                                      *
 215 %************************************************************************
 216
 217 \begin{code}
 218 data Tree a   = Node a (Forest a)
 219 type Forest a = [Tree a]
 220
 221 mapTree              :: (a -> b) -> (Tree a -> Tree b)
 222 mapTree f (Node x ts) = Node (f x) (map (mapTree f) ts)
 223 \end{code}
 224
 225 \begin{code}
 226 instance Show a => Show (Tree a) where
 227   showsPrec p t s = showTree t ++ s
 228
 229 showTree :: Show a => Tree a -> String
 230 showTree  = drawTree . mapTree show
 231
 232 showForest :: Show a => Forest a -> String
 233 showForest  = unlines . map showTree
 234
 235 drawTree        :: Tree String -> String
 236 drawTree         = unlines . draw
 237
 238 draw (Node x ts) = grp this (space (length this)) (stLoop ts)
 239  where this          = s1 ++ x ++ " "
 240
 241        space n       = replicate n ' '
 242
 243        stLoop []     = [""]
 244        stLoop [t]    = grp s2 "  " (draw t)
 245        stLoop (t:ts) = grp s3 s4 (draw t) ++ [s4] ++ rsLoop ts
 246
 247        rsLoop [t]    = grp s5 "  " (draw t)
 248        rsLoop (t:ts) = grp s6 s4 (draw t) ++ [s4] ++ rsLoop ts
 249
 250        grp fst rst   = zipWith (++) (fst:repeat rst)
 251
 252        [s1,s2,s3,s4,s5,s6] = ["- ", "--", "-+", " |", " `", " +"]
 253 \end{code}
 254
 255
 256 %************************************************************************
 257 %*                                                                      *
 258 %*      Depth first search
 259 %*                                                                      *
 260 %************************************************************************
 261
 262 \begin{code}
 263 type Set s    = STArray s Vertex Bool
 264
 265 mkEmpty      :: Bounds -> ST s (Set s)
 266 mkEmpty bnds  = newArray bnds False
 267
 268 contains     :: Set s -> Vertex -> ST s Bool
 269 contains m v  = readArray m v
 270
 271 include      :: Set s -> Vertex -> ST s ()
 272 include m v   = writeArray m v True
 273 \end{code}
 274
 275 \begin{code}
 276 dff          :: Graph -> Forest Vertex
 277 dff g         = dfs g (vertices g)
 278
 279 dfs          :: Graph -> [Vertex] -> Forest Vertex
 280 dfs g vs      = prune (bounds g) (map (generate g) vs)
 281
 282 generate     :: Graph -> Vertex -> Tree Vertex
 283 generate g v  = Node v (map (generate g) (g!v))
 284
 285 prune        :: Bounds -> Forest Vertex -> Forest Vertex
 286 prune bnds ts = runST (mkEmpty bnds  >>= \m ->
 287                        chop m ts)
 288
 289 chop         :: Set s -> Forest Vertex -> ST s (Forest Vertex)
 290 chop m []     = return []
 291 chop m (Node v ts : us)
 292               = contains m v >>= \visited ->
 293                 if visited then
 294                   chop m us
 295                 else
 296                   include m v >>= \_  ->
 297                   chop m ts   >>= \as ->
 298                   chop m us   >>= \bs ->
 299                   return (Node v as : bs)
 300 \end{code}
 301
 302
 303 %************************************************************************
 304 %*                                                                      *
 305 %*      Algorithms
 306 %*                                                                      *
 307 %************************************************************************
 308
 309 ------------------------------------------------------------
 310 -- Algorithm 1: depth first search numbering
 311 ------------------------------------------------------------
 312
 313 \begin{code}
 314 --preorder            :: Tree a -> [a]
 315 preorder (Node a ts) = a : preorderF ts
 316
 317 preorderF           :: Forest a -> [a]
 318 preorderF ts         = concat (map preorder ts)
 319
 320 tabulate        :: Bounds -> [Vertex] -> Table Int
 321 tabulate bnds vs = array bnds (zipWith (,) vs [1..])
 322
 323 preArr          :: Bounds -> Forest Vertex -> Table Int
 324 preArr bnds      = tabulate bnds . preorderF
 325 \end{code}
 326
 327
 328 ------------------------------------------------------------
 329 -- Algorithm 2: topological sorting
 330 ------------------------------------------------------------
 331
 332 \begin{code}
 333 postorder :: Tree a -> [a] -> [a]
 334 postorder (Node a ts) = postorderF ts . (a :)
 335
 336 postorderF   :: Forest a -> [a] -> [a]
 337 postorderF ts = foldr (.) id $ map postorder ts
 338
 339 postOrd :: Graph -> [Vertex]
 340 postOrd g = postorderF (dff g) []
 341
 342 topSort :: Graph -> [Vertex]
 343 topSort = reverse . postOrd
 344 \end{code}
 345
 346
 347 ------------------------------------------------------------
 348 -- Algorithm 3: connected components
 349 ------------------------------------------------------------
 350
 351 \begin{code}
 352 components   :: Graph -> Forest Vertex
 353 components    = dff . undirected
 354
 355 undirected   :: Graph -> Graph
 356 undirected g  = buildG (bounds g) (edges g ++ reverseE g)
 357 \end{code}
 358
 359
 360 -- Algorithm 4: strongly connected components
 361
 362 \begin{code}
 363 scc  :: Graph -> Forest Vertex
 364 scc g = dfs g (reverse (postOrd (transposeG g)))
 365 \end{code}
 366
 367
 368 ------------------------------------------------------------
 369 -- Algorithm 5: Classifying edges
 370 ------------------------------------------------------------
 371
 372 \begin{code}
 373 back              :: Graph -> Table Int -> Graph
 374 back g post        = mapT select g
 375  where select v ws = [ w | w <- ws, post!v < post!w ]
 376
 377 cross             :: Graph -> Table Int -> Table Int -> Graph
 378 cross g pre post   = mapT select g
 379  where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ]
 380
 381 forward           :: Graph -> Graph -> Table Int -> Graph
 382 forward g tree pre = mapT select g
 383  where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree!v
 384 \end{code}
 385
 386
 387 ------------------------------------------------------------
 388 -- Algorithm 6: Finding reachable vertices
 389 ------------------------------------------------------------
 390
 391 \begin{code}
 392 reachable    :: Graph -> Vertex -> [Vertex]
 393 reachable g v = preorderF (dfs g [v])
 394
 395 path         :: Graph -> Vertex -> Vertex -> Bool
 396 path g v w    = w `elem` (reachable g v)
 397 \end{code}
 398
 399
 400 ------------------------------------------------------------
 401 -- Algorithm 7: Biconnected components
 402 ------------------------------------------------------------
 403
 404 \begin{code}
 405 bcc :: Graph -> Forest [Vertex]
 406 bcc g = (concat . map bicomps . map (do_label g dnum)) forest
 407  where forest = dff g
 408        dnum   = preArr (bounds g) forest
 409
 410 do_label :: Graph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int)
 411 do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us
 412  where us = map (do_label g dnum) ts
 413        lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v]
 414                      ++ [lu | Node (u,du,lu) xs <- us])
 415
 416 bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex]
 417 bicomps (Node (v,dv,lv) ts)
 418       = [ Node (v:vs) us | (l,Node vs us) <- map collect ts]
 419
 420 collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex])
 421 collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs)
 422  where collected = map collect ts
 423        vs = concat [ ws | (lw, Node ws us) <- collected, lw<dv]
 424        cs = concat [ if lw<dv then us else [Node (v:ws) us]
 425                         | (lw, Node ws us) <- collected ]
 426 \end{code}
 427