never executed always true always false
1 -- (c) The University of Glasgow 2006
2
3
4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
5 {-# LANGUAGE ScopedTypeVariables #-}
6 {-# LANGUAGE ViewPatterns #-}
7
8 module GHC.Data.Graph.Directed (
9 Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq,
10
11 SCC(..), Node(..), flattenSCC, flattenSCCs,
12 stronglyConnCompG,
13 topologicalSortG,
14 verticesG, edgesG, hasVertexG,
15 reachableG, reachablesG, transposeG, allReachable, outgoingG,
16 emptyG,
17
18 findCycle,
19
20 -- For backwards compatibility with the simpler version of Digraph
21 stronglyConnCompFromEdgedVerticesOrd,
22 stronglyConnCompFromEdgedVerticesOrdR,
23 stronglyConnCompFromEdgedVerticesUniq,
24 stronglyConnCompFromEdgedVerticesUniqR,
25
26 -- Simple way to classify edges
27 EdgeType(..), classifyEdges
28 ) where
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 -- If you ever find yourself in need of algorithms for classifying edges,
39 -- or finding connected/biconnected components, consult the history; Sigbjorn
40 -- Finne contributed some implementations in 1997, although we've since
41 -- removed them since they were not used anywhere in GHC.
42 ------------------------------------------------------------------------------
43
44
45 import GHC.Prelude
46
47 import GHC.Utils.Misc ( minWith, count )
48 import GHC.Utils.Outputable
49 import GHC.Utils.Panic
50 import GHC.Data.Maybe ( expectJust )
51
52 -- std interfaces
53 import Data.Maybe
54 import Data.Array
55 import Data.List ( sort )
56 import qualified Data.Map as Map
57 import qualified Data.Set as Set
58
59 import qualified Data.Graph as G
60 import Data.Graph hiding (Graph, Edge, transposeG, reachable)
61 import Data.Tree
62 import GHC.Types.Unique
63 import GHC.Types.Unique.FM
64 import qualified Data.IntMap as IM
65 import qualified Data.IntSet as IS
66 import qualified Data.Map as M
67
68 {-
69 ************************************************************************
70 * *
71 * Graphs and Graph Construction
72 * *
73 ************************************************************************
74
75 Note [Nodes, keys, vertices]
76 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
77 * A 'node' is a big blob of client-stuff
78
79 * Each 'node' has a unique (client) 'key', but the latter
80 is in Ord and has fast comparison
81
82 * Digraph then maps each 'key' to a Vertex (Int) which is
83 arranged densely in 0.n
84 -}
85
86 data Graph node = Graph {
87 gr_int_graph :: IntGraph,
88 gr_vertex_to_node :: Vertex -> node,
89 gr_node_to_vertex :: node -> Maybe Vertex
90 }
91
92 data Edge node = Edge node node
93
94 {-| Representation for nodes of the Graph.
95
96 * The @payload@ is user data, just carried around in this module
97
98 * The @key@ is the node identifier.
99 Key has an Ord instance for performance reasons.
100
101 * The @[key]@ are the dependencies of the node;
102 it's ok to have extra keys in the dependencies that
103 are not the key of any Node in the graph
104 -}
105 data Node key payload = DigraphNode {
106 node_payload :: payload, -- ^ User data
107 node_key :: key, -- ^ User defined node id
108 node_dependencies :: [key] -- ^ Dependencies/successors of the node
109 }
110
111
112 instance (Outputable a, Outputable b) => Outputable (Node a b) where
113 ppr (DigraphNode a b c) = ppr (a, b, c)
114
115 emptyGraph :: Graph a
116 emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing)
117
118 -- See Note [Deterministic SCC]
119 graphFromEdgedVertices
120 :: ReduceFn key payload
121 -> [Node key payload] -- The graph; its ok for the
122 -- out-list to contain keys which aren't
123 -- a vertex key, they are ignored
124 -> Graph (Node key payload)
125 graphFromEdgedVertices _reduceFn [] = emptyGraph
126 graphFromEdgedVertices reduceFn edged_vertices =
127 Graph graph vertex_fn (key_vertex . key_extractor)
128 where key_extractor = node_key
129 (bounds, vertex_fn, key_vertex, numbered_nodes) =
130 reduceFn edged_vertices key_extractor
131 graph = array bounds [ (v, sort $ mapMaybe key_vertex ks)
132 | (v, (node_dependencies -> ks)) <- numbered_nodes]
133 -- We normalize outgoing edges by sorting on node order, so
134 -- that the result doesn't depend on the order of the edges
135
136 -- See Note [Deterministic SCC]
137 -- See Note [reduceNodesIntoVertices implementations]
138 graphFromEdgedVerticesOrd
139 :: Ord key
140 => [Node key payload] -- The graph; its ok for the
141 -- out-list to contain keys which aren't
142 -- a vertex key, they are ignored
143 -> Graph (Node key payload)
144 graphFromEdgedVerticesOrd = graphFromEdgedVertices reduceNodesIntoVerticesOrd
145
146 -- See Note [Deterministic SCC]
147 -- See Note [reduceNodesIntoVertices implementations]
148 graphFromEdgedVerticesUniq
149 :: Uniquable key
150 => [Node key payload] -- The graph; its ok for the
151 -- out-list to contain keys which aren't
152 -- a vertex key, they are ignored
153 -> Graph (Node key payload)
154 graphFromEdgedVerticesUniq = graphFromEdgedVertices reduceNodesIntoVerticesUniq
155
156 type ReduceFn key payload =
157 [Node key payload] -> (Node key payload -> key) ->
158 (Bounds, Vertex -> Node key payload
159 , key -> Maybe Vertex, [(Vertex, Node key payload)])
160
161 {-
162 Note [reduceNodesIntoVertices implementations]
163 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
164 reduceNodesIntoVertices is parameterized by the container type.
165 This is to accommodate key types that don't have an Ord instance
166 and hence preclude the use of Data.Map. An example of such type
167 would be Unique, there's no way to implement Ord Unique
168 deterministically.
169
170 For such types, there's a version with a Uniquable constraint.
171 This leaves us with two versions of every function that depends on
172 reduceNodesIntoVertices, one with Ord constraint and the other with
173 Uniquable constraint.
174 For example: graphFromEdgedVerticesOrd and graphFromEdgedVerticesUniq.
175
176 The Uniq version should be a tiny bit more efficient since it uses
177 Data.IntMap internally.
178 -}
179 reduceNodesIntoVertices
180 :: ([(key, Vertex)] -> m)
181 -> (key -> m -> Maybe Vertex)
182 -> ReduceFn key payload
183 reduceNodesIntoVertices fromList lookup nodes key_extractor =
184 (bounds, (!) vertex_map, key_vertex, numbered_nodes)
185 where
186 max_v = length nodes - 1
187 bounds = (0, max_v) :: (Vertex, Vertex)
188
189 -- Keep the order intact to make the result depend on input order
190 -- instead of key order
191 numbered_nodes = zip [0..] nodes
192 vertex_map = array bounds numbered_nodes
193
194 key_map = fromList
195 [ (key_extractor node, v) | (v, node) <- numbered_nodes ]
196 key_vertex k = lookup k key_map
197
198 -- See Note [reduceNodesIntoVertices implementations]
199 reduceNodesIntoVerticesOrd :: Ord key => ReduceFn key payload
200 reduceNodesIntoVerticesOrd = reduceNodesIntoVertices Map.fromList Map.lookup
201
202 -- See Note [reduceNodesIntoVertices implementations]
203 reduceNodesIntoVerticesUniq :: Uniquable key => ReduceFn key payload
204 reduceNodesIntoVerticesUniq = reduceNodesIntoVertices listToUFM (flip lookupUFM)
205
206 {-
207 ************************************************************************
208 * *
209 * SCC
210 * *
211 ************************************************************************
212 -}
213
214 type WorkItem key payload
215 = (Node key payload, -- Tip of the path
216 [payload]) -- Rest of the path;
217 -- [a,b,c] means c depends on b, b depends on a
218
219 -- | Find a reasonably short cycle a->b->c->a, in a strongly
220 -- connected component. The input nodes are presumed to be
221 -- a SCC, so you can start anywhere.
222 findCycle :: forall payload key. Ord key
223 => [Node key payload] -- The nodes. The dependencies can
224 -- contain extra keys, which are ignored
225 -> Maybe [payload] -- A cycle, starting with node
226 -- so each depends on the next
227 findCycle graph
228 = go Set.empty (new_work root_deps []) []
229 where
230 env :: Map.Map key (Node key payload)
231 env = Map.fromList [ (node_key node, node) | node <- graph ]
232
233 -- Find the node with fewest dependencies among the SCC modules
234 -- This is just a heuristic to find some plausible root module
235 root :: Node key payload
236 root = fst (minWith snd [ (node, count (`Map.member` env)
237 (node_dependencies node))
238 | node <- graph ])
239 DigraphNode root_payload root_key root_deps = root
240
241
242 -- 'go' implements Dijkstra's algorithm, more or less
243 go :: Set.Set key -- Visited
244 -> [WorkItem key payload] -- Work list, items length n
245 -> [WorkItem key payload] -- Work list, items length n+1
246 -> Maybe [payload] -- Returned cycle
247 -- Invariant: in a call (go visited ps qs),
248 -- visited = union (map tail (ps ++ qs))
249
250 go _ [] [] = Nothing -- No cycles
251 go visited [] qs = go visited qs []
252 go visited (((DigraphNode payload key deps), path) : ps) qs
253 | key == root_key = Just (root_payload : reverse path)
254 | key `Set.member` visited = go visited ps qs
255 | key `Map.notMember` env = go visited ps qs
256 | otherwise = go (Set.insert key visited)
257 ps (new_qs ++ qs)
258 where
259 new_qs = new_work deps (payload : path)
260
261 new_work :: [key] -> [payload] -> [WorkItem key payload]
262 new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ]
263
264 {-
265 ************************************************************************
266 * *
267 * Strongly Connected Component wrappers for Graph
268 * *
269 ************************************************************************
270
271 Note: the components are returned topologically sorted: later components
272 depend on earlier ones, but not vice versa i.e. later components only have
273 edges going from them to earlier ones.
274 -}
275
276 {-
277 Note [Deterministic SCC]
278 ~~~~~~~~~~~~~~~~~~~~~~~~
279 stronglyConnCompFromEdgedVerticesUniq,
280 stronglyConnCompFromEdgedVerticesUniqR,
281 stronglyConnCompFromEdgedVerticesOrd and
282 stronglyConnCompFromEdgedVerticesOrdR
283 provide a following guarantee:
284 Given a deterministically ordered list of nodes it returns a deterministically
285 ordered list of strongly connected components, where the list of vertices
286 in an SCC is also deterministically ordered.
287 Note that the order of edges doesn't need to be deterministic for this to work.
288 We use the order of nodes to normalize the order of edges.
289 -}
290
291 stronglyConnCompG :: Graph node -> [SCC node]
292 stronglyConnCompG graph = decodeSccs graph forest
293 where forest = {-# SCC "Digraph.scc" #-} scc (gr_int_graph graph)
294
295 decodeSccs :: Graph node -> Forest Vertex -> [SCC node]
296 decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest
297 = map decode forest
298 where
299 decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
300 | otherwise = AcyclicSCC (vertex_fn v)
301 decode other = CyclicSCC (dec other [])
302 where dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
303 mentions_itself v = v `elem` (graph ! v)
304
305
306 -- The following two versions are provided for backwards compatibility:
307 -- See Note [Deterministic SCC]
308 -- See Note [reduceNodesIntoVertices implementations]
309 stronglyConnCompFromEdgedVerticesOrd
310 :: Ord key
311 => [Node key payload]
312 -> [SCC payload]
313 stronglyConnCompFromEdgedVerticesOrd
314 = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesOrdR
315
316 -- The following two versions are provided for backwards compatibility:
317 -- See Note [Deterministic SCC]
318 -- See Note [reduceNodesIntoVertices implementations]
319 stronglyConnCompFromEdgedVerticesUniq
320 :: Uniquable key
321 => [Node key payload]
322 -> [SCC payload]
323 stronglyConnCompFromEdgedVerticesUniq
324 = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesUniqR
325
326 -- The "R" interface is used when you expect to apply SCC to
327 -- (some of) the result of SCC, so you don't want to lose the dependency info
328 -- See Note [Deterministic SCC]
329 -- See Note [reduceNodesIntoVertices implementations]
330 stronglyConnCompFromEdgedVerticesOrdR
331 :: Ord key
332 => [Node key payload]
333 -> [SCC (Node key payload)]
334 stronglyConnCompFromEdgedVerticesOrdR =
335 stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesOrd
336
337 -- The "R" interface is used when you expect to apply SCC to
338 -- (some of) the result of SCC, so you don't want to lose the dependency info
339 -- See Note [Deterministic SCC]
340 -- See Note [reduceNodesIntoVertices implementations]
341 stronglyConnCompFromEdgedVerticesUniqR
342 :: Uniquable key
343 => [Node key payload]
344 -> [SCC (Node key payload)]
345 stronglyConnCompFromEdgedVerticesUniqR =
346 stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesUniq
347
348 {-
349 ************************************************************************
350 * *
351 * Misc wrappers for Graph
352 * *
353 ************************************************************************
354 -}
355
356 topologicalSortG :: Graph node -> [node]
357 topologicalSortG graph = map (gr_vertex_to_node graph) result
358 where result = {-# SCC "Digraph.topSort" #-} topSort (gr_int_graph graph)
359
360 reachableG :: Graph node -> node -> [node]
361 reachableG graph from = map (gr_vertex_to_node graph) result
362 where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from)
363 result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) [from_vertex]
364
365 outgoingG :: Graph node -> node -> [node]
366 outgoingG graph from = map (gr_vertex_to_node graph) result
367 where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from)
368 result = gr_int_graph graph ! from_vertex
369
370 -- | Given a list of roots return all reachable nodes.
371 reachablesG :: Graph node -> [node] -> [node]
372 reachablesG graph froms = map (gr_vertex_to_node graph) result
373 where result = {-# SCC "Digraph.reachable" #-}
374 reachable (gr_int_graph graph) vs
375 vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ]
376
377 allReachable :: Ord key => Graph node -> (node -> key) -> M.Map key [key]
378 allReachable (Graph g from _) conv = M.fromList [(conv (from v), IS.foldr (\k vs -> conv (from k) : vs) [] vs) | (v, vs) <- IM.toList int_graph]
379 where
380 int_graph = reachableGraph g
381
382 hasVertexG :: Graph node -> node -> Bool
383 hasVertexG graph node = isJust $ gr_node_to_vertex graph node
384
385 verticesG :: Graph node -> [node]
386 verticesG graph = map (gr_vertex_to_node graph) $ vertices (gr_int_graph graph)
387
388 edgesG :: Graph node -> [Edge node]
389 edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ edges (gr_int_graph graph)
390 where v2n = gr_vertex_to_node graph
391
392 transposeG :: Graph node -> Graph node
393 transposeG graph = Graph (G.transposeG (gr_int_graph graph))
394 (gr_vertex_to_node graph)
395 (gr_node_to_vertex graph)
396
397 emptyG :: Graph node -> Bool
398 emptyG g = graphEmpty (gr_int_graph g)
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 = concatMap 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 reachableGraph :: IntGraph -> IM.IntMap IS.IntSet
452 reachableGraph g = res
453 where
454 do_one v = IS.unions (IS.fromList (g ! v) : mapMaybe (flip IM.lookup res) (g ! v))
455 res = IM.fromList [(v, do_one v) | v <- vertices g]
456
457 {-
458 ************************************************************************
459 * *
460 * Classify Edge Types
461 * *
462 ************************************************************************
463 -}
464
465 -- Remark: While we could generalize this algorithm this comes at a runtime
466 -- cost and with no advantages. If you find yourself using this with graphs
467 -- not easily represented using Int nodes please consider rewriting this
468 -- using the more general Graph type.
469
470 -- | Edge direction based on DFS Classification
471 data EdgeType
472 = Forward
473 | Cross
474 | Backward -- ^ Loop back towards the root node.
475 -- Eg backjumps in loops
476 | SelfLoop -- ^ v -> v
477 deriving (Eq,Ord)
478
479 instance Outputable EdgeType where
480 ppr Forward = text "Forward"
481 ppr Cross = text "Cross"
482 ppr Backward = text "Backward"
483 ppr SelfLoop = text "SelfLoop"
484
485 newtype Time = Time Int deriving (Eq,Ord,Num,Outputable)
486
487 --Allow for specialization
488 {-# INLINEABLE classifyEdges #-}
489
490 -- | Given a start vertex, a way to get successors from a node
491 -- and a list of (directed) edges classify the types of edges.
492 classifyEdges :: forall key. Uniquable key => key -> (key -> [key])
493 -> [(key,key)] -> [((key, key), EdgeType)]
494 classifyEdges root getSucc edges =
495 --let uqe (from,to) = (getUnique from, getUnique to)
496 --in pprTrace "Edges:" (ppr $ map uqe edges) $
497 zip edges $ map classify edges
498 where
499 (_time, starts, ends) = addTimes (0,emptyUFM,emptyUFM) root
500 classify :: (key,key) -> EdgeType
501 classify (from,to)
502 | startFrom < startTo
503 , endFrom > endTo
504 = Forward
505 | startFrom > startTo
506 , endFrom < endTo
507 = Backward
508 | startFrom > startTo
509 , endFrom > endTo
510 = Cross
511 | getUnique from == getUnique to
512 = SelfLoop
513 | otherwise
514 = pprPanic "Failed to classify edge of Graph"
515 (ppr (getUnique from, getUnique to))
516
517 where
518 getTime event node
519 | Just time <- lookupUFM event node
520 = time
521 | otherwise
522 = pprPanic "Failed to classify edge of CFG - not not timed"
523 (text "edges" <> ppr (getUnique from, getUnique to)
524 <+> ppr starts <+> ppr ends )
525 startFrom = getTime starts from
526 startTo = getTime starts to
527 endFrom = getTime ends from
528 endTo = getTime ends to
529
530 addTimes :: (Time, UniqFM key Time, UniqFM key Time) -> key
531 -> (Time, UniqFM key Time, UniqFM key Time)
532 addTimes (time,starts,ends) n
533 --Dont reenter nodes
534 | elemUFM n starts
535 = (time,starts,ends)
536 | otherwise =
537 let
538 starts' = addToUFM starts n time
539 time' = time + 1
540 succs = getSucc n :: [key]
541 (time'',starts'',ends') = foldl' addTimes (time',starts',ends) succs
542 ends'' = addToUFM ends' n time''
543 in
544 (time'' + 1, starts'', ends'')