Digraph.hs 19.5 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
-- (c) The University of Glasgow 2006
Simon Marlow's avatar
Simon Marlow committed
2

3
{-# LANGUAGE CPP, ScopedTypeVariables, ViewPatterns #-}
4
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5

sof's avatar
sof committed
6
module Digraph(
niteria's avatar
niteria committed
7
        Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq,
8

9
        SCC(..), Node(..), flattenSCC, flattenSCCs,
10
        stronglyConnCompG,
11
        topologicalSortG,
12
        verticesG, edgesG, hasVertexG,
13
        reachableG, reachablesG, transposeG,
14
        emptyG,
15

16
        findCycle,
17

18
        -- For backwards compatibility with the simpler version of Digraph
niteria's avatar
niteria committed
19 20 21 22
        stronglyConnCompFromEdgedVerticesOrd,
        stronglyConnCompFromEdgedVerticesOrdR,
        stronglyConnCompFromEdgedVerticesUniq,
        stronglyConnCompFromEdgedVerticesUniqR,
23 24 25

        -- Simple way to classify edges
        EdgeType(..), classifyEdges
26 27
    ) where

twanvl's avatar
twanvl committed
28
#include "HsVersions.h"
29

sof's avatar
sof committed
30 31
------------------------------------------------------------------------------
-- A version of the graph algorithms described in:
Ian Lynagh's avatar
Ian Lynagh committed
32
--
33
-- ``Lazy Depth-First Search and Linear IntGraph Algorithms in Haskell''
sof's avatar
sof committed
34
--   by David King and John Launchbury
Ian Lynagh's avatar
Ian Lynagh committed
35
--
sof's avatar
sof committed
36
-- Also included is some additional code for printing tree structures ...
37 38 39 40 41
--
-- If you ever find yourself in need of algorithms for classifying edges,
-- or finding connected/biconnected components, consult the history; Sigbjorn
-- Finne contributed some implementations in 1997, although we've since
-- removed them since they were not used anywhere in GHC.
sof's avatar
sof committed
42 43 44
------------------------------------------------------------------------------


45 46
import GhcPrelude

Ian Lynagh's avatar
Ian Lynagh committed
47
import Util        ( minWith, count )
Simon Marlow's avatar
Simon Marlow committed
48
import Outputable
49
import Maybes      ( expectJust )
50 51

-- std interfaces
Simon Marlow's avatar
Simon Marlow committed
52 53
import Data.Maybe
import Data.Array
Ian Lynagh's avatar
Ian Lynagh committed
54
import Data.List hiding (transpose)
55 56
import qualified Data.Map as Map
import qualified Data.Set as Set
57

58 59 60
import qualified Data.Graph as G
import Data.Graph hiding (Graph, Edge, transposeG, reachable)
import Data.Tree
niteria's avatar
niteria committed
61 62
import Unique
import UniqFM
63

Austin Seipp's avatar
Austin Seipp committed
64 65 66 67 68 69
{-
************************************************************************
*                                                                      *
*      Graphs and Graph Construction
*                                                                      *
************************************************************************
70 71 72 73 74

Note [Nodes, keys, vertices]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 * A 'node' is a big blob of client-stuff

75 76
 * Each 'node' has a unique (client) 'key', but the latter
        is in Ord and has fast comparison
77 78

 * Digraph then maps each 'key' to a Vertex (Int) which is
79
        arranged densely in 0.n
Austin Seipp's avatar
Austin Seipp committed
80
-}
81

82
data Graph node = Graph {
83
    gr_int_graph      :: IntGraph,
84 85 86 87 88 89
    gr_vertex_to_node :: Vertex -> node,
    gr_node_to_vertex :: node -> Maybe Vertex
  }

data Edge node = Edge node node

90 91 92 93 94 95 96 97 98 99 100
{-| Representation for nodes of the Graph.

 * The @payload@ is user data, just carried around in this module

 * The @key@ is the node identifier.
   Key has an Ord instance for performance reasons.

 * The @[key]@ are the dependencies of the node;
   it's ok to have extra keys in the dependencies that
   are not the key of any Node in the graph
-}
101
data Node key payload = DigraphNode {
102 103 104 105 106
      node_payload :: payload, -- ^ User data
      node_key :: key, -- ^ User defined node id
      node_dependencies :: [key] -- ^ Dependencies/successors of the node
  }

107

108 109 110
instance (Outputable a, Outputable b) => Outputable (Node  a b) where
  ppr (DigraphNode a b c) = ppr (a, b, c)

111 112 113
emptyGraph :: Graph a
emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing)

