# HG changeset patch
# User Adam Chlipala <adamc@hcoop.net>
# Date 1216312821 14400
# Node ID 25b28625d4df3a014b96ce0bcd3aa26b68eb205b
# Parent  5df6555032882ff2893eb7957c9e107942cc3c12
Proper topological sorting in untangle

diff -r 5df655503288 -r 25b28625d4df src/compiler.sig
--- 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
diff -r 5df655503288 -r 25b28625d4df src/compiler.sml
--- 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"
diff -r 5df655503288 -r 25b28625d4df src/untangle.sml
--- 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;