Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2017 Matthew Fluet. |
2 | * Copyright (C) 1999-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh | |
3 | * Jagannathan, and Stephen Weeks. | |
4 | * | |
5 | * MLton is released under a BSD-style license. | |
6 | * See the file MLton-LICENSE for details. | |
7 | *) | |
8 | ||
9 | structure DirectedGraph:> DIRECTED_GRAPH = | |
10 | struct | |
11 | ||
12 | structure Types = | |
13 | struct | |
14 | datatype node = Node of {successors: edge list ref, | |
15 | plist: PropertyList.t} | |
16 | and edge = Edge of {from: node, | |
17 | to: node, | |
18 | plist: PropertyList.t} | |
19 | end | |
20 | ||
21 | structure Edge = | |
22 | struct | |
23 | datatype t = datatype Types.edge | |
24 | ||
25 | local | |
26 | fun make sel (Edge r) = sel r | |
27 | in | |
28 | val from = make #from | |
29 | val plist = make #plist | |
30 | val to = make #to | |
31 | end | |
32 | end | |
33 | ||
34 | structure Node = | |
35 | struct | |
36 | type edge = Types.edge | |
37 | datatype t = datatype Types.node | |
38 | ||
39 | fun layout _ = Layout.str "node" | |
40 | ||
41 | fun successors (Node {successors, ...}) = !successors | |
42 | fun plist (Node {plist, ...}) = plist | |
43 | ||
44 | fun new () = Node {successors = ref [], | |
45 | plist = PropertyList.new ()} | |
46 | ||
47 | fun equals (n, n') = PropertyList.equals (plist n, plist n') | |
48 | ||
49 | fun hasEdge {from, to} = | |
50 | List.exists (successors from, fn e => equals (to, Edge.to e)) | |
51 | ||
52 | fun removeDuplicateSuccessors (Node {successors, ...}) = | |
53 | let | |
54 | val {get, rem, ...} = | |
55 | Property.get (plist, Property.initFun (fn _ => ref false)) | |
56 | val es = | |
57 | List.fold (! successors, [], fn (e, ac) => | |
58 | let | |
59 | val r = get (Edge.to e) | |
60 | in | |
61 | if !r | |
62 | then ac | |
63 | else (r := true ; e :: ac) | |
64 | end) | |
65 | val () = List.foreach (es, rem o Edge.to) | |
66 | val () = successors := es | |
67 | in | |
68 | () | |
69 | end | |
70 | end | |
71 | ||
72 | structure Edge = | |
73 | struct | |
74 | structure Node = Node | |
75 | ||
76 | open Edge | |
77 | ||
78 | fun new {from, to} = | |
79 | Edge {from = from, | |
80 | to = to, | |
81 | plist = PropertyList.new ()} | |
82 | ||
83 | fun equals (e, e') = PropertyList.equals (plist e, plist e') | |
84 | ||
85 | fun layout e = | |
86 | Layout.record [("from", Node.layout (from e)), | |
87 | ("to", Node.layout (to e))] | |
88 | end | |
89 | ||
90 | (*---------------------------------------------------*) | |
91 | (* graph datatype *) | |
92 | (*---------------------------------------------------*) | |
93 | ||
94 | datatype t = T of {nodes: Node.t list ref} | |
95 | ||
96 | fun coerce g = (g, {edge = fn e => e, | |
97 | node = fn n => n}) | |
98 | ||
99 | fun nodes (T {nodes, ...}) = !nodes | |
100 | ||
101 | fun foldNodes (g, a, f) = List.fold (nodes g, a, f) | |
102 | ||
103 | val numNodes = List.length o nodes | |
104 | ||
105 | fun removeDuplicateEdges (g: t): unit = | |
106 | List.foreach (nodes g, Node.removeDuplicateSuccessors) | |
107 | ||
108 | fun new () = T {nodes = ref []} | |
109 | ||
110 | fun newNode (T {nodes, ...}) = | |
111 | let val n = Node.new () | |
112 | in List.push (nodes, n) | |
113 | ; n | |
114 | end | |
115 | ||
116 | fun removeNode (T {nodes, ...}, n) = | |
117 | let | |
118 | fun nodePred n' = Node.equals (n, n') | |
119 | fun edgePred (Edge.Edge {to = n', ...}) = nodePred n' | |
120 | val _ = | |
121 | nodes := List.removeAll (!nodes, nodePred) | |
122 | val _ = | |
123 | List.foreach | |
124 | (!nodes, fn Node.Node {successors, ...} => | |
125 | successors := List.removeAll (!successors, edgePred)) | |
126 | in | |
127 | () | |
128 | end | |
129 | ||
130 | fun addEdge (_, e as {from = Node.Node {successors, ...}, ...}) = | |
131 | let | |
132 | val e = Edge.new e | |
133 | val () = List.push (successors, e) | |
134 | in | |
135 | e | |
136 | end | |
137 | fun addEdge' arg = ignore (addEdge arg) | |
138 | ||
139 | fun layoutDot (T {nodes, ...}, | |
140 | mkOptions: | |
141 | {nodeName: Node.t -> string} | |
142 | -> {edgeOptions: Edge.t -> Dot.EdgeOption.t list, | |
143 | nodeOptions: Node.t -> Dot.NodeOption.t list, | |
144 | options: Dot.GraphOption.t list, | |
145 | title: string}): Layout.t = | |
146 | let | |
147 | val ns = !nodes | |
148 | val c = Counter.new 0 | |
149 | val {get = nodeId, rem, ...} = | |
150 | Property.get | |
151 | (Node.plist, | |
152 | Property.initFun | |
153 | (fn _ => concat ["n", Int.toString (Counter.next c)])) | |
154 | val {edgeOptions, nodeOptions, options, title} = | |
155 | mkOptions {nodeName = nodeId} | |
156 | val nodes = | |
157 | List.revMap | |
158 | (ns, fn n as Node.Node {successors, ...} => | |
159 | {name = nodeId n, | |
160 | options = nodeOptions n, | |
161 | successors = List.revMap (!successors, fn e => | |
162 | {name = nodeId (Edge.to e), | |
163 | options = edgeOptions e})}) | |
164 | val res = | |
165 | Dot.layout {nodes = nodes, | |
166 | options = options, | |
167 | title = title} | |
168 | val _ = List.foreach (ns, rem) | |
169 | in | |
170 | res | |
171 | end | |
172 | ||
173 | (*--------------------------------------------------------*) | |
174 | (* Depth-First Search *) | |
175 | (*--------------------------------------------------------*) | |
176 | ||
177 | structure DfsParam = | |
178 | struct | |
179 | type ('a, 'b, 'c, 'd, 'e) t = | |
180 | 'b | |
181 | * (Node.t * 'b | |
182 | -> ('c | |
183 | * (Node.t * 'c -> ('d | |
184 | * (Edge.t * 'd -> 'd) | |
185 | * (Edge.t * 'd -> 'c * ('e -> 'd)) | |
186 | * ('d -> 'e))) | |
187 | * ('e -> 'b))) | |
188 | type ('a, 'b) u = ('a, 'b, 'b, 'b, 'b) t | |
189 | ||
190 | fun startFinishNode (a: 'a, | |
191 | start: Node.t * 'a -> 'a, | |
192 | finish: Node.t * 'a -> 'a): ('b, 'a) u = | |
193 | (a, | |
194 | fn (_, a) => (a, | |
195 | fn (n, a) => | |
196 | let | |
197 | val a = start (n, a) | |
198 | in | |
199 | (a, #2, fn (_, a) => (a, fn a => a), | |
200 | fn a => finish (n, a)) | |
201 | end, | |
202 | fn a => a)) | |
203 | ||
204 | fun finishNode (f: Node.t -> unit) = | |
205 | startFinishNode ((), fn _ => (), f o #1) | |
206 | ||
207 | fun startNode (f: Node.t -> unit) = | |
208 | startFinishNode ((), f o #1, fn _ => ()) | |
209 | ||
210 | fun discoverFinishTimes () = | |
211 | let | |
212 | val {get = discover, set = setDiscover, | |
213 | destroy = destroyDiscover, ...} = | |
214 | Property.destGetSetOnce | |
215 | (Node.plist, Property.initRaise ("discover", Node.layout)) | |
216 | val {get = finish, set = setFinish, destroy = destroyFinish, ...} = | |
217 | Property.destGetSetOnce | |
218 | (Node.plist, Property.initRaise ("finish", Node.layout)) | |
219 | in | |
220 | (startFinishNode (0: int, | |
221 | fn (n, t) => (setDiscover (n, t); t + 1), | |
222 | fn (n, t) => (setFinish (n, t); t + 1)), | |
223 | {destroy = fn () => (destroyDiscover (); destroyFinish ()), | |
224 | discover = discover, | |
225 | finish = finish}) | |
226 | end | |
227 | end | |
228 | ||
229 | fun dfsNodes (_: t, | |
230 | ns: Node.t list, | |
231 | (b, f): ('a, 'b, 'c, 'd, 'e) DfsParam.t) = | |
232 | let | |
233 | type info = {hasBeenVisited: bool ref} | |
234 | val {get = nodeInfo: Node.t -> info, destroy, ...} = | |
235 | Property.destGetSet (Node.plist, | |
236 | Property.initFun (fn _ => | |
237 | {hasBeenVisited = ref false})) | |
238 | val b = | |
239 | List.fold | |
240 | (ns, b, fn (n, b) => | |
241 | let | |
242 | val info as {hasBeenVisited} = nodeInfo n | |
243 | in | |
244 | if !hasBeenVisited | |
245 | then b | |
246 | else | |
247 | let | |
248 | val (c, startNode, finishTree) = f (n, b) | |
249 | fun visit (n: Node.t, {hasBeenVisited}: info, c: 'c): 'e = | |
250 | let | |
251 | val _ = hasBeenVisited := true | |
252 | val (d, nonTreeEdge, treeEdge, finishNode) = | |
253 | startNode (n, c) | |
254 | in | |
255 | finishNode | |
256 | (List.fold | |
257 | (Node.successors n, d, | |
258 | fn (e, d) => | |
259 | let | |
260 | val n = Edge.to e | |
261 | val info as {hasBeenVisited} = nodeInfo n | |
262 | in | |
263 | if !hasBeenVisited | |
264 | then nonTreeEdge (e, d) | |
265 | else | |
266 | let | |
267 | val (c, finish) = treeEdge (e, d) | |
268 | in | |
269 | finish (visit (n, info, c)) | |
270 | end | |
271 | end)) | |
272 | end | |
273 | in | |
274 | finishTree (visit (n, info, c)) | |
275 | end | |
276 | end) | |
277 | val _ = destroy () | |
278 | in | |
279 | b | |
280 | end | |
281 | ||
282 | fun dfs (g, z) = dfsNodes (g, nodes g, z) | |
283 | ||
284 | fun dfsForest (g, {roots: Node.t vector, nodeValue: Node.t -> 'a}) : 'a Tree.t vector = | |
285 | (Vector.fromList o dfsNodes) | |
286 | (g, Vector.toList roots, | |
287 | ([], fn (_, trees) => | |
288 | let | |
289 | fun startNode (n, ()) = | |
290 | let | |
291 | fun nonTree (_, ts) = ts | |
292 | fun tree (_, ts) = ((), fn t => t :: ts) | |
293 | fun finish ts = Tree.T (nodeValue n, Vector.fromList ts) | |
294 | in | |
295 | ([], nonTree, tree, finish) | |
296 | end | |
297 | fun finishTree t = t :: trees | |
298 | in | |
299 | ((), startNode, finishTree) | |
300 | end)) | |
301 | ||
302 | fun dfsTree (g, {root, nodeValue}) = | |
303 | let | |
304 | val ts = dfsForest (g, {roots = Vector.new1 root, nodeValue = nodeValue}) | |
305 | in | |
306 | if Vector.length ts = 1 | |
307 | then Vector.sub (ts, 0) | |
308 | else Error.bug "DirectedGraph.dfsTree" | |
309 | end | |
310 | ||
311 | fun display {graph, layoutNode, display} = | |
312 | dfs (graph, | |
313 | DfsParam.startNode | |
314 | (fn n => | |
315 | display let open Layout | |
316 | in seq [layoutNode n, | |
317 | str " ", | |
318 | list (List.revMap (Node.successors n, | |
319 | layoutNode o Edge.to))] | |
320 | end)) | |
321 | ||
322 | fun foreachDescendent (g, n, f) = | |
323 | dfsNodes (g, [n], DfsParam.finishNode f) | |
324 | ||
325 | fun foreachNode (g, f) = List.foreach (nodes g, f) | |
326 | ||
327 | fun foreachEdge (g, edge) = | |
328 | foreachNode (g, fn n as Node.Node {successors, ...} => | |
329 | List.foreach (!successors, fn e => edge (n, e))) | |
330 | ||
331 | (*--------------------------------------------------------*) | |
332 | (* Dominators *) | |
333 | (*--------------------------------------------------------*) | |
334 | ||
335 | fun validDominators (graph, | |
336 | {root: Node.t, | |
337 | idom: Node.t -> Node.t}): bool = | |
338 | (* Check for each edge v --> w that idom w dominates v. | |
339 | * FIXME: It should first check that idom describes a tree rooted at root. | |
340 | *) | |
341 | Exn.withEscape | |
342 | (fn escape => | |
343 | let | |
344 | fun dominates (a: Node.t, b: Node.t): bool = | |
345 | let | |
346 | fun loop b = | |
347 | Node.equals (a, b) | |
348 | orelse (not (Node.equals (b, root)) | |
349 | andalso loop (idom b)) | |
350 | in loop b | |
351 | end | |
352 | val _ = | |
353 | foreachEdge (graph, fn (_, Edge.Edge {from, to, ...}) => | |
354 | if dominates (idom to, from) | |
355 | then () | |
356 | else escape false) | |
357 | in true | |
358 | end) | |
359 | ||
360 | val _ = validDominators | |
361 | ||
362 | datatype 'a idomRes = | |
363 | Idom of Node.t | |
364 | | Root | |
365 | | Unreachable | |
366 | ||
367 | (* This is an implementation of the simple and fast dominance algorithm | |
368 | * described in | |
369 | * | |
370 | * A Simple, Fast Dominance Algorithm. | |
371 | * Keith Cooper and Timothy Harvey and Ken Kennedy. | |
372 | * Software Practice and Experience, 2001. | |
373 | * http://citeseer.ist.psu.edu/cooper01simple.html | |
374 | * http://www.cs.rice.edu/~keith/EMBED/dom.pdf | |
375 | * | |
376 | * This implementation replaced the previous implementation based on the | |
377 | * Lengauer/Tarjan algorithm, as described on p. 185-191 of Muchnick's | |
378 | * "Advanced Compiler Design and Implementation", and appears to run in | |
379 | * less than half the time on a self compile and took about half the | |
380 | * amount of code to implement. | |
381 | *) | |
382 | fun dominators (graph, {root}) = | |
383 | let | |
384 | val unknown = ~2 | |
385 | val visiting = ~1 | |
386 | ||
387 | val {get = getNum, set = setNum, rem = remNum, ...} = | |
388 | Property.getSet (Node.plist, Property.initConst unknown) | |
389 | ||
390 | val nodes = Array.array (numNodes graph, root) | |
391 | fun node i = Array.sub (nodes, i) | |
392 | ||
393 | fun dfs (n, v) = | |
394 | (setNum (v, visiting) | |
395 | ; case List.fold | |
396 | (Node.successors v, n, fn (Edge.Edge {to, ...}, n) => | |
397 | if getNum to = unknown then dfs (n, to) else n) of | |
398 | n => (setNum (v, n) ; Array.update (nodes, n, v) ; n+1)) | |
399 | val numNodes = dfs (0, root) | |
400 | ||
401 | val preds = Array.array (numNodes, []) | |
402 | fun addPred (t, f) = Array.update (preds, t, f :: Array.sub (preds, t)) | |
403 | ||
404 | val () = Int.for (0, numNodes, fn i => | |
405 | List.foreach (Node.successors (node i), | |
406 | fn Edge.Edge {to, ...} => addPred (getNum to, i))) | |
407 | ||
408 | val () = Array.foreach (nodes, remNum) | |
409 | ||
410 | val idoms = Array.array (numNodes, unknown) | |
411 | fun idom i = Array.sub (idoms, i) | |
412 | fun setIdom (i, d) = Array.update (idoms, i, d) | |
413 | ||
414 | val rootNum = numNodes-1 | |
415 | val () = setIdom (rootNum, rootNum) | |
416 | ||
417 | fun intersect (n1, n2) = | |
418 | if n1 = n2 | |
419 | then n1 | |
420 | else | |
421 | let | |
422 | fun up (f, t) = if f < t then up (idom f, t) else f | |
423 | val n1 = up (n1, n2) | |
424 | val n2 = up (n2, n1) | |
425 | in | |
426 | intersect (n1, n2) | |
427 | end | |
428 | ||
429 | fun iterate () = | |
430 | if Int.foldDown (0, rootNum, false, fn (i, changed) => let | |
431 | val new = | |
432 | case Array.sub (preds, i) of | |
433 | [] => raise Fail "bug" | |
434 | | p::ps => | |
435 | List.fold (ps, p, fn (j, new) => | |
436 | if idom j <> unknown then intersect (new, j) else new) | |
437 | in | |
438 | if idom i <> new then (setIdom (i, new) ; true) else changed | |
439 | end) | |
440 | then iterate () | |
441 | else () | |
442 | val () = iterate () | |
443 | ||
444 | val {get = idomFinal, set = setIdom, ...} = | |
445 | Property.getSetOnce (Node.plist, Property.initConst Unreachable) | |
446 | val () = setIdom (root, Root) | |
447 | val () = Int.for (0, rootNum, fn i => | |
448 | setIdom (node i, Idom (node (idom i)))) | |
449 | in | |
450 | {idom = idomFinal} | |
451 | end | |
452 | ||
453 | fun dominatorTree (graph, {root: Node.t, nodeValue: Node.t -> 'a}): 'a Tree.t = | |
454 | let | |
455 | val {idom} = dominators (graph, {root = root}) | |
456 | val {get = nodeInfo, ...} = | |
457 | Property.get (Node.plist, | |
458 | Property.initFun (fn n => {children = ref [], | |
459 | value = nodeValue n})) | |
460 | val _ = | |
461 | List.foreach | |
462 | (nodes graph, fn n => | |
463 | case idom n of | |
464 | Idom n' => List.push (#children (nodeInfo n'), n) | |
465 | | Root => () | |
466 | | Unreachable => ()) | |
467 | fun treeAt (n: Node.t): 'a Tree.t = | |
468 | let | |
469 | val {children, value} = nodeInfo n | |
470 | in | |
471 | Tree.T (value, Vector.fromListMap (!children, treeAt)) | |
472 | end | |
473 | in | |
474 | treeAt root | |
475 | end | |
476 | ||
477 | fun ignoreNodes (g: t, shouldIgnore: Node.t -> bool) | |
478 | : t * {destroy: unit -> unit, | |
479 | newNode: Node.t -> Node.t} = | |
480 | let | |
481 | val g' = new () | |
482 | val {destroy, get = newNode, ...} = | |
483 | Property.destGet (Node.plist, | |
484 | Property.initFun (fn _ => newNode g')) | |
485 | (* reach n is the set of non-ignored nodes that n reaches via | |
486 | * nonempty paths through ignored nodes. It is computed by starting | |
487 | * at each node and doing a DFS that only goes through ignored nodes. | |
488 | *) | |
489 | val {get = reach: Node.t -> Node.t list, ...} = | |
490 | Property.get | |
491 | (Node.plist, | |
492 | Property.initFun | |
493 | (fn root => | |
494 | let | |
495 | val r = ref [] | |
496 | val {destroy, get = seen, ...} = | |
497 | Property.destGet (Node.plist, | |
498 | Property.initFun (fn _ => ref false)) | |
499 | fun loop n = | |
500 | List.foreach (Node.successors n, fn e => | |
501 | let | |
502 | val n = Edge.to e | |
503 | val s = seen n | |
504 | in | |
505 | if !s | |
506 | then () | |
507 | else | |
508 | (s := true | |
509 | ; if shouldIgnore n | |
510 | then loop n | |
511 | else List.push (r, n)) | |
512 | end) | |
513 | val _ = loop root | |
514 | val _ = destroy () | |
515 | in | |
516 | !r | |
517 | end)) | |
518 | val _ = | |
519 | foreachNode | |
520 | (g, fn n => | |
521 | if shouldIgnore n | |
522 | then () | |
523 | else | |
524 | let | |
525 | val from = newNode n | |
526 | in | |
527 | List.foreach | |
528 | (reach n, fn to => | |
529 | addEdge' (g', {from = from, to = newNode to})) | |
530 | end) | |
531 | in | |
532 | (g', {destroy = destroy, | |
533 | newNode = newNode}) | |
534 | end | |
535 | ||
536 | (*--------------------------------------------------------*) | |
537 | (* Loop Forest *) | |
538 | (*--------------------------------------------------------*) | |
539 | ||
540 | (* This is an implementation of the G. Ramalingam loop forest construction, | |
541 | * as described in "On Loops, Dominators, and Dominance Frontiers" | |
542 | * (originally in PLDI00; revised technical report at | |
543 | * http://www.research.ibm.com/people/r/rama/Papers/ibmtr21513.revised.ps). | |
544 | *) | |
545 | ||
546 | structure LoopForest = | |
547 | struct | |
548 | (* Every node in the graph will appear exactly once in a notInLoop | |
549 | * vector in the loop forest. | |
550 | * Every node that is a loop header will appear in exactly one headers | |
551 | * vector. | |
552 | *) | |
553 | datatype t = T of {loops: {headers: Node.t vector, | |
554 | child: t} vector, | |
555 | notInLoop: Node.t vector} | |
556 | ||
557 | fun single n = T {loops = Vector.new0 (), | |
558 | notInLoop = Vector.new1 n} | |
559 | ||
560 | fun layoutDot (forest: t, | |
561 | {nodeName: Node.t -> string, | |
562 | options: Dot.GraphOption.t list, | |
563 | title: string}) = | |
564 | let | |
565 | open Dot | |
566 | fun label (ns, max) = | |
567 | let | |
568 | val pred = | |
569 | case max of | |
570 | NONE => (fn _ => true) | |
571 | | SOME max => (fn (i, _) => i < max) | |
572 | fun loop ns = | |
573 | let | |
574 | val {no = ms, yes = ns} = Vector.partitioni (ns, pred) | |
575 | val ns = String.concatWith (Vector.toListMap (ns, nodeName), ", ") | |
576 | in | |
577 | if Vector.isEmpty ms | |
578 | then [(ns, Center)] | |
579 | else (ns, Center)::(loop ms) | |
580 | end | |
581 | in | |
582 | NodeOption.Label (loop ns) | |
583 | end | |
584 | val c = Counter.new 0 | |
585 | fun newName () = concat ["n", Int.toString (Counter.next c)] | |
586 | val nodes = ref [] | |
587 | fun loop (T {loops, notInLoop}, root) = | |
588 | let | |
589 | val ms = | |
590 | Vector.fold | |
591 | (loops, [], fn ({headers, child}, ac) => | |
592 | let | |
593 | val n = newName () | |
594 | val _ = | |
595 | List.push | |
596 | (nodes, {name = n, | |
597 | options = [label (headers, SOME 5), | |
598 | NodeOption.Shape Ellipse], | |
599 | successors = | |
600 | List.map (loop (child, false), fn n => | |
601 | {name = n, options = []})}) | |
602 | in | |
603 | n :: ac | |
604 | end) | |
605 | val n = newName () | |
606 | val (max, successors) = | |
607 | if root | |
608 | then (SOME 10, | |
609 | case ms of | |
610 | [] => [] | |
611 | | m :: _ => [{name = m, | |
612 | options = [EdgeOption.Style Invisible]}]) | |
613 | else (SOME 5, []) | |
614 | val _ = List.push (nodes, {name = n, | |
615 | options = [label (notInLoop, max), | |
616 | NodeOption.Shape Box], | |
617 | successors = successors}) | |
618 | in | |
619 | n :: (List.rev ms) | |
620 | end | |
621 | val ns = loop (forest, true) | |
622 | val options = | |
623 | case ns of | |
624 | [] => options | |
625 | | _ :: ns => | |
626 | (GraphOption.Rank (Same, List.map (ns, fn n => {nodeName = n}))) | |
627 | :: options | |
628 | in | |
629 | Dot.layout {nodes = !nodes, | |
630 | options = options, | |
631 | title = title} | |
632 | end | |
633 | val _ = layoutDot | |
634 | end | |
635 | ||
636 | (* Strongly connected components from Aho, Hopcroft, Ullman section 5.5. *) | |
637 | ||
638 | fun stronglyConnectedComponents (g: t): Node.t list list = | |
639 | let | |
640 | val {get = nodeInfo: Node.t -> {dfnumber: int, | |
641 | isOnStack: bool ref, | |
642 | lowlink: int ref}, | |
643 | set = setNodeInfo, destroy, ...} = | |
644 | Property.destGetSetOnce (Node.plist, | |
645 | Property.initRaise ("scc info", Node.layout)) | |
646 | fun startNode (n, (count, stack, components)) = | |
647 | let | |
648 | val dfnumber = count | |
649 | val count = count + 1 | |
650 | val lowlink = ref dfnumber | |
651 | val stack = n :: stack | |
652 | val isOnStack = ref true | |
653 | val v = {dfnumber = dfnumber, | |
654 | isOnStack = isOnStack, | |
655 | lowlink = lowlink} | |
656 | val _ = setNodeInfo (n, v) | |
657 | fun nonTreeEdge (e, z) = | |
658 | let | |
659 | val w = nodeInfo (Edge.to e) | |
660 | val _ = | |
661 | if #dfnumber w < #dfnumber v | |
662 | andalso !(#isOnStack w) | |
663 | andalso #dfnumber w < !(#lowlink v) | |
664 | then #lowlink v := #dfnumber w | |
665 | else () | |
666 | in | |
667 | z | |
668 | end | |
669 | fun treeEdge (e, z) = | |
670 | (z, | |
671 | fn z => | |
672 | let | |
673 | val w = nodeInfo (Edge.to e) | |
674 | val _ = | |
675 | if !(#lowlink w) < !(#lowlink v) | |
676 | then #lowlink v := !(#lowlink w) | |
677 | else () | |
678 | in | |
679 | z | |
680 | end) | |
681 | fun finishNode (count, stack, components) = | |
682 | if !lowlink = dfnumber | |
683 | then | |
684 | let | |
685 | fun popTo (stack, ac) = | |
686 | case stack of | |
687 | [] => Error.bug "DirectedGraph.stronglyConnectedComponents.finishNode.popTo" | |
688 | | n' :: stack => | |
689 | let | |
690 | val _ = #isOnStack (nodeInfo n') := false | |
691 | val ac = n' :: ac | |
692 | in | |
693 | if Node.equals (n, n') | |
694 | then (stack, ac) | |
695 | else popTo (stack, ac) | |
696 | end | |
697 | val (stack, component) = popTo (stack, []) | |
698 | in | |
699 | (count, stack, component :: components) | |
700 | end | |
701 | else (count, stack, components) | |
702 | in | |
703 | ((count, stack, components), | |
704 | nonTreeEdge, | |
705 | treeEdge, | |
706 | finishNode) | |
707 | end | |
708 | val (_, _, components) = | |
709 | dfs (g, ((0, [], []), fn (_, z) => (z, startNode, fn z => z))) | |
710 | val _ = destroy () | |
711 | in | |
712 | components | |
713 | end | |
714 | ||
715 | val stronglyConnectedComponents = | |
716 | if true | |
717 | then stronglyConnectedComponents | |
718 | else | |
719 | let | |
720 | val c = Counter.new 0 | |
721 | in | |
722 | fn g => | |
723 | let | |
724 | val nodeCounter = Counter.new 0 | |
725 | val {get = nodeIndex: Node.t -> int, destroy, ...} = | |
726 | Property.destGet | |
727 | (Node.plist, | |
728 | Property.initFun (fn _ => Counter.next nodeCounter)) | |
729 | val index = Counter.next c | |
730 | val _ = | |
731 | File.withOut | |
732 | (concat ["graph", Int.toString index, ".dot"], fn out => | |
733 | Layout.output | |
734 | (layoutDot (g, fn _ => | |
735 | {edgeOptions = fn _ => [], | |
736 | nodeOptions = fn n => [Dot.NodeOption.label | |
737 | (Int.toString (nodeIndex n))], | |
738 | options = [], | |
739 | title = "scc graph"}), | |
740 | out)) | |
741 | val ns = stronglyConnectedComponents g | |
742 | val _ = | |
743 | File.withOut | |
744 | (concat ["scc", Int.toString index], fn out => | |
745 | Layout.outputl | |
746 | (List.layout (List.layout (Int.layout o nodeIndex)) ns, | |
747 | out)) | |
748 | val _ = destroy () | |
749 | in | |
750 | ns | |
751 | end | |
752 | end | |
753 | ||
754 | (* This code assumes everything is reachable from the root. | |
755 | * Otherwise it may loop forever. | |
756 | *) | |
757 | fun loopForestSteensgaard (g: t, {root: Node.t}): LoopForest.t = | |
758 | let | |
759 | val {get = | |
760 | nodeInfo: | |
761 | Node.t -> {class: int ref, | |
762 | isHeader: bool ref, | |
763 | (* The corresponding node in the next subgraph. *) | |
764 | next: Node.t option ref, | |
765 | (* The corresponding node in the original graph. *) | |
766 | original: Node.t}, | |
767 | set = setNodeInfo, | |
768 | rem = remNodeInfo, ...} = | |
769 | Property.getSet | |
770 | (Node.plist, Property.initRaise ("loopForestSteensgaard", Node.layout)) | |
771 | fun newNodeInfo (n, original) = | |
772 | setNodeInfo (n, {class = ref ~1, | |
773 | isHeader = ref false, | |
774 | next = ref NONE, | |
775 | original = original}) | |
776 | val _ = List.foreach (nodes g, fn n => newNodeInfo (n, n)) | |
777 | (* Treat the root as though there is an external edge into it. *) | |
778 | val _ = #isHeader (nodeInfo root) := true | |
779 | (* Before calling treeFor, nodeInfo must be defined for all nodes in g. *) | |
780 | fun treeFor (g: t): LoopForest.t = | |
781 | let | |
782 | val sccs = stronglyConnectedComponents g | |
783 | (* Put nodes in the same scc into the same class. *) | |
784 | val _ = List.foreachi | |
785 | (sccs, fn (i, ns) => | |
786 | List.foreach | |
787 | (ns, fn n => | |
788 | #class (nodeInfo n) := i)) | |
789 | (* Set nodes to be headers if they are the target of an edge whose | |
790 | * source is in another scc. | |
791 | * This is a bit of an abuse of terminology, since it also marks | |
792 | * as headers nodes that are in their own trivial (one node) scc. | |
793 | *) | |
794 | val _ = | |
795 | List.foreach | |
796 | (nodes g, fn n => | |
797 | let | |
798 | val {class = ref class, ...} = nodeInfo n | |
799 | val _ = | |
800 | List.foreach | |
801 | (Node.successors n, fn e => | |
802 | let | |
803 | val {class = ref class', isHeader, ...} = | |
804 | nodeInfo (Edge.to e) | |
805 | in | |
806 | if class = class' | |
807 | then () | |
808 | else isHeader := true | |
809 | end) | |
810 | in | |
811 | () | |
812 | end) | |
813 | (* Accumulate the subtrees. *) | |
814 | val loops = ref [] | |
815 | val notInLoop = ref [] | |
816 | val _ = | |
817 | List.foreach | |
818 | (sccs, fn ns => | |
819 | case ns of | |
820 | [n] => | |
821 | let | |
822 | val {original, ...} = nodeInfo n | |
823 | in | |
824 | if List.exists (Node.successors n, fn e => | |
825 | Node.equals (n, Edge.to e)) | |
826 | then | |
827 | List.push (loops, | |
828 | {headers = Vector.new1 original, | |
829 | child = LoopForest.single original}) | |
830 | else List.push (notInLoop, original) | |
831 | end | |
832 | | _ => | |
833 | let | |
834 | (* Build a new subgraph of the component, sans edges | |
835 | * that go into headers. | |
836 | *) | |
837 | val g' = new () | |
838 | val headers = ref [] | |
839 | (* Create all the new nodes. *) | |
840 | val _ = | |
841 | List.foreach | |
842 | (ns, fn n => | |
843 | let | |
844 | val {next, original, ...} = nodeInfo n | |
845 | val n' = newNode g' | |
846 | val _ = next := SOME n' | |
847 | val _ = newNodeInfo (n', original) | |
848 | in | |
849 | () | |
850 | end) | |
851 | (* Add all the edges. *) | |
852 | val _ = | |
853 | List.foreach | |
854 | (ns, fn from => | |
855 | let | |
856 | val {class = ref class, isHeader, next, | |
857 | original, ...} = nodeInfo from | |
858 | val from' = valOf (!next) | |
859 | val _ = | |
860 | if !isHeader | |
861 | then List.push (headers, original) | |
862 | else () | |
863 | in | |
864 | List.foreach | |
865 | (Node.successors from, fn e => | |
866 | let | |
867 | val to = Edge.to e | |
868 | val {class = ref class', | |
869 | isHeader = isHeader', | |
870 | next = next', ...} = nodeInfo to | |
871 | in | |
872 | if class = class' | |
873 | andalso not (!isHeader') | |
874 | then addEdge' (g', {from = from', | |
875 | to = valOf (!next')}) | |
876 | else () | |
877 | end) | |
878 | end) | |
879 | (* We're done with the old graph, so delete the | |
880 | * nodeInfo. | |
881 | *) | |
882 | val _ = List.foreach (ns, remNodeInfo) | |
883 | val headers = Vector.fromList (!headers) | |
884 | val child = treeFor g' | |
885 | in | |
886 | List.push (loops, {child = child, | |
887 | headers = headers}) | |
888 | end) | |
889 | in | |
890 | LoopForest.T {loops = Vector.fromList (!loops), | |
891 | notInLoop = Vector.fromList (!notInLoop)} | |
892 | end | |
893 | in | |
894 | treeFor g | |
895 | end | |
896 | ||
897 | fun quotient (g, vs) = | |
898 | let | |
899 | val numClasses = Vector.length vs | |
900 | val {destroy, get = nodeClass: Node.t -> int, set = setNodeClass, ...} = | |
901 | Property.destGetSetOnce (Node.plist, | |
902 | Property.initRaise ("newNode", Node.layout)) | |
903 | val g' = new () | |
904 | val newNodes = | |
905 | Vector.mapi (vs, fn (i, v) => | |
906 | let | |
907 | val n' = newNode g' | |
908 | val _ = | |
909 | Vector.foreach (v, fn n => setNodeClass (n, i)) | |
910 | in | |
911 | n' | |
912 | end) | |
913 | val successors = Array.array (numClasses, []) | |
914 | val _ = | |
915 | foreachNode | |
916 | (g, fn n => | |
917 | let | |
918 | val class = nodeClass n | |
919 | in | |
920 | Array.update | |
921 | (successors, class, | |
922 | List.fold (Node.successors n, | |
923 | Array.sub (successors, class), | |
924 | fn (e, ac) => nodeClass (Edge.to e) :: ac)) | |
925 | end) | |
926 | (* Eliminate duplicates from successor lists and add the graph edges. *) | |
927 | val hasIt = Array.array (numClasses, false) | |
928 | val _ = | |
929 | Array.foreachi | |
930 | (successors, fn (i, cs) => | |
931 | let | |
932 | val from = Vector.sub (newNodes, i) | |
933 | val _ = | |
934 | List.foreach | |
935 | (cs, fn c => | |
936 | if Array.sub (hasIt, c) | |
937 | then () | |
938 | else (Array.update (hasIt, c, true) | |
939 | ; addEdge' (g', {from = from, | |
940 | to = Vector.sub (newNodes, c)}))) | |
941 | val _ = | |
942 | List.foreach (cs, fn c => Array.update (hasIt, c, false)) | |
943 | in | |
944 | () | |
945 | end) | |
946 | fun newNode n = Vector.sub (newNodes, nodeClass n) | |
947 | in | |
948 | (g', {destroy = destroy, | |
949 | newNode = newNode}) | |
950 | end | |
951 | ||
952 | fun subgraph (g: t, keep: Node.t -> bool) = | |
953 | let | |
954 | val sub = new () | |
955 | val {get = newNode, destroy, ...} = | |
956 | Property.destGet (Node.plist, | |
957 | Property.initFun (fn _ => newNode sub)) | |
958 | val _ = foreachNode (g, fn from => | |
959 | if not (keep from) | |
960 | then () | |
961 | else | |
962 | List.foreach | |
963 | (Node.successors from, | |
964 | let | |
965 | val from = newNode from | |
966 | in | |
967 | fn e => | |
968 | let | |
969 | val to = Edge.to e | |
970 | in | |
971 | if keep to | |
972 | then | |
973 | addEdge' (sub, {from = from, | |
974 | to = newNode to}) | |
975 | else () | |
976 | end | |
977 | end)) | |
978 | in | |
979 | (sub, {destroy = destroy, | |
980 | newNode = newNode}) | |
981 | end | |
982 | ||
983 | fun topologicalSort (g: t): Node.t list option = | |
984 | let | |
985 | exception Cycle | |
986 | val {get = amVisiting, destroy, ...} = | |
987 | Property.destGet (Node.plist, Property.initFun (fn _ => ref false)) | |
988 | fun doit () = | |
989 | dfs (g, | |
990 | ([], fn (_, ns) => | |
991 | let | |
992 | fun startNode (n, ns) = | |
993 | let | |
994 | fun nonTree (e, ns) = | |
995 | if !(amVisiting (Edge.to e)) | |
996 | then raise Cycle | |
997 | else ns | |
998 | fun tree (_, ns) = (ns, fn ns => ns) | |
999 | fun finish ns = n :: ns | |
1000 | in | |
1001 | (ns, nonTree, tree, finish) | |
1002 | end | |
1003 | fun finishTree ns = ns | |
1004 | in | |
1005 | (ns, startNode, finishTree) | |
1006 | end)) | |
1007 | val res = SOME (doit ()) handle Cycle => NONE | |
1008 | val _ = destroy () | |
1009 | in | |
1010 | res | |
1011 | end | |
1012 | ||
1013 | fun transpose (g: t) = | |
1014 | let | |
1015 | val transpose = new () | |
1016 | val {get = newNode, destroy, ...} = | |
1017 | Property.destGet (Node.plist, | |
1018 | Property.initFun (fn _ => newNode transpose)) | |
1019 | val _ = foreachNode (g, fn to => | |
1020 | List.foreach | |
1021 | (Node.successors to, | |
1022 | let | |
1023 | val to = newNode to | |
1024 | in | |
1025 | fn e => | |
1026 | addEdge' (transpose, {from = newNode (Edge.to e), | |
1027 | to = to}) | |
1028 | end)) | |
1029 | in | |
1030 | (transpose, {destroy = destroy, | |
1031 | newNode = newNode}) | |
1032 | end | |
1033 | ||
1034 | val transpose = | |
1035 | if true | |
1036 | then transpose | |
1037 | else | |
1038 | let | |
1039 | val c = Counter.new 0 | |
1040 | in | |
1041 | fn g => | |
1042 | let | |
1043 | val nodeCounter = Counter.new 0 | |
1044 | val {get = nodeIndex: Node.t -> int, destroy, ...} = | |
1045 | Property.destGet | |
1046 | (Node.plist, | |
1047 | Property.initFun (fn _ => Counter.next nodeCounter)) | |
1048 | val index = Counter.next c | |
1049 | val _ = | |
1050 | File.withOut | |
1051 | (concat ["graph", Int.toString index, ".dot"], fn out => | |
1052 | Layout.output | |
1053 | (layoutDot (g, fn _ => | |
1054 | {edgeOptions = fn _ => [], | |
1055 | nodeOptions = fn n => [Dot.NodeOption.label | |
1056 | (Int.toString (nodeIndex n))], | |
1057 | options = [], | |
1058 | title = "transpose graph"}), | |
1059 | out)) | |
1060 | val z as (g, _) = transpose g | |
1061 | val _ = | |
1062 | File.withOut | |
1063 | (concat ["transpose", Int.toString index, ".dot"], fn out => | |
1064 | Layout.output | |
1065 | (layoutDot (g, fn _ => | |
1066 | {edgeOptions = fn _ => [], | |
1067 | nodeOptions = fn n => [Dot.NodeOption.label | |
1068 | (Int.toString (nodeIndex n))], | |
1069 | options = [], | |
1070 | title = "transpose graph"}), | |
1071 | out)) | |
1072 | val _ = destroy () | |
1073 | in | |
1074 | z | |
1075 | end | |
1076 | end | |
1077 | ||
1078 | structure Node = | |
1079 | struct | |
1080 | open Node | |
1081 | ||
1082 | type 'a t = t | |
1083 | type 'a edge = edge | |
1084 | end | |
1085 | ||
1086 | structure Edge = | |
1087 | struct | |
1088 | open Edge | |
1089 | ||
1090 | type 'a t = t | |
1091 | end | |
1092 | ||
1093 | type 'a t = t | |
1094 | type 'a u = unit | |
1095 | ||
1096 | structure LoopForest = | |
1097 | struct | |
1098 | open LoopForest | |
1099 | type 'a t = t | |
1100 | ||
1101 | fun dest (T r) = r | |
1102 | end | |
1103 | ||
1104 | end |