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