niteria's avatar
niteria committed
114
-- See Note [Deterministic SCC]
115
graphFromEdgedVertices
niteria's avatar
niteria committed
116 117
        :: ReduceFn key payload
        -> [Node key payload]           -- The graph; its ok for the
118
                                        -- out-list to contain keys which aren't
119
                                        -- a vertex key, they are ignored
120
        -> Graph (Node key payload)
niteria's avatar
niteria committed
121 122 123
graphFromEdgedVertices _reduceFn []            = emptyGraph
graphFromEdgedVertices reduceFn edged_vertices =
  Graph graph vertex_fn (key_vertex . key_extractor)
124
  where key_extractor = node_key
niteria's avatar
niteria committed
125 126
        (bounds, vertex_fn, key_vertex, numbered_nodes) =
          reduceFn edged_vertices key_extractor
127
        graph = array bounds [ (v, sort $ mapMaybe key_vertex ks)
128
                             | (v, (node_dependencies -> ks)) <- numbered_nodes]
129 130 131
                -- We normalize outgoing edges by sorting on node order, so
                -- that the result doesn't depend on the order of the edges

niteria's avatar
niteria committed
132 133 134 135 136
-- See Note [Deterministic SCC]
-- See Note [reduceNodesIntoVertices implementations]
graphFromEdgedVerticesOrd
        :: Ord key
        => [Node key payload]           -- The graph; its ok for the
137
                                        -- out-list to contain keys which aren't
niteria's avatar
niteria committed
138 139 140 141 142 143 144 145 146
                                        -- a vertex key, they are ignored
        -> Graph (Node key payload)
graphFromEdgedVerticesOrd = graphFromEdgedVertices reduceNodesIntoVerticesOrd

-- See Note [Deterministic SCC]
-- See Note [reduceNodesIntoVertices implementations]
graphFromEdgedVerticesUniq
        :: Uniquable key
        => [Node key payload]           -- The graph; its ok for the
147
                                        -- out-list to contain keys which aren't
niteria's avatar
niteria committed
148 149 150 151 152 153 154 155
                                        -- a vertex key, they are ignored
        -> Graph (Node key payload)
graphFromEdgedVerticesUniq = graphFromEdgedVertices reduceNodesIntoVerticesUniq

type ReduceFn key payload =
  [Node key payload] -> (Node key payload -> key) ->
    (Bounds, Vertex -> Node key payload
    , key -> Maybe Vertex, [(Vertex, Node key payload)])
156

