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