Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh |
2 | * Jagannathan, and Stephen Weeks. | |
3 | * | |
4 | * MLton is released under a BSD-style license. | |
5 | * See the file MLton-LICENSE for details. | |
6 | *) | |
7 | ||
8 | structure DirectedSubGraph: DIRECTED_SUB_GRAPH = | |
9 | struct | |
10 | ||
11 | structure Types = | |
12 | struct | |
13 | datatype node = Node of {successors: edge list ref, | |
14 | plist: PropertyList.t} | |
15 | and edge = Edge of {from: node, | |
16 | to: node, | |
17 | plist: PropertyList.t} | |
18 | and graph = T of {nodes: node list ref, | |
19 | nodeP: node -> bool, | |
20 | edgeP: edge -> bool} | |
21 | end | |
22 | ||
23 | structure Edge = | |
24 | struct | |
25 | datatype graph = datatype Types.graph | |
26 | type node = Types.node | |
27 | datatype t = datatype Types.edge | |
28 | ||
29 | fun layout _ = Layout.str "edge" | |
30 | ||
31 | local | |
32 | fun make sel (Edge r) = sel r | |
33 | in | |
34 | val from = make #from | |
35 | val plist = make #plist | |
36 | val to = make #to | |
37 | end | |
38 | val from = fn (T {nodeP, edgeP, ...}, e) => | |
39 | (Assert.assert("DirectedSubGraph.Edge.from", fn () => edgeP e) | |
40 | ; Assert.assert("DirectedSubGraph.Edge.from", fn () => nodeP (from e)) | |
41 | ; from e) | |
42 | val to = fn (T {nodeP, edgeP, ...}, e) => | |
43 | (Assert.assert("DirectedSubGraph.Edge.to", fn () => edgeP e) | |
44 | ; Assert.assert("DirectedSubGraph.Edge.to", fn () => nodeP (to e)) | |
45 | ; to e) | |
46 | ||
47 | fun new (T {nodeP, edgeP, ...}, {from, to}) = | |
48 | (Assert.assert("DirectedSubGraph.Edge.new", fn () => nodeP from) | |
49 | ; Assert.assert("DirectedSubGraph.Edge.new", fn () => nodeP to) | |
50 | ; Edge {from = from, | |
51 | to = to, | |
52 | plist = PropertyList.new ()}) | |
53 | ||
54 | fun equals (e, e') = PropertyList.equals (plist e, plist e') | |
55 | end | |
56 | ||
57 | structure Node = | |
58 | struct | |
59 | datatype graph = datatype Types.graph | |
60 | type edge = Types.edge | |
61 | datatype t = datatype Types.node | |
62 | ||
63 | fun layout _ = Layout.str "node" | |
64 | ||
65 | local | |
66 | fun make sel (Node r) = sel r | |
67 | in | |
68 | val plist = make #plist | |
69 | val successors' = make #successors | |
70 | val successors = ! o successors' | |
71 | end | |
72 | val foreachSuccessor = fn (T {nodeP, edgeP, ...}, n, f) => | |
73 | (Assert.assert("DirectedSubGraph.Node.foreachSuccessor", fn () => nodeP n) | |
74 | ; List.foreach(successors n, fn e => if edgeP e then f e else ())) | |
75 | val forallSuccessors = fn (T {nodeP, edgeP, ...}, n, f) => | |
76 | (Assert.assert("DirectedSubGraph.Node.forallSuccessors", fn () => nodeP n) | |
77 | ; List.forall(successors n, fn e => if edgeP e then f e else true)) | |
78 | val existsSuccessor = fn (T {nodeP, edgeP, ...}, n, f) => | |
79 | (Assert.assert("DirectedSubGraph.Node.existsSuccessor", fn () => nodeP n) | |
80 | ; List.exists(successors n, fn e => if edgeP e then f e else false)) | |
81 | val successors = fn (T {nodeP, edgeP, ...}, n) => | |
82 | (Assert.assert("DirectedSubGraph.Node.successors", fn () => nodeP n) | |
83 | ; List.keepAll(successors n, fn e => edgeP e)) | |
84 | ||
85 | ||
86 | fun new g = Node {successors = ref [], | |
87 | plist = PropertyList.new ()} | |
88 | ||
89 | fun equals (n, n') = PropertyList.equals (plist n, plist n') | |
90 | ||
91 | fun hasEdge (g as T {nodeP, edgeP, ...}, {from, to}) = | |
92 | if nodeP from andalso nodeP to | |
93 | then existsSuccessor (g, from, fn e => | |
94 | equals (to, Edge.to (g, e))) | |
95 | else false | |
96 | ||
97 | (* fun removeSuccessor (Node {successors, ...}, n) = | |
98 | * successors := List.removeFirst (!successors, fn Edge.Edge {to, ...} => | |
99 | * equals (n, to)) | |
100 | *) | |
101 | end | |
102 | ||
103 | structure DfsParam = | |
104 | struct | |
105 | type t = {startNode: Node.t -> unit, | |
106 | finishNode: Node.t -> unit, | |
107 | handleTreeEdge: Edge.t -> unit, | |
108 | handleNonTreeEdge: Edge.t -> unit, | |
109 | startTree: Node.t -> unit, | |
110 | finishTree: Node.t -> unit, | |
111 | finishDfs: unit -> unit} | |
112 | ||
113 | fun ignore _ = () | |
114 | ||
115 | fun finishNode f = {finishNode = f, | |
116 | startNode = ignore, | |
117 | handleTreeEdge = ignore, | |
118 | handleNonTreeEdge = ignore, | |
119 | startTree = ignore, | |
120 | finishTree = ignore, | |
121 | finishDfs = ignore} | |
122 | ||
123 | fun startNode f = {finishNode = ignore, | |
124 | startNode = f, | |
125 | handleTreeEdge = ignore, | |
126 | handleNonTreeEdge = ignore, | |
127 | startTree = ignore, | |
128 | finishTree = ignore, | |
129 | finishDfs = ignore} | |
130 | ||
131 | fun seq f g a = (f a; g a) | |
132 | ||
133 | fun combine ({startNode, finishNode, | |
134 | handleTreeEdge, handleNonTreeEdge, | |
135 | startTree, finishTree, finishDfs}: t, | |
136 | {startNode = sn, finishNode = fin, | |
137 | handleTreeEdge = ht, handleNonTreeEdge = hn, | |
138 | startTree = st, finishTree = ft, finishDfs = fd}: t): t = | |
139 | {startNode = seq startNode sn, | |
140 | finishNode = seq finishNode fin, | |
141 | handleTreeEdge = seq handleTreeEdge ht, | |
142 | handleNonTreeEdge = seq handleNonTreeEdge hn, | |
143 | startTree = seq startTree st, | |
144 | finishTree = seq finishTree ft, | |
145 | finishDfs = seq finishDfs fd} | |
146 | end | |
147 | ||
148 | (*---------------------------------------------------*) | |
149 | (* graph datatype *) | |
150 | (*---------------------------------------------------*) | |
151 | ||
152 | datatype t = datatype Types.graph | |
153 | ||
154 | (*--------------------------------------------------------*) | |
155 | (* Foreach *) | |
156 | (*--------------------------------------------------------*) | |
157 | ||
158 | (* | |
159 | fun foreachNode (g, f) = List.foreach (nodes g, f) | |
160 | *) | |
161 | ||
162 | fun foreachNode (g as T {nodes, nodeP, ...}, f) | |
163 | = List.foreach (!nodes, fn n => if nodeP n then f n else ()) | |
164 | ||
165 | (* | |
166 | fun foreachEdge (g, f) = | |
167 | foreachNode (g, fn n => List.foreach (Node.successors (g, n), fn e => f (n, e))) | |
168 | *) | |
169 | ||
170 | fun foreachEdge (g, f) = | |
171 | foreachNode (g, fn n => Node.foreachSuccessor (g, n, fn e => f (n, e))) | |
172 | ||
173 | (*--------------------------------------------------------*) | |
174 | (* subGraphs *) | |
175 | (*--------------------------------------------------------*) | |
176 | ||
177 | fun subGraph (g as T {nodes, nodeP, edgeP, ...}, | |
178 | {nodeP = nodeP', edgeP = edgeP'}) = | |
179 | let | |
180 | val nodeP = fn n => if nodeP n then nodeP' n else false | |
181 | val edgeP = fn e => if edgeP e then edgeP' e else false | |
182 | val _ = | |
183 | Assert.assert | |
184 | ("DirectedSubGraph.subGraph", fn () => | |
185 | List.forall(!nodes, fn n => | |
186 | if nodeP n | |
187 | then Node.forallSuccessors(g, n, fn e => | |
188 | nodeP (Edge.to (g, e))) | |
189 | else true)) | |
190 | in | |
191 | T {nodes = nodes, nodeP = nodeP, edgeP = edgeP} | |
192 | end | |
193 | ||
194 | fun supGraph (g as T {nodes, ...}) = | |
195 | T {nodes = nodes, nodeP = fn _ => true, edgeP = fn _ => true} | |
196 | ||
197 | fun nodes (T {nodes, nodeP, ...}) = List.keepAll(!nodes, nodeP) | |
198 | ||
199 | fun new () = T {nodes = ref [], nodeP = fn _ => true, edgeP = fn _ => true} | |
200 | ||
201 | fun newNode (g as T {nodes, ...}) = | |
202 | let val n = Node.new g | |
203 | in List.push (nodes, n) | |
204 | ; n | |
205 | end | |
206 | ||
207 | fun addEdge (g as T {nodeP, ...}, e as {from, to}) = | |
208 | let val _ = Assert.assert("DirectedSubGraph.addEdge", fn () => nodeP from andalso nodeP to) | |
209 | val e = Edge.new (g, e) | |
210 | in | |
211 | List.push (Node.successors' from, e) | |
212 | ; e | |
213 | end | |
214 | ||
215 | (*fun removeEdge (_, {from, to}) = Node.removeSuccessor (from, to) *) | |
216 | ||
217 | fun layoutDot (g, {edgeOptions: Edge.t -> Dot.EdgeOption.t list, | |
218 | nodeOptions: Node.t -> Dot.NodeOption.t list, | |
219 | options, | |
220 | title}): Layout.t = | |
221 | let | |
222 | val c = Counter.new 0 | |
223 | val {get = nodeId, destroy, ...} = | |
224 | Property.destGet | |
225 | (Node.plist, | |
226 | Property.initFun | |
227 | (fn _ => concat ["n", Int.toString (Counter.next c)])) | |
228 | val nodes = | |
229 | List.revMap | |
230 | (nodes g, | |
231 | fn n => {name = nodeId n, | |
232 | options = nodeOptions n, | |
233 | successors = List.revMap | |
234 | (Node.successors (g, n), fn e => | |
235 | {name = nodeId (Edge.to (g, e)), | |
236 | options = edgeOptions e})}) | |
237 | val res = | |
238 | Dot.layout {nodes = nodes, | |
239 | options = options, | |
240 | title = title} | |
241 | val _ = destroy () | |
242 | in | |
243 | res | |
244 | end | |
245 | ||
246 | (*--------------------------------------------------------*) | |
247 | (* Depth-First Search *) | |
248 | (*--------------------------------------------------------*) | |
249 | ||
250 | fun dfsNodes (g as T {nodeP, ...}, ns, | |
251 | {startNode, finishNode, | |
252 | handleTreeEdge, handleNonTreeEdge, | |
253 | startTree, finishTree, finishDfs}) = | |
254 | let | |
255 | val {get = hasBeenVisited, set = setVisited, destroy, ...} = | |
256 | Property.destGetSet (Node.plist, Property.initConst false) | |
257 | fun visit n = | |
258 | (Assert.assert("DirectedSubGraph.dfsNodes", fn () => nodeP n) | |
259 | ; startNode n | |
260 | ; setVisited (n, true) | |
261 | ; Node.foreachSuccessor (g, n, fn e => | |
262 | let val n' = Edge.to (g, e) | |
263 | in if hasBeenVisited n' | |
264 | then handleNonTreeEdge e | |
265 | else (visit n'; handleTreeEdge e) | |
266 | end) | |
267 | ; finishNode n) | |
268 | in List.foreach (ns, fn n => | |
269 | (Assert.assert("DirectedSubGraph.dfsNodes", fn () => nodeP n) | |
270 | ; if hasBeenVisited n | |
271 | then () | |
272 | else (startTree n; visit n; finishTree n))) | |
273 | ; destroy () | |
274 | ; finishDfs () | |
275 | end | |
276 | ||
277 | fun dfs (g, p) = dfsNodes (g, nodes g, p) | |
278 | ||
279 | fun display {graph, layoutNode, display} = | |
280 | dfs (graph, | |
281 | DfsParam.startNode | |
282 | (fn n => | |
283 | display let open Layout | |
284 | in seq [layoutNode n, | |
285 | str " ", | |
286 | list (List.revMap (Node.successors (graph, n), | |
287 | fn e => layoutNode (Edge.to (graph, e))))] | |
288 | end)) | |
289 | ||
290 | fun foreachDescendent (g, n, f) = | |
291 | dfsNodes (g, [n], DfsParam.finishNode f) | |
292 | ||
293 | (* fun removeBackEdges g = | |
294 | * let | |
295 | * val discoverTime = Counter.new 0 | |
296 | * val {get, destroy, ...} = | |
297 | * Property.newDest | |
298 | * (Node.plist, Property.initFun (fn _ => {time = Counter.next discoverTime, | |
299 | * alive = ref true})) | |
300 | * val ignore = DfsParam.ignore | |
301 | * in dfs | |
302 | * (g, {startNode = fn n => (get n; ()), | |
303 | * finishNode = fn n => #alive (get n) := false, | |
304 | * handleNonTreeEdge = | |
305 | * fn e as Edge.Edge {from, to, ...} => | |
306 | * let val {alive, time} = get to | |
307 | * in if !alive andalso time < #time (get from) | |
308 | * then removeEdge (g, e) | |
309 | * else () | |
310 | * end, | |
311 | * handleTreeEdge = ignore, | |
312 | * startTree = ignore, | |
313 | * finishTree = ignore, | |
314 | * finishDfs = ignore}) | |
315 | * end | |
316 | *) | |
317 | ||
318 | (*--------------------------------------------------------*) | |
319 | (* Times *) | |
320 | (*--------------------------------------------------------*) | |
321 | ||
322 | fun discoverFinishTimes g = | |
323 | let val time: int ref = ref 0 | |
324 | val {get = discover, set = setDiscover, destroy = destroyDiscover, ...} = | |
325 | Property.destGetSetOnce (Node.plist, | |
326 | Property.initRaise ("discover", Node.layout)) | |
327 | val {get = finish, set = setFinish, destroy = destroyFinish, ...} = | |
328 | Property.destGetSetOnce (Node.plist, | |
329 | Property.initRaise ("finish", Node.layout)) | |
330 | in {destroy = fn () => (destroyDiscover (); destroyFinish ()), | |
331 | discover = discover, | |
332 | finish = finish, | |
333 | param = {startNode = fn n => (Int.inc time; setDiscover (n, !time)), | |
334 | finishNode = fn n => (Int.inc time; setFinish (n, !time)), | |
335 | handleTreeEdge = DfsParam.ignore, | |
336 | handleNonTreeEdge = DfsParam.ignore, | |
337 | startTree = DfsParam.ignore, | |
338 | finishTree = DfsParam.ignore, | |
339 | finishDfs = DfsParam.ignore}} | |
340 | end | |
341 | ||
342 | (*--------------------------------------------------------*) | |
343 | (* Random *) | |
344 | (*--------------------------------------------------------*) | |
345 | (* | |
346 | fun maxNumEdges n = n * (n - 1) | |
347 | ||
348 | fun random {numNodes,numEdges} = | |
349 | let val max = maxNumEdges numNodes | |
350 | in if numNodes < 0 orelse numEdges < 0 orelse numEdges > max | |
351 | then Error.error "random" | |
352 | else let val g = new () | |
353 | val needed = ref numEdges | |
354 | val remaining = ref max | |
355 | fun maybeAddEdge (n,n') = | |
356 | (if Int.random (1, !remaining) <= !needed | |
357 | then (addEdge (g, Node.fromInt n, Node.fromInt n') | |
358 | ; IntRef.dec needed) | |
359 | else () | |
360 | ; IntRef.dec remaining) | |
361 | val minNode = 0 | |
362 | val maxNode = numNodes - 1 | |
363 | fun directed n = | |
364 | Int.foreach (0, maxNode, fn n' => | |
365 | if n = n' then () else maybeAddEdge (n,n')) | |
366 | fun undirected n = | |
367 | Int.foreach (n + 1, maxNode, fn n' => maybeAddEdge (n,n')) | |
368 | val addEdges = if isDirected then directed | |
369 | else undirected | |
370 | in Int.foreach (minNode, maxNode, addEdges) | |
371 | ; g | |
372 | end | |
373 | end | |
374 | *) | |
375 | (*--------------------------------------------------------*) | |
376 | (* Cycle *) | |
377 | (*--------------------------------------------------------*) | |
378 | (* | |
379 | fun cycleParam g = | |
380 | let val {get = isActive, set = setActive} = | |
381 | nodeInfo (g, fn _ => false) | |
382 | val cycle = ref false | |
383 | in (cycle, {startNode = fn n => setActive (n, true), | |
384 | finishNode = fn n => setActive (n, false), | |
385 | handleNonTreeEdge = | |
386 | fn (n, e) => let val n' = Edge.otherNode (e,n) | |
387 | in if isActive n' then cycle := true | |
388 | else () | |
389 | end, | |
390 | handleTreeEdge = DfsParam.ignore, | |
391 | startTree = DfsParam.ignore, | |
392 | finishTree = DfsParam.ignore, | |
393 | finishDfs = DfsParam.ignore}) | |
394 | end | |
395 | ||
396 | fun isCyclic g = let val (cycle, p) = cycleParam g | |
397 | in dfs (g, p); !cycle | |
398 | end | |
399 | *) | |
400 | ||
401 | (*--------------------------------------------------------*) | |
402 | (* Topological Sort *) | |
403 | (*--------------------------------------------------------*) | |
404 | ||
405 | exception TopologicalSort | |
406 | ||
407 | fun topSortParam g = | |
408 | let | |
409 | val {get = amVisiting, set = setVisiting, destroy, ...} = | |
410 | Property.destGetSet (Node.plist, | |
411 | Property.initRaise ("visiting", Node.layout)) | |
412 | val ns = ref [] | |
413 | in (ns, {startNode = fn n => amVisiting n := true, | |
414 | finishNode = fn n => (amVisiting n := false; List.push (ns,n)), | |
415 | handleNonTreeEdge = fn e => if !(amVisiting(Edge.to (g, e))) | |
416 | then raise TopologicalSort | |
417 | else (), | |
418 | startTree = DfsParam.ignore, finishTree = DfsParam.ignore, | |
419 | handleTreeEdge = DfsParam.ignore, | |
420 | finishDfs = destroy}) | |
421 | end | |
422 | ||
423 | fun topologicalSort g = let val (ns, p) = topSortParam g | |
424 | in dfs (g, p); !ns | |
425 | end | |
426 | ||
427 | (*--------------------------------------------------------*) | |
428 | (* Transpose *) | |
429 | (*--------------------------------------------------------*) | |
430 | (* | |
431 | fun transposeParam g = | |
432 | let val gt = new () | |
433 | fun handleEdge (n, e) = let val n' = Edge.otherNode (e,n) | |
434 | in addEdge (gt,n',n); () | |
435 | end | |
436 | in (gt, {handleTreeEdge = handleEdge, | |
437 | handleNonTreeEdge = handleEdge, | |
438 | finishDfs = DfsParam.ignore, | |
439 | startNode = DfsParam.ignore, finishNode = DfsParam.ignore, | |
440 | startTree = DfsParam.ignore, finishTree = DfsParam.ignore}) | |
441 | end | |
442 | ||
443 | fun transpose g = let val (gt, p) = transposeParam g | |
444 | in dfs (g, p); gt | |
445 | end | |
446 | *) | |
447 | (*--------------------------------------------------------*) | |
448 | (* Strongly Connected Components *) | |
449 | (*--------------------------------------------------------*) | |
450 | ||
451 | (* from Cormen, Leiserson, and Rivest 23.5 *) | |
452 | (* | |
453 | fun sccCLR g = | |
454 | let | |
455 | val (gt, p) = transposeParam g | |
456 | val ns = ref [] | |
457 | val p' = P.finishNode (fn n => List.push (ns,n)) | |
458 | val components = ref [] | |
459 | val component = ref [] | |
460 | fun startNode n = List.push (component,n) | |
461 | fun startTree _ = component := [] | |
462 | fun finishTree _ = List.push (components, !component) | |
463 | val pt = {startNode = startNode, | |
464 | startTree = startTree, | |
465 | finishTree = finishTree, | |
466 | finishNode = DfsParam.ignore, | |
467 | finishDfs = DfsParam.ignore, | |
468 | handleTreeEdge = DfsParam.ignore, | |
469 | handleNonTreeEdge = DfsParam.ignore} | |
470 | in dfs (g, P.combine (p, p')) | |
471 | ; dfsNodes (gt, !ns, pt) | |
472 | ; !components | |
473 | end | |
474 | *) | |
475 | ||
476 | (* from Aho, Hopcroft, Ullman section 5.5 *) | |
477 | ||
478 | fun stronglyConnectedComponents g = | |
479 | let | |
480 | val {get = discover: Node.t -> int, set = setDiscover, | |
481 | destroy = destroyDiscover, ...} = | |
482 | Property.destGetSetOnce (Node.plist, | |
483 | Property.initRaise ("discover", Node.layout)) | |
484 | val {get = low: Node.t -> int ref, destroy = destroyLow, ...} = | |
485 | Property.destGet (Node.plist, Property.initFun (fn _ => ref ~1)) | |
486 | val {get = isOnStack: Node.t -> bool, set = setOnStack, | |
487 | destroy = destroyStack, ...} = | |
488 | Property.destGetSet (Node.plist, | |
489 | Property.initRaise ("isOnStack", Node.layout)) | |
490 | val stack = ref [] | |
491 | val components = ref [] | |
492 | val time = ref 0 | |
493 | fun pop () = let val n = List.pop stack | |
494 | in setOnStack (n, false); n | |
495 | end | |
496 | fun popTo n = let fun popTo () = let val n' = pop () | |
497 | in if Node.equals (n,n') then [n] | |
498 | else n' :: (popTo ()) | |
499 | end | |
500 | in popTo () | |
501 | end | |
502 | fun startNode n = (Int.inc time | |
503 | ; setDiscover (n, !time) | |
504 | ; low n := !time | |
505 | ; setOnStack (n, true) | |
506 | ; List.push (stack, n)) | |
507 | fun finishNode n = if discover n = ! (low n) | |
508 | then List.push (components, popTo n) | |
509 | else () | |
510 | fun updateLow e = | |
511 | let val from = Edge.from (g, e) | |
512 | val to = Edge.to (g, e) | |
513 | val lto = low to | |
514 | val lfrom = low from | |
515 | in if !lto < !lfrom | |
516 | then lfrom := !lto | |
517 | else () | |
518 | end | |
519 | val handleTreeEdge = updateLow | |
520 | fun handleNonTreeEdge e = | |
521 | if isOnStack (Edge.to (g, e)) | |
522 | then updateLow e | |
523 | else () | |
524 | val p = {startNode = startNode, finishNode = finishNode, | |
525 | handleTreeEdge = handleTreeEdge, | |
526 | handleNonTreeEdge = handleNonTreeEdge, | |
527 | startTree = DfsParam.ignore, finishTree = DfsParam.ignore, | |
528 | finishDfs = DfsParam.ignore} | |
529 | in dfs (g, p) | |
530 | ; destroyLow () | |
531 | ; destroyStack () | |
532 | ; destroyDiscover () | |
533 | ; !components | |
534 | end | |
535 | ||
536 | (*--------------------------------------------------------*) | |
537 | (* Dominators *) | |
538 | (*--------------------------------------------------------*) | |
539 | ||
540 | (* This is an implementation of the Lengauer/Tarjan dominator algorithm, as | |
541 | * described on p. 185-191 of Muchnick's "Advanced Compiler Design and | |
542 | * Implementation" | |
543 | *) | |
544 | structure NodeInfo = | |
545 | struct | |
546 | type t = {ancestor: Node.t ref, | |
547 | bucket: Node.t list ref, | |
548 | child: Node.t ref, | |
549 | dfn: int ref, (* depth first number *) | |
550 | idom: Node.t ref, | |
551 | label: Node.t ref, | |
552 | parent: Node.t ref, | |
553 | preds: Node.t list ref, | |
554 | sdno: int ref, (* semidominator dfn *) | |
555 | size: int ref} | |
556 | end | |
557 | ||
558 | fun validDominators (graph, | |
559 | {root: Node.t, | |
560 | idom: Node.t -> Node.t}): bool = | |
561 | (* Check for each edge v --> w that idom w dominates v. | |
562 | * FIXME: It should first check that idom describes a tree rooted at root. | |
563 | *) | |
564 | Exn.withEscape | |
565 | (fn escape => | |
566 | let | |
567 | fun dominates (a: Node.t, b: Node.t): bool = | |
568 | let | |
569 | fun loop b = | |
570 | Node.equals (a, b) | |
571 | orelse (not (Node.equals (b, root)) | |
572 | andalso loop (idom b)) | |
573 | in loop b | |
574 | end | |
575 | val _ = | |
576 | foreachEdge (graph, fn (_, Edge.Edge {from, to, ...}) => | |
577 | if dominates (idom to, from) | |
578 | then () | |
579 | else escape false) | |
580 | in true | |
581 | end) | |
582 | ||
583 | fun dominators (graph, {root}) = | |
584 | let | |
585 | val n0 = Node.new () | |
586 | fun newNode (n: Node.t): NodeInfo.t = | |
587 | {ancestor = ref n0, | |
588 | bucket = ref [], | |
589 | child = ref n0, | |
590 | dfn = ref ~1, | |
591 | idom = ref n0, | |
592 | label = ref n, | |
593 | parent = ref n0, | |
594 | preds = ref [], | |
595 | sdno = ref ~1, | |
596 | size = ref 1} | |
597 | val {get = nodeInfo: Node.t -> NodeInfo.t, ...} = | |
598 | Property.get (Node.plist, Property.initFun newNode) | |
599 | local | |
600 | fun 'a make (sel: NodeInfo.t -> 'a ref) = | |
601 | (sel o nodeInfo, ! o sel o nodeInfo) | |
602 | in | |
603 | val (ancestor', ancestor) = make #ancestor | |
604 | val (bucket', bucket) = make #bucket | |
605 | val (child', child) = make #child | |
606 | val (dfn', dfn) = make #dfn | |
607 | val (idom', idom) = make #idom | |
608 | val (label', label) = make #label | |
609 | val (parent', parent) = make #parent | |
610 | val (preds', preds) = make #preds | |
611 | val (sdno', sdno) = make #sdno | |
612 | val (size', size) = make #size | |
613 | end | |
614 | val _ = size' n0 := 0 | |
615 | (* nodes is an array of nodes indexed by dfs number. *) | |
616 | val numNodes = List.length (nodes graph) | |
617 | val nodes = Array.new (numNodes, n0) | |
618 | fun ndfs i = Array.sub (nodes, i) | |
619 | val dfnCounter = ref 0 | |
620 | fun dfs (v: Node.t): unit = | |
621 | let | |
622 | val i = !dfnCounter | |
623 | val _ = Int.inc dfnCounter | |
624 | val _ = dfn' v := i | |
625 | val _ = sdno' v := i | |
626 | val _ = Array.update (nodes, i, v) | |
627 | val _ = | |
628 | Node.foreachSuccessor | |
629 | (graph, v, fn e => | |
630 | let | |
631 | val w = Edge.to (graph, e) | |
632 | val _ = List.push (preds' w, v) | |
633 | in if sdno w = ~1 | |
634 | then (parent' w := v | |
635 | ; dfs w) | |
636 | else () | |
637 | end) | |
638 | in () | |
639 | end | |
640 | val _ = dfs root | |
641 | val _ = | |
642 | if !dfnCounter = numNodes | |
643 | then () | |
644 | else Error.bug "DirectedSubGraph.dominators: graph is not connected" | |
645 | (* compress ancestor path to node v to the node whose label has the | |
646 | * maximal (minimal?) semidominator number. | |
647 | *) | |
648 | fun compress (v: Node.t): unit = | |
649 | if Node.equals (n0, ancestor (ancestor v)) | |
650 | then () | |
651 | else let | |
652 | val _ = compress (ancestor v) | |
653 | val _ = | |
654 | if sdno (label (ancestor v)) < sdno (label v) | |
655 | then label' v := label (ancestor v) | |
656 | else () | |
657 | val _ = ancestor' v := ancestor (ancestor v) | |
658 | in () | |
659 | end | |
660 | fun eval (v: Node.t): Node.t = | |
661 | (* Determine the ancestor of v whose semidominator has the minimal | |
662 | * depth-first number. | |
663 | *) | |
664 | if Node.equals (ancestor v, n0) | |
665 | then label v | |
666 | else let | |
667 | val _ = compress v | |
668 | in | |
669 | if sdno (label (ancestor v)) >= sdno (label v) | |
670 | then label v | |
671 | else label (ancestor v) | |
672 | end | |
673 | fun link (v: Node.t, w: Node.t): unit = | |
674 | let | |
675 | fun loop s = | |
676 | if sdno (label w) < sdno (label (child s)) | |
677 | then | |
678 | if size s + size (child (child s)) >= 2 * size (child s) | |
679 | then (ancestor' (child s) := s | |
680 | ; child' s := child (child s) | |
681 | ; loop s) | |
682 | else (size' (child s) := size s | |
683 | ; ancestor' s := child s | |
684 | ; loop (child s)) | |
685 | else s | |
686 | val s = loop w | |
687 | val _ = label' s := label w | |
688 | val _ = size' v := size v + size w | |
689 | val s = | |
690 | if size v < 2 * size w | |
691 | then | |
692 | let | |
693 | val tmp = child v | |
694 | val _ = child' v := s | |
695 | in tmp | |
696 | end | |
697 | else s | |
698 | fun loop s = | |
699 | if Node.equals (s, n0) | |
700 | then () | |
701 | else (ancestor' s := v | |
702 | ; loop (child s)) | |
703 | val _ = loop s | |
704 | in () | |
705 | end | |
706 | val _ = | |
707 | Int.forDown | |
708 | (1, numNodes, fn i => | |
709 | let | |
710 | (* Compute initial values for semidominators and store nodes with | |
711 | * the same semidominator in the same bucket. | |
712 | *) | |
713 | val w = ndfs i | |
714 | val min = List.fold (preds w, sdno w, fn (n, min) => | |
715 | Int.min (min, sdno (eval n))) | |
716 | val _ = sdno' w := min | |
717 | val _ = List.push (bucket' (ndfs min), w) | |
718 | val _ = link (parent w, w) | |
719 | (* Compute immediate dominators for nodes in the bucket of w's | |
720 | * parent. | |
721 | *) | |
722 | val _ = | |
723 | List.foreach | |
724 | (bucket (parent w), fn v => | |
725 | let | |
726 | val u = eval v | |
727 | in | |
728 | idom' v := (if sdno u < sdno v | |
729 | then u | |
730 | else parent w) | |
731 | end) | |
732 | val _ = bucket' (parent w) := [] | |
733 | in () | |
734 | end) | |
735 | (* Adjust immediate dominators of nodes whose current version of the | |
736 | * immediate dominator differs from the node with the depth-first number | |
737 | * of the node's semidominator. | |
738 | *) | |
739 | val _ = | |
740 | Int.for | |
741 | (1, numNodes, fn i => | |
742 | let | |
743 | val w = ndfs i | |
744 | in | |
745 | if Node.equals (idom w, ndfs (sdno w)) | |
746 | then () | |
747 | else idom' w := idom (idom w) | |
748 | end) | |
749 | val _ = idom' root := root | |
750 | val _ = Assert.assert ("DirectedSubGraph.dominators", fn () => | |
751 | validDominators (graph, {root = root, | |
752 | idom = idom})) | |
753 | in {idom = idom} | |
754 | end | |
755 | ||
756 | fun dominatorTree (graph, {root: Node.t, nodeValue: Node.t -> 'a}): 'a Tree.t = | |
757 | let | |
758 | val {idom} = dominators (graph, {root = root}) | |
759 | val {get = nodeInfo, ...} = | |
760 | Property.get (Node.plist, | |
761 | Property.initFun (fn n => {children = ref [], | |
762 | value = nodeValue n})) | |
763 | val _ = | |
764 | foreachNode | |
765 | (graph, fn n => | |
766 | if Node.equals (n, root) | |
767 | then () | |
768 | else List.push (#children (nodeInfo (idom n)), n)) | |
769 | fun treeAt (n: Node.t): 'a Tree.t = | |
770 | let | |
771 | val {children, value} = nodeInfo n | |
772 | in | |
773 | Tree.T (value, Vector.fromListMap (!children, treeAt)) | |
774 | end | |
775 | in | |
776 | treeAt root | |
777 | end | |
778 | ||
779 | (*--------------------------------------------------------*) | |
780 | (* Loop Forest *) | |
781 | (*--------------------------------------------------------*) | |
782 | ||
783 | (* This is an implementation of the G. Ramalingam loop forest construction, | |
784 | * as described in "On Loops, Dominators, and Dominance Frontiers" | |
785 | * (originally in PLDI00; revised technical report at | |
786 | * http://www.research.ibm.com/people/r/rama/Papers/ibmtr21513.revised.ps). | |
787 | *) | |
788 | ||
789 | structure GraphNodeInfo = | |
790 | struct | |
791 | type t = {forestNode: Node.t} | |
792 | end | |
793 | ||
794 | structure ForestNodeInfo = | |
795 | struct | |
796 | type t = {parent: Node.t option, | |
797 | loopNodes: Node.t list} | |
798 | end | |
799 | ||
800 | structure SubGraphNodeInfo = | |
801 | struct | |
802 | type t = {childSubGraphNode: Node.t option ref, | |
803 | graphNode: Node.t} | |
804 | end | |
805 | ||
806 | (* loopForest : {headers: (* graph *) Node.t list -> (* graph *) Node.t list, | |
807 | * graph: t, | |
808 | * root: (* graph *) Node.t} | |
809 | * -> {forest: t, | |
810 | * graphToForest: (* graph *) Node.t -> (* forest *) Node.t, | |
811 | * loopNodes: (* forest *) Node.t -> (* graph *) Node.t list, | |
812 | * parent: (* forest *) Node.t -> (* forest *) Node.t option} | |
813 | * | |
814 | * Inputs: graph -- a rooted control flow graph | |
815 | * root -- the root of graph | |
816 | * headers -- a function mapping strongly connected components of graph | |
817 | * to a set of header nodes | |
818 | * Outputs: forest -- the loop nesting forest | |
819 | * "Consider any loop L. Let G_L denote the subgraph induced by | |
820 | * the vertices in L, but without the loopback edges of L. | |
821 | * The 'children' of L in the 'forest' representation are | |
822 | * the strongly connected components of G_L. The non-trivial | |
823 | * strongly connected components of G_L denote inner loops | |
824 | * (which become internal nodes in the 'forest' representation), | |
825 | * while the trivial strongly connected components of G_L | |
826 | * denote vertices belonging to L but not to any inner loop of L, | |
827 | * and these become 'leaves' of the 'forest'." | |
828 | * graphToForest -- maps a node in graph to it's corresponding leaf in forest | |
829 | * headers -- a function mapping strongly connected components of graph | |
830 | * to a set of header nodes; compose with loopNodes to get | |
831 | * the loop headers of an internal node in the forest | |
832 | * isHeader -- predicate indicating that the node is the header for some loop | |
833 | * loopNodes -- maps an internal node in the forest to a set of nodes | |
834 | * in graph that compose a loop | |
835 | * parent -- maps a node in forest to it's parent in forest | |
836 | *) | |
837 | ||
838 | (* | |
839 | fun loopForest {headers, graph, root} | |
840 | = let | |
841 | val addEdge = ignore o addEdge | |
842 | ||
843 | val {get = graphNodeInfo : Node.t -> GraphNodeInfo.t, | |
844 | set = setGraphNodeInfo, ...} | |
845 | = Property.getSetOnce | |
846 | (Node.plist, Property.initRaise ("graphNodeInfo", Node.layout)) | |
847 | val forestNode = #forestNode o graphNodeInfo | |
848 | ||
849 | val {get = forestNodeInfo : Node.t -> ForestNodeInfo.t, | |
850 | set = setForestNodeInfo, ...} | |
851 | = Property.getSetOnce | |
852 | (Node.plist, Property.initRaise ("forestNodeInfo", Node.layout)) | |
853 | val parent = #parent o forestNodeInfo | |
854 | val loopNodes = #loopNodes o forestNodeInfo | |
855 | ||
856 | ||
857 | val {get = nodeNesting: Node.t -> int list ref, | |
858 | destroy = destNodeNesting, ...} | |
859 | = Property.destGet | |
860 | (Node.plist, Property.initFun (fn _ => ref [])) | |
861 | val {get = edgeNesting: Edge.t -> int list ref, | |
862 | destroy = destEdgeNesting, ...} | |
863 | = Property.destGet | |
864 | (Edge.plist, Property.initFun (fn _ => ref [])) | |
865 | ||
866 | val {get = getIsHeader: Node.t -> bool ref, ...} | |
867 | = Property.get | |
868 | (Node.plist, Property.initFun (fn _ => ref false)) | |
869 | ||
870 | ||
871 | val F = new () | |
872 | ||
873 | ||
874 | val depth = ref 0 | |
875 | fun nodeP n = fn node => case !(nodeNesting node) | |
876 | of n'::_ => n' >= n | |
877 | | _ => false | |
878 | fun edgeP n = fn edge => case !(edgeNesting edge) | |
879 | of n'::_ => n' >= n | |
880 | | _ => false | |
881 | ||
882 | ||
883 | fun inducedGraph {graph, scc} | |
884 | = let | |
885 | val depth = !depth | |
886 | val headers = headers scc | |
887 | val _ = List.foreach(headers, fn header => getIsHeader header := true) | |
888 | in | |
889 | List.foreach | |
890 | (scc, | |
891 | fn n => (List.push(nodeNesting n, depth) ; | |
892 | Node.foreachSuccessor | |
893 | (graph, n, | |
894 | fn e => let | |
895 | val from = n | |
896 | val to = Edge.to (graph, e) | |
897 | in | |
898 | if List.contains(scc, to, Node.equals) | |
899 | andalso | |
900 | not (List.contains(headers, to, Node.equals)) | |
901 | then List.push(edgeNesting e, depth) | |
902 | else () | |
903 | end))) ; | |
904 | subGraph (supGraph graph, {nodeP = nodeP depth, edgeP = edgeP depth}) | |
905 | end | |
906 | ||
907 | fun nest {graph, parent} | |
908 | = List.foreach | |
909 | (stronglyConnectedComponents graph, | |
910 | fn scc => let | |
911 | val n' = newNode F | |
912 | fun default () | |
913 | = let | |
914 | val _ = setForestNodeInfo(n', {loopNodes = scc, | |
915 | parent = parent}) | |
916 | ||
917 | val _ = Int.inc depth | |
918 | val graph' = inducedGraph {graph = graph, | |
919 | scc = scc} | |
920 | val _ = nest {graph = graph', | |
921 | parent = SOME n'} | |
922 | val _ = foreachNode | |
923 | (graph', | |
924 | fn n => (Node.foreachSuccessor | |
925 | (graph', n, | |
926 | fn e => ignore(List.pop(edgeNesting e))); | |
927 | ignore(List.pop(nodeNesting n)))) | |
928 | val _ = Int.dec depth | |
929 | in | |
930 | () | |
931 | end | |
932 | ||
933 | fun default' n | |
934 | = let | |
935 | in | |
936 | setForestNodeInfo (n', {loopNodes = [n], | |
937 | parent = parent}) ; | |
938 | setGraphNodeInfo (n, {forestNode = n'}) | |
939 | end | |
940 | in | |
941 | case parent | |
942 | of NONE => () | |
943 | | SOME parent => addEdge (F, {from = parent, to = n'}) ; | |
944 | case scc | |
945 | of [n] => if Node.hasEdge (graph, {from = n, to = n}) | |
946 | then default () | |
947 | else default' n | |
948 | | scc => default () | |
949 | end) | |
950 | ||
951 | ||
952 | val depth = !depth | |
953 | val _ = foreachNode | |
954 | (graph, | |
955 | fn n => (List.push(nodeNesting n, depth) ; | |
956 | Node.foreachSuccessor | |
957 | (graph, n, fn e => List.push(edgeNesting e, depth)))) | |
958 | val graph' = subGraph (supGraph graph, | |
959 | {nodeP = nodeP depth, edgeP = edgeP depth}) | |
960 | val _ = nest {graph = graph', parent = NONE} | |
961 | val _ = destNodeNesting () | |
962 | val _ = destEdgeNesting () | |
963 | in | |
964 | {forest = F, | |
965 | graphToForest = forestNode, | |
966 | headers = headers, | |
967 | isHeader = ! o getIsHeader, | |
968 | loopNodes = loopNodes, | |
969 | parent = parent} | |
970 | end | |
971 | *) | |
972 | ||
973 | fun loopForest {headers, graph, root} | |
974 | = let | |
975 | val addEdge = ignore o addEdge | |
976 | ||
977 | val {get = graphNodeInfo : Node.t -> GraphNodeInfo.t, | |
978 | set = setGraphNodeInfo, ...} | |
979 | = Property.getSetOnce | |
980 | (Node.plist, Property.initRaise ("graphNodeInfo", Node.layout)) | |
981 | val forestNode = #forestNode o graphNodeInfo | |
982 | ||
983 | val {get = getIsHeader : Node.t -> bool ref, | |
984 | set = setIsHeader, ...} | |
985 | = Property.getSetOnce | |
986 | (Node.plist, Property.initFun (fn _ => ref false)) | |
987 | ||
988 | val {get = forestNodeInfo : Node.t -> ForestNodeInfo.t, | |
989 | set = setForestNodeInfo, ...} | |
990 | = Property.getSetOnce | |
991 | (Node.plist, Property.initRaise ("forestNodeInfo", Node.layout)) | |
992 | val parent = #parent o forestNodeInfo | |
993 | val loopNodes = #loopNodes o forestNodeInfo | |
994 | ||
995 | val {get = subGraphNodeInfo : Node.t -> SubGraphNodeInfo.t, | |
996 | set = setSubGraphNodeInfo, ...} | |
997 | = Property.getSetOnce | |
998 | (Node.plist, Property.initRaise ("subGraphNodeInfo", Node.layout)) | |
999 | val childSubGraphNode = #childSubGraphNode o subGraphNodeInfo | |
1000 | val childSubGraphNode' = ! o childSubGraphNode | |
1001 | val childSubGraphNode'' = valOf o childSubGraphNode' | |
1002 | val graphNode = #graphNode o subGraphNodeInfo | |
1003 | ||
1004 | val F = new () | |
1005 | ||
1006 | fun subGraph {graph, | |
1007 | scc} | |
1008 | = let | |
1009 | val scc' = List.map(scc, #graphNode o subGraphNodeInfo) | |
1010 | val headers = headers scc' | |
1011 | val _ = List.foreach | |
1012 | (headers, fn header => getIsHeader header := true) | |
1013 | ||
1014 | val graph' = new () | |
1015 | in | |
1016 | List.foreach | |
1017 | (scc, | |
1018 | fn n => let | |
1019 | val n' = newNode graph' | |
1020 | ||
1021 | val {childSubGraphNode, graphNode, ...} | |
1022 | = subGraphNodeInfo n | |
1023 | in | |
1024 | childSubGraphNode := SOME n' ; | |
1025 | setSubGraphNodeInfo | |
1026 | (n', | |
1027 | {childSubGraphNode = ref NONE, | |
1028 | graphNode = graphNode}) | |
1029 | end) ; | |
1030 | List.foreach | |
1031 | (scc, | |
1032 | fn n => Node.foreachSuccessor | |
1033 | (graph, n, fn e => | |
1034 | let | |
1035 | val from = n | |
1036 | val to = Edge.to (graph, e) | |
1037 | in | |
1038 | if List.contains | |
1039 | (scc, to, Node.equals) | |
1040 | andalso | |
1041 | not (List.contains | |
1042 | (headers, graphNode to, Node.equals)) | |
1043 | then let | |
1044 | val from' = childSubGraphNode'' from | |
1045 | val to' = childSubGraphNode'' to | |
1046 | in | |
1047 | addEdge (graph', {from = from', to = to'}) | |
1048 | end | |
1049 | else () | |
1050 | end)) ; | |
1051 | graph' | |
1052 | end | |
1053 | ||
1054 | fun nest {graph, parent} | |
1055 | = List.foreach | |
1056 | (stronglyConnectedComponents graph, | |
1057 | fn scc => let | |
1058 | val scc' = List.map(scc, graphNode) | |
1059 | val n' = newNode F | |
1060 | fun default () | |
1061 | = let | |
1062 | val graph' = subGraph {graph = graph, | |
1063 | scc = scc} | |
1064 | in | |
1065 | setForestNodeInfo(n', {loopNodes = scc', | |
1066 | parent = parent}) ; | |
1067 | nest {graph = graph', | |
1068 | parent = SOME n'} | |
1069 | end | |
1070 | ||
1071 | fun default' n | |
1072 | = let | |
1073 | in | |
1074 | setForestNodeInfo (n', {loopNodes = [graphNode n], | |
1075 | parent = parent}) ; | |
1076 | setGraphNodeInfo (graphNode n, {forestNode = n'}) | |
1077 | end | |
1078 | in | |
1079 | case parent | |
1080 | of NONE => () | |
1081 | | SOME parent => addEdge (F, {from = parent, to = n'}) ; | |
1082 | case scc | |
1083 | of [n] => if Node.hasEdge (graph, {from = n, to = n}) | |
1084 | then default () | |
1085 | else default' n | |
1086 | | scc => default () | |
1087 | end) | |
1088 | ||
1089 | val graph' | |
1090 | = let | |
1091 | val graph' = new () | |
1092 | val {get = nodeInfo': Node.t -> Node.t, | |
1093 | destroy} | |
1094 | = Property.destGet | |
1095 | (Node.plist, | |
1096 | Property.initFun (fn node => let | |
1097 | val node' = newNode graph' | |
1098 | in | |
1099 | setSubGraphNodeInfo | |
1100 | (node', | |
1101 | {childSubGraphNode = ref NONE, | |
1102 | graphNode = node}) ; | |
1103 | node' | |
1104 | end)) | |
1105 | in | |
1106 | foreachEdge | |
1107 | (graph, | |
1108 | fn (n, e) => let | |
1109 | val from = n | |
1110 | val from' = nodeInfo' from | |
1111 | val to = Edge.to (graph, e) | |
1112 | val to' = nodeInfo' to | |
1113 | in | |
1114 | addEdge(graph', {from = from', to = to'}) | |
1115 | end) ; | |
1116 | destroy () ; | |
1117 | graph' | |
1118 | end | |
1119 | ||
1120 | val _ = nest {graph = graph', parent = NONE} | |
1121 | in | |
1122 | {forest = F, | |
1123 | graphToForest = forestNode, | |
1124 | headers = headers, | |
1125 | isHeader = ! o getIsHeader, | |
1126 | loopNodes = loopNodes, | |
1127 | parent = parent} | |
1128 | end | |
1129 | ||
1130 | fun loopForestSteensgaard {graph, root} | |
1131 | = let | |
1132 | fun headers X | |
1133 | = let | |
1134 | val headers = ref [] | |
1135 | in | |
1136 | foreachEdge | |
1137 | (graph, fn (n, e) => let | |
1138 | val from = Edge.from (graph, e) | |
1139 | val to = Edge.to (graph, e) | |
1140 | in | |
1141 | if List.contains(X, to, Node.equals) | |
1142 | andalso | |
1143 | not (List.contains(X, from, Node.equals)) | |
1144 | then List.push(headers, to) | |
1145 | else () | |
1146 | end) ; | |
1147 | List.removeDuplicates(!headers, Node.equals) | |
1148 | end | |
1149 | (* | |
1150 | fun headers X | |
1151 | = List.keepAll | |
1152 | (X, | |
1153 | fn node | |
1154 | => Exn.withEscape | |
1155 | (fn escape | |
1156 | => (foreachEdge | |
1157 | (graph, | |
1158 | fn (n, e) => let | |
1159 | val from = n | |
1160 | val to = Edge.to (graph, e) | |
1161 | in | |
1162 | if Node.equals(node, to) | |
1163 | andalso | |
1164 | List.contains(X, to, Node.equals) | |
1165 | andalso | |
1166 | not (List.contains(X, from, Node.equals)) | |
1167 | then escape true | |
1168 | else () | |
1169 | end); | |
1170 | false))) | |
1171 | *) | |
1172 | in | |
1173 | loopForest {headers = headers, | |
1174 | graph = graph, | |
1175 | root = root} | |
1176 | end | |
1177 | ||
1178 | end |