niteria's avatar
niteria committed
157 158 159 160
{-
Note [reduceNodesIntoVertices implementations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
reduceNodesIntoVertices is parameterized by the container type.
Brian Wignall's avatar
Brian Wignall committed
161
This is to accommodate key types that don't have an Ord instance
niteria's avatar
niteria committed
162 163 164 165 166 167 168 169 170 171 172 173 174
and hence preclude the use of Data.Map. An example of such type
would be Unique, there's no way to implement Ord Unique
deterministically.

For such types, there's a version with a Uniquable constraint.
This leaves us with two versions of every function that depends on
reduceNodesIntoVertices, one with Ord constraint and the other with
Uniquable constraint.
For example: graphFromEdgedVerticesOrd and graphFromEdgedVerticesUniq.

The Uniq version should be a tiny bit more efficient since it uses
Data.IntMap internally.
-}
175
reduceNodesIntoVertices
niteria's avatar
niteria committed
176 177 178 179 180
  :: ([(key, Vertex)] -> m)
  -> (key -> m -> Maybe Vertex)
  -> ReduceFn key payload
reduceNodesIntoVertices fromList lookup nodes key_extractor =
  (bounds, (!) vertex_map, key_vertex, numbered_nodes)
181 182 183 184
  where
    max_v           = length nodes - 1
    bounds          = (0, max_v) :: (Vertex, Vertex)

185 186 187
    -- Keep the order intact to make the result depend on input order
    -- instead of key order
    numbered_nodes  = zip [0..] nodes
188 189
    vertex_map      = array bounds numbered_nodes

niteria's avatar
niteria committed
190
    key_map = fromList
191
      [ (key_extractor node, v) | (v, node) <- numbered_nodes ]
niteria's avatar
niteria committed
192 193 194 195 196 197 198 199 200
    key_vertex k = lookup k key_map

-- See Note [reduceNodesIntoVertices implementations]
reduceNodesIntoVerticesOrd :: Ord key => ReduceFn key payload
reduceNodesIntoVerticesOrd = reduceNodesIntoVertices Map.fromList Map.lookup

-- See Note [reduceNodesIntoVertices implementations]
reduceNodesIntoVerticesUniq :: Uniquable key => ReduceFn key payload
reduceNodesIntoVerticesUniq = reduceNodesIntoVertices listToUFM (flip lookupUFM)
201

Austin Seipp's avatar
Austin Seipp committed
202 203 204 205 206 207 208
{-
************************************************************************
*                                                                      *
*      SCC
*                                                                      *
************************************************************************
-}
sof's avatar
sof committed
209

210
type WorkItem key payload
211 212 213
  = (Node key payload,  -- Tip of the path
     [payload])         -- Rest of the path;
                        --  [a,b,c] means c depends on b, b depends on a
214 215 216 217

-- | Find a reasonably short cycle a->b->c->a, in a strongly
-- connected component.  The input nodes are presumed to be
-- a SCC, so you can start anywhere.
218
findCycle :: forall payload key. Ord key
219
          => [Node key payload]     -- The nodes.  The dependencies can
220 221 222
                                    -- contain extra keys, which are ignored
          -> Maybe [payload]        -- A cycle, starting with node
                                    -- so each depends on the next
223 224 225 226
findCycle graph
  = go Set.empty (new_work root_deps []) []
  where
    env :: Map.Map key (Node key payload)
227
    env = Map.fromList [ (node_key node, node) | node <- graph ]
228 229 230 231

    -- Find the node with fewest dependencies among the SCC modules
    -- This is just a heuristic to find some plausible root module
    root :: Node key payload
232 233 234 235
    root = fst (minWith snd [ (node, count (`Map.member` env)
                                           (node_dependencies node))
                            | node <- graph ])
    DigraphNode root_payload root_key root_deps = root
236 237 238


    -- 'go' implements Dijkstra's algorithm, more or less
239 240 241 242
    go :: Set.Set key   -- Visited
       -> [WorkItem key payload]        -- Work list, items length n
       -> [WorkItem key payload]        -- Work list, items length n+1
       -> Maybe [payload]               -- Returned cycle
243 244 245
       -- Invariant: in a call (go visited ps qs),
       --            visited = union (map tail (ps ++ qs))

246
    go _       [] [] = Nothing  -- No cycles
247
    go visited [] qs = go visited qs []
248
    go visited (((DigraphNode payload key deps), path) : ps) qs
249 250 251 252 253 254
       | key == root_key           = Just (root_payload : reverse path)
       | key `Set.member` visited  = go visited ps qs
       | key `Map.notMember` env   = go visited ps qs
       | otherwise                 = go (Set.insert key visited)
                                        ps (new_qs ++ qs)
       where
255
         new_qs = new_work deps (payload : path)
256 257 258 259

    new_work :: [key] -> [payload] -> [WorkItem key payload]
    new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ]

Austin Seipp's avatar
Austin Seipp committed
260 261 262 263 264 265
{-
************************************************************************
*                                                                      *
*      Strongly Connected Component wrappers for Graph
*                                                                      *
************************************************************************
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
266

267
Note: the components are returned topologically sorted: later components
268
depend on earlier ones, but not vice versa i.e. later components only have
269
edges going from them to earlier ones.
Austin Seipp's avatar
Austin Seipp committed
270
-}
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
271

niteria's avatar
niteria committed
272 273 274
{-
Note [Deterministic SCC]
~~~~~~~~~~~~~~~~~~~~~~~~
niteria's avatar
niteria committed
275 276 277 278
stronglyConnCompFromEdgedVerticesUniq,
stronglyConnCompFromEdgedVerticesUniqR,
stronglyConnCompFromEdgedVerticesOrd and
stronglyConnCompFromEdgedVerticesOrdR
niteria's avatar
niteria committed
279 280 281 282 283 284 285 286
provide a following guarantee:
Given a deterministically ordered list of nodes it returns a deterministically
ordered list of strongly connected components, where the list of vertices
in an SCC is also deterministically ordered.
Note that the order of edges doesn't need to be deterministic for this to work.
We use the order of nodes to normalize the order of edges.
-}

