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