Mercurial > urweb
changeset 132:25b28625d4df
Proper topological sorting in untangle
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 17 Jul 2008 12:40:21 -0400 |
| parents | 5df655503288 |
| children | 55d8cfa4d024 |
| files | src/compiler.sig src/compiler.sml src/untangle.sml |
| diffstat | 3 files changed, 53 insertions(+), 11 deletions(-) [+] |
line wrap: on
line diff
--- a/src/compiler.sig Thu Jul 17 12:19:44 2008 -0400 +++ b/src/compiler.sig Thu Jul 17 12:40:21 2008 -0400 @@ -47,6 +47,7 @@ val reduce : job -> Core.file option val shake : job -> Core.file option val monoize : job -> Mono.file option + val mono_opt' : job -> Mono.file option val untangle : job -> Mono.file option val mono_opt : job -> Mono.file option val cjrize : job -> Cjr.file option @@ -60,8 +61,9 @@ val testReduce : job -> unit val testShake : job -> unit val testMonoize : job -> unit + val testMono_opt' : job -> unit + val testUntangle : job -> unit val testMono_opt : job -> unit - val testUntangle : job -> unit val testCjrize : job -> unit end
--- a/src/compiler.sml Thu Jul 17 12:19:44 2008 -0400 +++ b/src/compiler.sml Thu Jul 17 12:40:21 2008 -0400 @@ -232,8 +232,17 @@ else SOME (Monoize.monoize CoreEnv.empty file) +fun mono_opt' job = + case monoize job of + NONE => NONE + | SOME file => + if ErrorMsg.anyErrors () then + NONE + else + SOME (MonoOpt.optimize file) + fun untangle job = - case monoize job of + case mono_opt' job of NONE => NONE | SOME file => if ErrorMsg.anyErrors () then @@ -339,6 +348,15 @@ handle MonoEnv.UnboundNamed n => print ("Unbound named " ^ Int.toString n ^ "\n") +fun testMono_opt' job = + (case mono_opt' job of + NONE => print "Failed\n" + | SOME file => + (Print.print (MonoPrint.p_file MonoEnv.empty file); + print "\n")) + handle MonoEnv.UnboundNamed n => + print ("Unbound named " ^ Int.toString n ^ "\n") + fun testUntangle job = (case untangle job of NONE => print "Failed\n"
--- a/src/untangle.sml Thu Jul 17 12:19:44 2008 -0400 +++ b/src/untangle.sml Thu Jul 17 12:40:21 2008 -0400 @@ -134,20 +134,42 @@ sccs (nodes, scc :: acc) end - val sccs = rev (sccs (thisGroup, [])) + val sccs = sccs (thisGroup, []) (*val () = app (fn nodes => (print "SCC:"; IS.app (fn i => (print " "; print (Int.toString i))) nodes; print "\n")) sccs*) - val sccs = ListMergeSort.sort (fn (nodes1, nodes2) => - let - val node1 = valOf (IS.find (fn _ => true) nodes1) - val node2 = valOf (IS.find (fn _ => true) nodes2) - val reachable1 = valOf (IM.find (reachable, node1)) - in - IS.member (reachable1, node2) - end) sccs + fun depends nodes1 nodes2 = + let + val node1 = valOf (IS.find (fn _ => true) nodes1) + val node2 = valOf (IS.find (fn _ => true) nodes2) + val reachable1 = valOf (IM.find (reachable, node1)) + in + IS.member (reachable1, node2) + end + + fun findReady (sccs, passed) = + case sccs of + [] => raise Fail "Untangle: Unable to topologically sort 'val rec'" + | nodes :: sccs => + if List.exists (depends nodes) passed + orelse List.exists (depends nodes) sccs then + findReady (sccs, nodes :: passed) + else + (nodes, List.revAppend (passed, sccs)) + + fun topo (sccs, acc) = + case sccs of + [] => rev acc + | _ => + let + val (node, sccs) = findReady (sccs, []) + in + topo (sccs, node :: acc) + end + + val sccs = topo (sccs, []) (*val () = app (fn nodes => (print "SCC':"; IS.app (fn i => (print " "; print (Int.toString i))) nodes;