287
stronglyConnCompG :: Graph node -> [SCC node]
288 289 290 291 292 293
stronglyConnCompG graph = decodeSccs graph forest
  where forest = {-# SCC "Digraph.scc" #-} scc (gr_int_graph graph)

decodeSccs :: Graph node -> Forest Vertex -> [SCC node]
decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest
  = map decode forest
sof's avatar
sof committed
294 295
  where
    decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
Ian Lynagh's avatar
Ian Lynagh committed
296
                       | otherwise         = AcyclicSCC (vertex_fn v)
sof's avatar
sof committed
297
    decode other = CyclicSCC (dec other [])
298
      where dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
sof's avatar
sof committed
299
    mentions_itself v = v `elem` (graph ! v)
300 301


302
-- The following two versions are provided for backwards compatibility:
niteria's avatar
niteria committed
303
-- See Note [Deterministic SCC]
niteria's avatar
niteria committed
304 305
-- See Note [reduceNodesIntoVertices implementations]
stronglyConnCompFromEdgedVerticesOrd
306
        :: Ord key
307 308
        => [Node key payload]
        -> [SCC payload]
niteria's avatar
niteria committed
309
stronglyConnCompFromEdgedVerticesOrd
310
  = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesOrdR
niteria's avatar
niteria committed
311

312
-- The following two versions are provided for backwards compatibility:
niteria's avatar
niteria committed
313 314 315 316 317 318 319
-- See Note [Deterministic SCC]
-- See Note [reduceNodesIntoVertices implementations]
stronglyConnCompFromEdgedVerticesUniq
        :: Uniquable key
        => [Node key payload]
        -> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq
320
  = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesUniqR
321 322

-- The "R" interface is used when you expect to apply SCC to
323
-- (some of) the result of SCC, so you don't want to lose the dependency info
niteria's avatar
niteria committed
324
-- See Note [Deterministic SCC]
niteria's avatar
niteria committed
325 326
-- See Note [reduceNodesIntoVertices implementations]
stronglyConnCompFromEdgedVerticesOrdR
327
        :: Ord key
328 329
        => [Node key payload]
        -> [SCC (Node key payload)]
niteria's avatar
niteria committed
330 331 332 333
stronglyConnCompFromEdgedVerticesOrdR =
  stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesOrd

-- The "R" interface is used when you expect to apply SCC to
334
-- (some of) the result of SCC, so you don't want to lose the dependency info
niteria's avatar
niteria committed
335 336 337 338 339 340 341 342
-- See Note [Deterministic SCC]
-- See Note [reduceNodesIntoVertices implementations]
stronglyConnCompFromEdgedVerticesUniqR
        :: Uniquable key
        => [Node key payload]
        -> [SCC (Node key payload)]
stronglyConnCompFromEdgedVerticesUniqR =
  stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesUniq
343

Austin Seipp's avatar
Austin Seipp committed
344 345 346 347 348 349 350
{-
************************************************************************
*                                                                      *
*      Misc wrappers for Graph
*                                                                      *
************************************************************************
-}
351

352 353 354 355 356 357 358
topologicalSortG :: Graph node -> [node]
topologicalSortG graph = map (gr_vertex_to_node graph) result
  where result = {-# SCC "Digraph.topSort" #-} topSort (gr_int_graph graph)

reachableG :: Graph node -> node -> [node]
reachableG graph from = map (gr_vertex_to_node graph) result
  where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from)
359 360
        result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) [from_vertex]

361
-- | Given a list of roots return all reachable nodes.
362 363
reachablesG :: Graph node -> [node] -> [node]
reachablesG graph froms = map (gr_vertex_to_node graph) result
364
  where result = {-# SCC "Digraph.reachable" #-}
365 366
                 reachable (gr_int_graph graph) vs
        vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ]
367 368 369 370 371 372 373 374 375 376 377 378

hasVertexG :: Graph node -> node -> Bool
hasVertexG graph node = isJust $ gr_node_to_vertex graph node

verticesG :: Graph node -> [node]
verticesG graph = map (gr_vertex_to_node graph) $ vertices (gr_int_graph graph)

edgesG :: Graph node -> [Edge node]
edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ edges (gr_int_graph graph)
  where v2n = gr_vertex_to_node graph

transposeG :: Graph node -> Graph node
379 380 381
transposeG graph = Graph (G.transposeG (gr_int_graph graph))
                         (gr_vertex_to_node graph)
                         (gr_node_to_vertex graph)
382 383 384 385

emptyG :: Graph node -> Bool
emptyG g = graphEmpty (gr_int_graph g)

Austin Seipp's avatar
Austin Seipp committed
386 387 388 389 390 391 392
{-
************************************************************************
*                                                                      *
*      Showing Graphs
*                                                                      *
************************************************************************
-}
393 394 395 396 397 398 399 400 401 402

