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