compiler/utils/Digraph.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 %
   4
   5 \begin{code}
   6 module Digraph(
   7         Graph, graphFromVerticesAndAdjacency, graphFromEdgedVertices,
   8
   9         SCC(..), flattenSCC, flattenSCCs,
  10         stronglyConnCompG, topologicalSortG,
  11         verticesG, edgesG, hasVertexG,
  12         reachableG, transposeG,
  13         outdegreeG, indegreeG,
  14         vertexGroupsG, emptyG,
  15         componentsG,
  16
  17         -- For backwards compatability with the simpler version of Digraph
  18         stronglyConnCompFromEdgedVertices, stronglyConnCompFromEdgedVerticesR,
  19
  20         -- No friendly interface yet, not used but exported to avoid warnings
  21         tabulate, preArr,
  22         components, undirected,
  23         back, cross, forward,
  24         path,
  25         bcc, do_label, bicomps, collect
  26     ) where
  27
  28 #include "HsVersions.h"
  29
  30 ------------------------------------------------------------------------------
  31 -- A version of the graph algorithms described in:
  32 --
  33 -- ``Lazy Depth-First Search and Linear IntGraph Algorithms in Haskell''
  34 --   by David King and John Launchbury
  35 --
  36 -- Also included is some additional code for printing tree structures ...
  37 ------------------------------------------------------------------------------
  38
  39
  40 import Util        ( sortLe )
  41 import Outputable
  42 import Maybes      ( expectJust )
  43 import MonadUtils  ( allM )
  44
  45 -- Extensions
  46 import Control.Monad    ( filterM, liftM, liftM2 )
  47 import Control.Monad.ST
  48
  49 -- std interfaces
  50 import Data.Maybe
  51 import Data.Array
  52 import Data.List   ( (\\) )
  53 import Data.Array.ST
  54 \end{code}
  55
  56 %************************************************************************
  57 %*                                                                      *
  58 %*      Graphs and Graph Construction
  59 %*                                                                      *
  60 %************************************************************************
  61
  62 Note [Nodes, keys, vertices]
  63 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  64  * A 'node' is a big blob of client-stuff
  65
  66  * Each 'node' has a unique (client) 'key', but the latter
  67         is in Ord and has fast comparison
  68
  69  * Digraph then maps each 'key' to a Vertex (Int) which is
  70         arranged densely in 0.n
  71
  72 \begin{code}
  73 data Graph node = Graph {
  74     gr_int_graph      :: IntGraph,
  75     gr_vertex_to_node :: Vertex -> node,
  76     gr_node_to_vertex :: node -> Maybe Vertex
  77   }
  78
  79 data Edge node = Edge node node
  80
  81 emptyGraph :: Graph a
  82 emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing)
  83
  84 graphFromVerticesAndAdjacency
  85         :: Ord key
  86         => [(node, key)]
  87         -> [(key, key)]  -- First component is source vertex key,
  88                          -- second is target vertex key (thing depended on)
  89                          -- Unlike the other interface I insist they correspond to
  90                          -- actual vertices because the alternative hides bugs. I can't
  91                          -- do the same thing for the other one for backcompat reasons.
  92         -> Graph (node, key)
  93 graphFromVerticesAndAdjacency []       _     = emptyGraph
  94 graphFromVerticesAndAdjacency vertices edges = Graph graph vertex_node (key_vertex . key_extractor)
  95   where key_extractor = snd
  96         (bounds, vertex_node, key_vertex, _) = reduceNodesIntoVertices vertices key_extractor
  97         key_vertex_pair (a, b) = (expectJust "graphFromVerticesAndAdjacency" $ key_vertex a,
  98                                   expectJust "graphFromVerticesAndAdjacency" $ key_vertex b)
  99         reduced_edges = map key_vertex_pair edges
 100         graph = buildG bounds reduced_edges
 101
 102 graphFromEdgedVertices
 103         :: Ord key
 104         => [(node, key, [key])]         -- The graph; its ok for the
 105                                         -- out-list to contain keys which arent
 106                                         -- a vertex key, they are ignored
 107         -> Graph (node, key, [key])
 108 graphFromEdgedVertices []             = emptyGraph
 109 graphFromEdgedVertices edged_vertices = Graph graph vertex_fn (key_vertex . key_extractor)
 110   where key_extractor (_, k, _) = k
 111         (bounds, vertex_fn, key_vertex, numbered_nodes) = reduceNodesIntoVertices edged_vertices key_extractor
 112         graph = array bounds [(v, mapMaybe key_vertex ks) | (v, (_, _, ks)) <- numbered_nodes]
 113
 114 reduceNodesIntoVertices
 115         :: Ord key
 116         => [node]
 117         -> (node -> key)
 118         -> (Bounds, Vertex -> node, key -> Maybe Vertex, [(Int, node)])
 119 reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_vertex, numbered_nodes)
 120   where
 121     max_v           = length nodes - 1
 122     bounds          = (0, max_v) :: (Vertex, Vertex)
 123
 124     sorted_nodes    = let n1 `le` n2 = (key_extractor n1 `compare` key_extractor n2) /= GT
 125                       in sortLe le nodes
 126     numbered_nodes  = zipWith (,) [0..] sorted_nodes
 127
 128     key_map         = array bounds [(i, key_extractor node) | (i, node) <- numbered_nodes]
 129     vertex_map      = array bounds numbered_nodes
 130
 131     --key_vertex :: key -> Maybe Vertex
 132     -- returns Nothing for non-interesting vertices
 133     key_vertex k = find 0 max_v
 134       where
 135         find a b | a > b = Nothing
 136                  | otherwise = let mid = (a + b) `div` 2
 137                                in case compare k (key_map ! mid) of
 138                                     LT -> find a (mid - 1)
 139                                     EQ -> Just mid
 140                                     GT -> find (mid + 1) b
 141 \end{code}
 142
 143 %************************************************************************
 144 %*                                                                      *
 145 %*      SCC
 146 %*                                                                      *
 147 %************************************************************************
 148
 149 \begin{code}
 150 data SCC vertex = AcyclicSCC vertex
 151                 | CyclicSCC  [vertex]
 152
 153 instance Functor SCC where
 154     fmap f (AcyclicSCC v) = AcyclicSCC (f v)
 155     fmap f (CyclicSCC vs) = CyclicSCC (fmap f vs)
 156
 157 flattenSCCs :: [SCC a] -> [a]
 158 flattenSCCs = concatMap flattenSCC
 159
 160 flattenSCC :: SCC a -> [a]
 161 flattenSCC (AcyclicSCC v) = [v]
 162 flattenSCC (CyclicSCC vs) = vs
 163
 164 instance Outputable a => Outputable (SCC a) where
 165    ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v))
 166    ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs)))
 167 \end{code}
 168
 169 %************************************************************************
 170 %*                                                                      *
 171 %*      Strongly Connected Component wrappers for Graph
 172 %*                                                                      *
 173 %************************************************************************
 174
 175 Note: the components are returned topologically sorted: later components
 176 depend on earlier ones, but not vice versa i.e. later components only have
 177 edges going from them to earlier ones.
 178
 179 \begin{code}
 180 stronglyConnCompG :: Graph node -> [SCC node]
 181 stronglyConnCompG (Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn }) = map decode forest
 182   where
 183     forest             = {-# SCC "Digraph.scc" #-} scc graph
 184     decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
 185                        | otherwise         = AcyclicSCC (vertex_fn v)
 186     decode other = CyclicSCC (dec other [])
 187       where dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
 188     mentions_itself v = v `elem` (graph ! v)
 189
 190
 191 -- The following two versions are provided for backwards compatability:
 192 stronglyConnCompFromEdgedVertices
 193         :: Ord key
 194         => [(node, key, [key])]
 195         -> [SCC node]
 196 stronglyConnCompFromEdgedVertices = map (fmap get_node) . stronglyConnCompFromEdgedVerticesR
 197   where get_node (n, _, _) = n
 198
 199 -- The "R" interface is used when you expect to apply SCC to
 200 -- the (some of) the result of SCC, so you dont want to lose the dependency info
 201 stronglyConnCompFromEdgedVerticesR
 202         :: Ord key
 203         => [(node, key, [key])]
 204         -> [SCC (node, key, [key])]
 205 stronglyConnCompFromEdgedVerticesR = stronglyConnCompG . graphFromEdgedVertices
 206 \end{code}
 207
 208 %************************************************************************
 209 %*                                                                      *
 210 %*      Misc wrappers for Graph
 211 %*                                                                      *
 212 %************************************************************************
 213
 214 \begin{code}
 215 topologicalSortG :: Graph node -> [node]
 216 topologicalSortG graph = map (gr_vertex_to_node graph) result
 217   where result = {-# SCC "Digraph.topSort" #-} topSort (gr_int_graph graph)
 218
 219 reachableG :: Graph node -> node -> [node]
 220 reachableG graph from = map (gr_vertex_to_node graph) result
 221   where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from)
 222         result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) from_vertex
 223
 224 hasVertexG :: Graph node -> node -> Bool
 225 hasVertexG graph node = isJust $ gr_node_to_vertex graph node
 226
 227 verticesG :: Graph node -> [node]
 228 verticesG graph = map (gr_vertex_to_node graph) $ vertices (gr_int_graph graph)
 229
 230 edgesG :: Graph node -> [Edge node]
 231 edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ edges (gr_int_graph graph)
 232   where v2n = gr_vertex_to_node graph
 233
 234 transposeG :: Graph node -> Graph node
 235 transposeG graph = Graph (transpose (gr_int_graph graph)) (gr_vertex_to_node graph) (gr_node_to_vertex graph)
 236
 237 outdegreeG :: Graph node -> node -> Maybe Int
 238 outdegreeG = degreeG outdegree
 239
 240 indegreeG :: Graph node -> node -> Maybe Int
 241 indegreeG = degreeG indegree
 242
 243 degreeG :: (IntGraph -> Table Int) -> Graph node -> node -> Maybe Int
 244 degreeG degree graph node = let table = degree (gr_int_graph graph)
 245                             in fmap ((!) table) $ gr_node_to_vertex graph node
 246
 247 vertexGroupsG :: Graph node -> [[node]]
 248 vertexGroupsG graph = map (map (gr_vertex_to_node graph)) result
 249   where result = vertexGroups (gr_int_graph graph)
 250
 251 emptyG :: Graph node -> Bool
 252 emptyG g = graphEmpty (gr_int_graph g)
 253
 254 componentsG :: Graph node -> [[node]]
 255 componentsG graph = map (map (gr_vertex_to_node graph) . flattenTree) $ components (gr_int_graph graph)
 256 \end{code}
 257
 258 %************************************************************************
 259 %*                                                                      *
 260 %*      Showing Graphs
 261 %*                                                                      *
 262 %************************************************************************
 263
 264 \begin{code}
 265
 266 instance Outputable node => Outputable (Graph node) where
 267     ppr graph = vcat [
 268                   hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)),
 269                   hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph))
 270                 ]
 271
 272 instance Outputable node => Outputable (Edge node) where
 273     ppr (Edge from to) = ppr from <+> text "->" <+> ppr to
 274
 275 \end{code}
 276
 277 %************************************************************************
 278 %*                                                                      *
 279 %*      IntGraphs
 280 %*                                                                      *
 281 %************************************************************************
 282
 283 \begin{code}
 284 type Vertex  = Int
 285 type Table a = Array Vertex a
 286 type IntGraph   = Table [Vertex]
 287 type Bounds  = (Vertex, Vertex)
 288 type IntEdge    = (Vertex, Vertex)
 289 \end{code}
 290
 291 \begin{code}
 292 vertices :: IntGraph -> [Vertex]
 293 vertices  = indices
 294
 295 edges    :: IntGraph -> [IntEdge]
 296 edges g   = [ (v, w) | v <- vertices g, w <- g!v ]
 297
 298 mapT    :: (Vertex -> a -> b) -> Table a -> Table b
 299 mapT f t = array (bounds t) [ (v, f v (t ! v)) | v <- indices t ]
 300
 301 buildG :: Bounds -> [IntEdge] -> IntGraph
 302 buildG bounds edges = accumArray (flip (:)) [] bounds edges
 303
 304 transpose  :: IntGraph -> IntGraph
 305 transpose g = buildG (bounds g) (reverseE g)
 306
 307 reverseE    :: IntGraph -> [IntEdge]
 308 reverseE g   = [ (w, v) | (v, w) <- edges g ]
 309
 310 outdegree :: IntGraph -> Table Int
 311 outdegree  = mapT numEdges
 312              where numEdges _ ws = length ws
 313
 314 indegree :: IntGraph -> Table Int
 315 indegree  = outdegree . transpose
 316
 317 graphEmpty :: IntGraph -> Bool
 318 graphEmpty g = lo > hi
 319   where (lo, hi) = bounds g
 320
 321 \end{code}
 322
 323 %************************************************************************
 324 %*                                                                      *
 325 %*      Trees and forests
 326 %*                                                                      *
 327 %************************************************************************
 328
 329 \begin{code}
 330 data Tree a   = Node a (Forest a)
 331 type Forest a = [Tree a]
 332
 333 mapTree              :: (a -> b) -> (Tree a -> Tree b)
 334 mapTree f (Node x ts) = Node (f x) (map (mapTree f) ts)
 335
 336 flattenTree :: Tree a -> [a]
 337 flattenTree (Node x ts) = x : concatMap flattenTree ts
 338 \end{code}
 339
 340 \begin{code}
 341 instance Show a => Show (Tree a) where
 342   showsPrec _ t s = showTree t ++ s
 343
 344 showTree :: Show a => Tree a -> String
 345 showTree  = drawTree . mapTree show
 346
 347 instance Show a => Show (Forest a) where
 348   showsPrec _ f s = showForest f ++ s
 349
 350 showForest :: Show a => Forest a -> String
 351 showForest  = unlines . map showTree
 352
 353 drawTree        :: Tree String -> String
 354 drawTree         = unlines . draw
 355
 356 draw :: Tree String -> [String]
 357 draw (Node x ts) = grp this (space (length this)) (stLoop ts)
 358  where this          = s1 ++ x ++ " "
 359
 360        space n       = replicate n ' '
 361
 362        stLoop []     = [""]
 363        stLoop [t]    = grp s2 "  " (draw t)
 364        stLoop (t:ts) = grp s3 s4 (draw t) ++ [s4] ++ rsLoop ts
 365
 366        rsLoop []     = []
 367        rsLoop [t]    = grp s5 "  " (draw t)
 368        rsLoop (t:ts) = grp s6 s4 (draw t) ++ [s4] ++ rsLoop ts
 369
 370        grp fst rst   = zipWith (++) (fst:repeat rst)
 371
 372        [s1,s2,s3,s4,s5,s6] = ["- ", "--", "-+", " |", " `", " +"]
 373 \end{code}
 374
 375
 376 %************************************************************************
 377 %*                                                                      *
 378 %*      Depth first search
 379 %*                                                                      *
 380 %************************************************************************
 381
 382 \begin{code}
 383 type Set s    = STArray s Vertex Bool
 384
 385 mkEmpty      :: Bounds -> ST s (Set s)
 386 mkEmpty bnds  = newArray bnds False
 387
 388 contains     :: Set s -> Vertex -> ST s Bool
 389 contains m v  = readArray m v
 390
 391 include      :: Set s -> Vertex -> ST s ()
 392 include m v   = writeArray m v True
 393 \end{code}
 394
 395 \begin{code}
 396 dff          :: IntGraph -> Forest Vertex
 397 dff g         = dfs g (vertices g)
 398
 399 dfs          :: IntGraph -> [Vertex] -> Forest Vertex
 400 dfs g vs      = prune (bounds g) (map (generate g) vs)
 401
 402 generate     :: IntGraph -> Vertex -> Tree Vertex
 403 generate g v  = Node v (map (generate g) (g!v))
 404
 405 prune        :: Bounds -> Forest Vertex -> Forest Vertex
 406 prune bnds ts = runST (mkEmpty bnds  >>= \m ->
 407                        chop m ts)
 408
 409 chop         :: Set s -> Forest Vertex -> ST s (Forest Vertex)
 410 chop _ []     = return []
 411 chop m (Node v ts : us)
 412               = contains m v >>= \visited ->
 413                 if visited then
 414                   chop m us
 415                 else
 416                   include m v >>= \_  ->
 417                   chop m ts   >>= \as ->
 418                   chop m us   >>= \bs ->
 419                   return (Node v as : bs)
 420 \end{code}
 421
 422
 423 %************************************************************************
 424 %*                                                                      *
 425 %*      Algorithms
 426 %*                                                                      *
 427 %************************************************************************
 428
 429 ------------------------------------------------------------
 430 -- Algorithm 1: depth first search numbering
 431 ------------------------------------------------------------
 432
 433 \begin{code}
 434 preorder            :: Tree a -> [a]
 435 preorder (Node a ts) = a : preorderF ts
 436
 437 preorderF           :: Forest a -> [a]
 438 preorderF ts         = concat (map preorder ts)
 439
 440 tabulate        :: Bounds -> [Vertex] -> Table Int
 441 tabulate bnds vs = array bnds (zip vs [1..])
 442
 443 preArr          :: Bounds -> Forest Vertex -> Table Int
 444 preArr bnds      = tabulate bnds . preorderF
 445 \end{code}
 446
 447 ------------------------------------------------------------
 448 -- Algorithm 2: topological sorting
 449 ------------------------------------------------------------
 450
 451 \begin{code}
 452 postorder :: Tree a -> [a] -> [a]
 453 postorder (Node a ts) = postorderF ts . (a :)
 454
 455 postorderF   :: Forest a -> [a] -> [a]
 456 postorderF ts = foldr (.) id $ map postorder ts
 457
 458 postOrd :: IntGraph -> [Vertex]
 459 postOrd g = postorderF (dff g) []
 460
 461 topSort :: IntGraph -> [Vertex]
 462 topSort = reverse . postOrd
 463 \end{code}
 464
 465 ------------------------------------------------------------
 466 -- Algorithm 3: connected components
 467 ------------------------------------------------------------
 468
 469 \begin{code}
 470 components   :: IntGraph -> Forest Vertex
 471 components    = dff . undirected
 472
 473 undirected   :: IntGraph -> IntGraph
 474 undirected g  = buildG (bounds g) (edges g ++ reverseE g)
 475 \end{code}
 476
 477 ------------------------------------------------------------
 478 -- Algorithm 4: strongly connected components
 479 ------------------------------------------------------------
 480
 481 \begin{code}
 482 scc  :: IntGraph -> Forest Vertex
 483 scc g = dfs g (reverse (postOrd (transpose g)))
 484 \end{code}
 485
 486 ------------------------------------------------------------
 487 -- Algorithm 5: Classifying edges
 488 ------------------------------------------------------------
 489
 490 \begin{code}
 491 back              :: IntGraph -> Table Int -> IntGraph
 492 back g post        = mapT select g
 493  where select v ws = [ w | w <- ws, post!v < post!w ]
 494
 495 cross             :: IntGraph -> Table Int -> Table Int -> IntGraph
 496 cross g pre post   = mapT select g
 497  where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ]
 498
 499 forward           :: IntGraph -> IntGraph -> Table Int -> IntGraph
 500 forward g tree pre = mapT select g
 501  where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree!v
 502 \end{code}
 503
 504 ------------------------------------------------------------
 505 -- Algorithm 6: Finding reachable vertices
 506 ------------------------------------------------------------
 507
 508 \begin{code}
 509 reachable    :: IntGraph -> Vertex -> [Vertex]
 510 reachable g v = preorderF (dfs g [v])
 511
 512 path         :: IntGraph -> Vertex -> Vertex -> Bool
 513 path g v w    = w `elem` (reachable g v)
 514 \end{code}
 515
 516 ------------------------------------------------------------
 517 -- Algorithm 7: Biconnected components
 518 ------------------------------------------------------------
 519
 520 \begin{code}
 521 bcc :: IntGraph -> Forest [Vertex]
 522 bcc g = (concat . map bicomps . map (do_label g dnum)) forest
 523  where forest = dff g
 524        dnum   = preArr (bounds g) forest
 525
 526 do_label :: IntGraph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int)
 527 do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us
 528  where us = map (do_label g dnum) ts
 529        lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v]
 530                      ++ [lu | Node (_,_,lu) _ <- us])
 531
 532 bicomps :: Tree (Vertex, Int, Int) -> Forest [Vertex]
 533 bicomps (Node (v,_,_) ts)
 534       = [ Node (v:vs) us | (_,Node vs us) <- map collect ts]
 535
 536 collect :: Tree (Vertex, Int, Int) -> (Int, Tree [Vertex])
 537 collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs)
 538  where collected = map collect ts
 539        vs = concat [ ws | (lw, Node ws _)  <- collected, lw<dv]
 540        cs = concat [ if lw<dv then us else [Node (v:ws) us]
 541                         | (lw, Node ws us) <- collected ]
 542 \end{code}
 543
 544 ------------------------------------------------------------
 545 -- Algorithm 8: Total ordering on groups of vertices
 546 ------------------------------------------------------------
 547
 548 The plan here is to extract a list of groups of elements of the graph
 549 such that each group has no dependence except on nodes in previous
 550 groups (i.e. in particular they may not depend on nodes in their own
 551 group) and is maximal such group.
 552
 553 Clearly we cannot provide a solution for cyclic graphs.
 554
 555 We proceed by iteratively removing elements with no outgoing edges
 556 and their associated edges from the graph.
 557
 558 This probably isn't very efficient and certainly isn't very clever.
 559
 560 \begin{code}
 561
 562 vertexGroups :: IntGraph -> [[Vertex]]
 563 vertexGroups g = runST (mkEmpty (bounds g) >>= \provided -> vertexGroupsS provided g next_vertices)
 564   where next_vertices = noOutEdges g
 565
 566 noOutEdges :: IntGraph -> [Vertex]
 567 noOutEdges g = [ v | v <- vertices g, null (g!v)]
 568
 569 vertexGroupsS :: Set s -> IntGraph -> [Vertex] -> ST s [[Vertex]]
 570 vertexGroupsS provided g to_provide
 571   = if null to_provide
 572     then do {
 573           all_provided <- allM (provided `contains`) (vertices g)
 574         ; if all_provided
 575           then return []
 576           else error "vertexGroup: cyclic graph"
 577         }
 578     else do {
 579           mapM_ (include provided) to_provide
 580         ; to_provide' <- filterM (vertexReady provided g) (vertices g)
 581         ; rest <- vertexGroupsS provided g to_provide'
 582         ; return $ to_provide : rest
 583         }
 584
 585 vertexReady :: Set s -> IntGraph -> Vertex -> ST s Bool
 586 vertexReady provided g v = liftM2 (&&) (liftM not $ provided `contains` v) (allM (provided `contains`) (g!v))
 587 \end{code}