instance Outputable node => Outputable (Graph node) where
    ppr graph = vcat [
                  hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)),
                  hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph))
                ]

instance Outputable node => Outputable (Edge node) where
    ppr (Edge from to) = ppr from <+> text "->" <+> ppr to

403
graphEmpty :: G.Graph -> Bool
404 405
graphEmpty g = lo > hi
  where (lo, hi) = bounds g
406

Austin Seipp's avatar
Austin Seipp committed
407 408 409
{-
************************************************************************
*                                                                      *
410
*      IntGraphs
411 412 413 414
*                                                                      *
************************************************************************
-}

415
type IntGraph = G.Graph
416 417

{-
sof's avatar
sof committed
418
------------------------------------------------------------
419
-- Depth first search numbering
sof's avatar
sof committed
420
------------------------------------------------------------
Austin Seipp's avatar
Austin Seipp committed
421
-}
sof's avatar
sof committed
422

423
-- Data.Tree has flatten for Tree, but nothing for Forest
sof's avatar
sof committed
424
preorderF           :: Forest a -> [a]
425
preorderF ts         = concat (map flatten ts)
426 427 428

{-
------------------------------------------------------------
429
-- Finding reachable vertices
sof's avatar
sof committed
430
------------------------------------------------------------
Austin Seipp's avatar
Austin Seipp committed
431
-}
sof's avatar
sof committed
432

433
-- This generalizes reachable which was found in Data.Graph
434 435
reachable    :: IntGraph -> [Vertex] -> [Vertex]
reachable g vs = preorderF (dfs g vs)
436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466

{-
************************************************************************
*                                                                      *
*                         Classify Edge Types
*                                                                      *
************************************************************************
-}

-- Remark: While we could generalize this algorithm this comes at a runtime
-- cost and with no advantages. If you find yourself using this with graphs
-- not easily represented using Int nodes please consider rewriting this
-- using the more general Graph type.

-- | Edge direction based on DFS Classification
data EdgeType
  = Forward
  | Cross
  | Backward -- ^ Loop back towards the root node.
             -- Eg backjumps in loops
  | SelfLoop -- ^ v -> v
   deriving (Eq,Ord)

instance Outputable EdgeType where
  ppr Forward = text "Forward"
  ppr Cross = text "Cross"
  ppr Backward = text "Backward"
  ppr SelfLoop = text "SelfLoop"

newtype Time = Time Int deriving (Eq,Ord,Num,Outputable)

467
--Allow for specialization
468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524
{-# INLINEABLE classifyEdges #-}

-- | Given a start vertex, a way to get successors from a node
-- and a list of (directed) edges classify the types of edges.
classifyEdges :: forall key. Uniquable key => key -> (key -> [key])
              -> [(key,key)] -> [((key, key), EdgeType)]
classifyEdges root getSucc edges =
    --let uqe (from,to) = (getUnique from, getUnique to)
    --in pprTrace "Edges:" (ppr $ map uqe edges) $
    zip edges $ map classify edges
  where
    (_time, starts, ends) = addTimes (0,emptyUFM,emptyUFM) root
    classify :: (key,key) -> EdgeType
    classify (from,to)
      | startFrom < startTo
      , endFrom   > endTo
      = Forward
      | startFrom > startTo
      , endFrom   < endTo
      = Backward
      | startFrom > startTo
      , endFrom   > endTo
      = Cross
      | getUnique from == getUnique to
      = SelfLoop
      | otherwise
      = pprPanic "Failed to classify edge of Graph"
                 (ppr (getUnique from, getUnique to))

      where
        getTime event node
          | Just time <- lookupUFM event node
          = time
          | otherwise
          = pprPanic "Failed to classify edge of CFG - not not timed"
            (text "edges" <> ppr (getUnique from, getUnique to)
                          <+> ppr starts <+> ppr ends )
        startFrom = getTime starts from
        startTo   = getTime starts to
        endFrom   = getTime ends   from
        endTo     = getTime ends   to

    addTimes :: (Time, UniqFM Time, UniqFM Time) -> key
             -> (Time, UniqFM Time, UniqFM Time)
    addTimes (time,starts,ends) n
      --Dont reenter nodes
      | elemUFM n starts
      = (time,starts,ends)
      | otherwise =
        let
          starts' = addToUFM starts n time
          time' = time + 1
          succs = getSucc n :: [key]
          (time'',starts'',ends') = foldl' addTimes (time',starts',ends) succs
          ends'' = addToUFM ends' n time''
        in
        (time'' + 1, starts'', ends'')