diff options
| -rw-r--r-- | src/compiler.sig | 4 | ||||
| -rw-r--r-- | src/compiler.sml | 20 | ||||
| -rw-r--r-- | src/untangle.sml | 40 |
3 files changed, 53 insertions, 11 deletions
diff --git a/src/compiler.sig b/src/compiler.sig index b77b635c..aca352f7 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -47,6 +47,7 @@ signature COMPILER = sig 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 @@ signature COMPILER = sig val testReduce : job -> unit val testShake : job -> unit val testMonoize : job -> unit - val testMono_opt : job -> unit + val testMono_opt' : job -> unit val testUntangle : job -> unit + val testMono_opt : job -> unit val testCjrize : job -> unit end diff --git a/src/compiler.sml b/src/compiler.sml index 77c8d202..e8d07f1c 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -232,13 +232,22 @@ fun monoize job = else SOME (Monoize.monoize CoreEnv.empty file) -fun untangle job = +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 mono_opt' job of + NONE => NONE + | SOME file => + if ErrorMsg.anyErrors () then + NONE + else SOME (Untangle.untangle file) fun mono_opt job = @@ -339,6 +348,15 @@ fun testMonoize job = 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" diff --git a/src/untangle.sml b/src/untangle.sml index f3e220b2..373cfe18 100644 --- a/src/untangle.sml +++ b/src/untangle.sml @@ -134,20 +134,42 @@ fun untangle file = 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; |