48e39f761f4a40a4320bf697fd23b0a9e08241f5
[ghc.git] / compiler / utils / Digraph.hs
1 -- (c) The University of Glasgow 2006
2
3 {-# LANGUAGE CPP, ScopedTypeVariables #-}
4
5 module Digraph(
6 Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq,
7
8 SCC(..), Node, flattenSCC, flattenSCCs,
9 stronglyConnCompG,
10 topologicalSortG, dfsTopSortG,
11 verticesG, edgesG, hasVertexG,
12 reachableG, reachablesG, transposeG,
13 outdegreeG, indegreeG,
14 vertexGroupsG, emptyG,
15 componentsG,
16
17 findCycle,
18
19 -- For backwards compatibility with the simpler version of Digraph
20 stronglyConnCompFromEdgedVerticesOrd,
21 stronglyConnCompFromEdgedVerticesOrdR,
22 stronglyConnCompFromEdgedVerticesUniq,
23 stronglyConnCompFromEdgedVerticesUniqR,
24 ) where
25
26 #include "HsVersions.h"
27
28 ------------------------------------------------------------------------------
29 -- A version of the graph algorithms described in:
30 --
31 -- ``Lazy Depth-First Search and Linear IntGraph Algorithms in Haskell''
32 -- by David King and John Launchbury
33 --
34 -- Also included is some additional code for printing tree structures ...
35 --
36 -- If you ever find yourself in need of algorithms for classifying edges,
37 -- or finding connected/biconnected components, consult the history; Sigbjorn
38 -- Finne contributed some implementations in 1997, although we've since
39 -- removed them since they were not used anywhere in GHC.
40 ------------------------------------------------------------------------------
41
42
43 import Util ( minWith, count )
44 import Outputable
45 import Maybes ( expectJust )
46 import MonadUtils ( allM )
47
48 -- Extensions
49 import Control.Monad ( filterM, liftM, liftM2 )
50 import Control.Monad.ST
51
52 -- std interfaces
53 import Data.Maybe
54 import Data.Array
55 import Data.List hiding (transpose)
56 import Data.Array.ST
57 import qualified Data.Map as Map
58 import qualified Data.Set as Set
59
60 import qualified Data.Graph as G
61 import Data.Graph hiding (Graph, Edge, transposeG, reachable)
62 import Data.Tree
63 import Unique
64 import UniqFM
65
66 {-
67 ************************************************************************
68 * *
69 * Graphs and Graph Construction
70 * *
71 ************************************************************************
72
73 Note [Nodes, keys, vertices]
74 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
75 * A 'node' is a big blob of client-stuff
76
77 * Each 'node' has a unique (client) 'key', but the latter
78 is in Ord and has fast comparison
79
80 * Digraph then maps each 'key' to a Vertex (Int) which is
81 arranged densely in 0.n
82 -}
83
84 data Graph node = Graph {
85 gr_int_graph :: IntGraph,
86 gr_vertex_to_node :: Vertex -> node,
87 gr_node_to_vertex :: node -> Maybe Vertex
88 }
89
90 data Edge node = Edge node node
91
92 type Node key payload = (payload, key, [key])
93 -- The payload is user data, just carried around in this module
94 -- The keys are ordered
95 -- The [key] are the dependencies of the node;
96 -- it's ok to have extra keys in the dependencies that
97 -- are not the key of any Node in the graph
98
99 emptyGraph :: Graph a
100 emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing)
101
102 -- See Note [Deterministic SCC]
103 graphFromEdgedVertices
104 :: ReduceFn key payload
105 -> [Node key payload] -- The graph; its ok for the
106 -- out-list to contain keys which aren't
107 -- a vertex key, they are ignored
108 -> Graph (Node key payload)
109 graphFromEdgedVertices _reduceFn [] = emptyGraph
110 graphFromEdgedVertices reduceFn edged_vertices =
111 Graph graph vertex_fn (key_vertex . key_extractor)
112 where key_extractor (_, k, _) = k
113 (bounds, vertex_fn, key_vertex, numbered_nodes) =
114 reduceFn edged_vertices key_extractor
115 graph = array bounds [ (v, sort $ mapMaybe key_vertex ks)
116 | (v, (_, _, ks)) <- numbered_nodes]
117 -- We normalize outgoing edges by sorting on node order, so
118 -- that the result doesn't depend on the order of the edges
119
120 -- See Note [Deterministic SCC]
121 -- See Note [reduceNodesIntoVertices implementations]
122 graphFromEdgedVerticesOrd
123 :: Ord key
124 => [Node key payload] -- The graph; its ok for the
125 -- out-list to contain keys which aren't
126 -- a vertex key, they are ignored
127 -> Graph (Node key payload)
128 graphFromEdgedVerticesOrd = graphFromEdgedVertices reduceNodesIntoVerticesOrd
129
130 -- See Note [Deterministic SCC]
131 -- See Note [reduceNodesIntoVertices implementations]
132 graphFromEdgedVerticesUniq
133 :: Uniquable key
134 => [Node key payload] -- The graph; its ok for the
135 -- out-list to contain keys which aren't
136 -- a vertex key, they are ignored
137 -> Graph (Node key payload)
138 graphFromEdgedVerticesUniq = graphFromEdgedVertices reduceNodesIntoVerticesUniq
139
140 type ReduceFn key payload =
141 [Node key payload] -> (Node key payload -> key) ->
142 (Bounds, Vertex -> Node key payload
143 , key -> Maybe Vertex, [(Vertex, Node key payload)])
144
145 {-
146 Note [reduceNodesIntoVertices implementations]
147 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
148 reduceNodesIntoVertices is parameterized by the container type.
149 This is to accomodate key types that don't have an Ord instance
150 and hence preclude the use of Data.Map. An example of such type
151 would be Unique, there's no way to implement Ord Unique
152 deterministically.
153
154 For such types, there's a version with a Uniquable constraint.
155 This leaves us with two versions of every function that depends on
156 reduceNodesIntoVertices, one with Ord constraint and the other with
157 Uniquable constraint.
158 For example: graphFromEdgedVerticesOrd and graphFromEdgedVerticesUniq.
159
160 The Uniq version should be a tiny bit more efficient since it uses
161 Data.IntMap internally.
162 -}
163 reduceNodesIntoVertices
164 :: ([(key, Vertex)] -> m)
165 -> (key -> m -> Maybe Vertex)
166 -> ReduceFn key payload
167 reduceNodesIntoVertices fromList lookup nodes key_extractor =
168 (bounds, (!) vertex_map, key_vertex, numbered_nodes)
169 where
170 max_v = length nodes - 1
171 bounds = (0, max_v) :: (Vertex, Vertex)
172
173 -- Keep the order intact to make the result depend on input order
174 -- instead of key order
175 numbered_nodes = zip [0..] nodes
176 vertex_map = array bounds numbered_nodes
177
178 key_map = fromList
179 [ (key_extractor node, v) | (v, node) <- numbered_nodes ]
180 key_vertex k = lookup k key_map
181
182 -- See Note [reduceNodesIntoVertices implementations]
183 reduceNodesIntoVerticesOrd :: Ord key => ReduceFn key payload
184 reduceNodesIntoVerticesOrd = reduceNodesIntoVertices Map.fromList Map.lookup
185
186 -- See Note [reduceNodesIntoVertices implementations]
187 reduceNodesIntoVerticesUniq :: Uniquable key => ReduceFn key payload
188 reduceNodesIntoVerticesUniq = reduceNodesIntoVertices listToUFM (flip lookupUFM)
189
190 {-
191 ************************************************************************
192 * *
193 * SCC
194 * *
195 ************************************************************************
196 -}
197
198 type WorkItem key payload
199 = (Node key payload, -- Tip of the path
200 [payload]) -- Rest of the path;
201 -- [a,b,c] means c depends on b, b depends on a
202
203 -- | Find a reasonably short cycle a->b->c->a, in a strongly
204 -- connected component. The input nodes are presumed to be
205 -- a SCC, so you can start anywhere.
206 findCycle :: forall payload key. Ord key
207 => [Node key payload] -- The nodes. The dependencies can
208 -- contain extra keys, which are ignored
209 -> Maybe [payload] -- A cycle, starting with node
210 -- so each depends on the next
211 findCycle graph
212 = go Set.empty (new_work root_deps []) []
213 where
214 env :: Map.Map key (Node key payload)
215 env = Map.fromList [ (key, node) | node@(_, key, _) <- graph ]
216
217 -- Find the node with fewest dependencies among the SCC modules
218 -- This is just a heuristic to find some plausible root module
219 root :: Node key payload
220 root = fst (minWith snd [ (node, count (`Map.member` env) deps)
221 | node@(_,_,deps) <- graph ])
222 (root_payload,root_key,root_deps) = root
223
224
225 -- 'go' implements Dijkstra's algorithm, more or less
226 go :: Set.Set key -- Visited
227 -> [WorkItem key payload] -- Work list, items length n
228 -> [WorkItem key payload] -- Work list, items length n+1
229 -> Maybe [payload] -- Returned cycle
230 -- Invariant: in a call (go visited ps qs),
231 -- visited = union (map tail (ps ++ qs))
232
233 go _ [] [] = Nothing -- No cycles
234 go visited [] qs = go visited qs []
235 go visited (((payload,key,deps), path) : ps) qs
236 | key == root_key = Just (root_payload : reverse path)
237 | key `Set.member` visited = go visited ps qs
238 | key `Map.notMember` env = go visited ps qs
239 | otherwise = go (Set.insert key visited)
240 ps (new_qs ++ qs)
241 where
242 new_qs = new_work deps (payload : path)
243
244 new_work :: [key] -> [payload] -> [WorkItem key payload]
245 new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ]
246
247 {-
248 ************************************************************************
249 * *
250 * Strongly Connected Component wrappers for Graph
251 * *
252 ************************************************************************
253
254 Note: the components are returned topologically sorted: later components
255 depend on earlier ones, but not vice versa i.e. later components only have
256 edges going from them to earlier ones.
257 -}
258
259 {-
260 Note [Deterministic SCC]
261 ~~~~~~~~~~~~~~~~~~~~~~~~
262 stronglyConnCompFromEdgedVerticesUniq,
263 stronglyConnCompFromEdgedVerticesUniqR,
264 stronglyConnCompFromEdgedVerticesOrd and
265 stronglyConnCompFromEdgedVerticesOrdR
266 provide a following guarantee:
267 Given a deterministically ordered list of nodes it returns a deterministically
268 ordered list of strongly connected components, where the list of vertices
269 in an SCC is also deterministically ordered.
270 Note that the order of edges doesn't need to be deterministic for this to work.
271 We use the order of nodes to normalize the order of edges.
272 -}
273
274 stronglyConnCompG :: Graph node -> [SCC node]
275 stronglyConnCompG graph = decodeSccs graph forest
276 where forest = {-# SCC "Digraph.scc" #-} scc (gr_int_graph graph)
277
278 decodeSccs :: Graph node -> Forest Vertex -> [SCC node]
279 decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest
280 = map decode forest
281 where
282 decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
283 | otherwise = AcyclicSCC (vertex_fn v)
284 decode other = CyclicSCC (dec other [])
285 where dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
286 mentions_itself v = v `elem` (graph ! v)
287
288
289 -- The following two versions are provided for backwards compatibility:
290 -- See Note [Deterministic SCC]
291 -- See Note [reduceNodesIntoVertices implementations]
292 stronglyConnCompFromEdgedVerticesOrd
293 :: Ord key
294 => [Node key payload]
295 -> [SCC payload]
296 stronglyConnCompFromEdgedVerticesOrd
297 = map (fmap get_node) . stronglyConnCompFromEdgedVerticesOrdR
298 where get_node (n, _, _) = n
299
300 -- The following two versions are provided for backwards compatibility:
301 -- See Note [Deterministic SCC]
302 -- See Note [reduceNodesIntoVertices implementations]
303 stronglyConnCompFromEdgedVerticesUniq
304 :: Uniquable key
305 => [Node key payload]
306 -> [SCC payload]
307 stronglyConnCompFromEdgedVerticesUniq
308 = map (fmap get_node) . stronglyConnCompFromEdgedVerticesUniqR
309 where get_node (n, _, _) = n
310
311 -- The "R" interface is used when you expect to apply SCC to
312 -- (some of) the result of SCC, so you dont want to lose the dependency info
313 -- See Note [Deterministic SCC]
314 -- See Note [reduceNodesIntoVertices implementations]
315 stronglyConnCompFromEdgedVerticesOrdR
316 :: Ord key
317 => [Node key payload]
318 -> [SCC (Node key payload)]
319 stronglyConnCompFromEdgedVerticesOrdR =
320 stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesOrd
321
322 -- The "R" interface is used when you expect to apply SCC to
323 -- (some of) the result of SCC, so you dont want to lose the dependency info
324 -- See Note [Deterministic SCC]
325 -- See Note [reduceNodesIntoVertices implementations]
326 stronglyConnCompFromEdgedVerticesUniqR
327 :: Uniquable key
328 => [Node key payload]
329 -> [SCC (Node key payload)]
330 stronglyConnCompFromEdgedVerticesUniqR =
331 stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesUniq
332
333 {-
334 ************************************************************************
335 * *
336 * Misc wrappers for Graph
337 * *
338 ************************************************************************
339 -}
340
341 topologicalSortG :: Graph node -> [node]
342 topologicalSortG graph = map (gr_vertex_to_node graph) result
343 where result = {-# SCC "Digraph.topSort" #-} topSort (gr_int_graph graph)
344
345 dfsTopSortG :: Graph node -> [[node]]
346 dfsTopSortG graph =
347 map (map (gr_vertex_to_node graph) . flatten) $ dfs g (topSort g)
348 where
349 g = gr_int_graph graph
350
351 reachableG :: Graph node -> node -> [node]
352 reachableG graph from = map (gr_vertex_to_node graph) result
353 where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from)
354 result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) [from_vertex]
355
356 reachablesG :: Graph node -> [node] -> [node]
357 reachablesG graph froms = map (gr_vertex_to_node graph) result
358 where result = {-# SCC "Digraph.reachable" #-}
359 reachable (gr_int_graph graph) vs
360 vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ]
361
362 hasVertexG :: Graph node -> node -> Bool
363 hasVertexG graph node = isJust $ gr_node_to_vertex graph node
364
365 verticesG :: Graph node -> [node]
366 verticesG graph = map (gr_vertex_to_node graph) $ vertices (gr_int_graph graph)
367
368 edgesG :: Graph node -> [Edge node]
369 edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ edges (gr_int_graph graph)
370 where v2n = gr_vertex_to_node graph
371
372 transposeG :: Graph node -> Graph node
373 transposeG graph = Graph (G.transposeG (gr_int_graph graph))
374 (gr_vertex_to_node graph)
375 (gr_node_to_vertex graph)
376
377 outdegreeG :: Graph node -> node -> Maybe Int
378 outdegreeG = degreeG outdegree
379
380 indegreeG :: Graph node -> node -> Maybe Int
381 indegreeG = degreeG indegree
382
383 degreeG :: (G.Graph -> Table Int) -> Graph node -> node -> Maybe Int
384 degreeG degree graph node = let table = degree (gr_int_graph graph)
385 in fmap ((!) table) $ gr_node_to_vertex graph node
386
387 vertexGroupsG :: Graph node -> [[node]]
388 vertexGroupsG graph = map (map (gr_vertex_to_node graph)) result
389 where result = vertexGroups (gr_int_graph graph)
390
391 emptyG :: Graph node -> Bool
392 emptyG g = graphEmpty (gr_int_graph g)
393
394 componentsG :: Graph node -> [[node]]
395 componentsG graph = map (map (gr_vertex_to_node graph) . flatten)
396 $ components (gr_int_graph graph)
397
398 {-
399 ************************************************************************
400 * *
401 * Showing Graphs
402 * *
403 ************************************************************************
404 -}
405
406 instance Outputable node => Outputable (Graph node) where
407 ppr graph = vcat [
408 hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)),
409 hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph))
410 ]
411
412 instance Outputable node => Outputable (Edge node) where
413 ppr (Edge from to) = ppr from <+> text "->" <+> ppr to
414
415 graphEmpty :: G.Graph -> Bool
416 graphEmpty g = lo > hi
417 where (lo, hi) = bounds g
418
419 {-
420 ************************************************************************
421 * *
422 * IntGraphs
423 * *
424 ************************************************************************
425 -}
426
427 type IntGraph = G.Graph
428
429 {-
430 ------------------------------------------------------------
431 -- Depth first search numbering
432 ------------------------------------------------------------
433 -}
434
435 -- Data.Tree has flatten for Tree, but nothing for Forest
436 preorderF :: Forest a -> [a]
437 preorderF ts = concat (map flatten ts)
438
439 {-
440 ------------------------------------------------------------
441 -- Finding reachable vertices
442 ------------------------------------------------------------
443 -}
444
445 -- This generalizes reachable which was found in Data.Graph
446 reachable :: IntGraph -> [Vertex] -> [Vertex]
447 reachable g vs = preorderF (dfs g vs)
448
449 {-
450 ------------------------------------------------------------
451 -- Total ordering on groups of vertices
452 ------------------------------------------------------------
453
454 The plan here is to extract a list of groups of elements of the graph
455 such that each group has no dependence except on nodes in previous
456 groups (i.e. in particular they may not depend on nodes in their own
457 group) and is maximal such group.
458
459 Clearly we cannot provide a solution for cyclic graphs.
460
461 We proceed by iteratively removing elements with no outgoing edges
462 and their associated edges from the graph.
463
464 This probably isn't very efficient and certainly isn't very clever.
465 -}
466
467 type Set s = STArray s Vertex Bool
468
469 mkEmpty :: Bounds -> ST s (Set s)
470 mkEmpty bnds = newArray bnds False
471
472 contains :: Set s -> Vertex -> ST s Bool
473 contains m v = readArray m v
474
475 include :: Set s -> Vertex -> ST s ()
476 include m v = writeArray m v True
477
478 vertexGroups :: IntGraph -> [[Vertex]]
479 vertexGroups g = runST (mkEmpty (bounds g) >>= \provided -> vertexGroupsS provided g next_vertices)
480 where next_vertices = noOutEdges g
481
482 noOutEdges :: IntGraph -> [Vertex]
483 noOutEdges g = [ v | v <- vertices g, null (g!v)]
484
485 vertexGroupsS :: Set s -> IntGraph -> [Vertex] -> ST s [[Vertex]]
486 vertexGroupsS provided g to_provide
487 = if null to_provide
488 then do {
489 all_provided <- allM (provided `contains`) (vertices g)
490 ; if all_provided
491 then return []
492 else error "vertexGroup: cyclic graph"
493 }
494 else do {
495 mapM_ (include provided) to_provide
496 ; to_provide' <- filterM (vertexReady provided g) (vertices g)
497 ; rest <- vertexGroupsS provided g to_provide'
498 ; return $ to_provide : rest
499 }
500
501 vertexReady :: Set s -> IntGraph -> Vertex -> ST s Bool
502 vertexReady provided g v = liftM2 (&&) (liftM not $ provided `contains` v) (allM (provided `contains`) (g!v))