Untangle

6 files changed, 250 insertions, 2 deletions

diff --git a/src/compiler.sig b/src/compiler.sig
index eca871f8..b77b635c 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 untangle : job -> Mono.file option
     val mono_opt : job -> Mono.file option
     val cjrize : job -> Cjr.file option
 
@@ -60,6 +61,7 @@ signature COMPILER = sig
     val testShake : job -> unit
     val testMonoize : job -> unit
     val testMono_opt : job -> unit
+    val testUntangle : job -> unit
     val testCjrize : job -> unit
 
 end
diff --git a/src/compiler.sml b/src/compiler.sml
index 7ef8b646..77c8d202 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -232,13 +232,22 @@ fun monoize job =
         else
             SOME (Monoize.monoize CoreEnv.empty file)
 
-fun mono_opt job =
+fun untangle job =
     case monoize job of
         NONE => NONE
       | SOME file =>
         if ErrorMsg.anyErrors () then
             NONE
         else
+            SOME (Untangle.untangle file)
+
+fun mono_opt job =
+    case untangle job of
+        NONE => NONE
+      | SOME file =>
+        if ErrorMsg.anyErrors () then
+            NONE
+        else
             SOME (MonoOpt.optimize file)
 
 fun cjrize job =
@@ -304,7 +313,7 @@ fun testTag job =
            print ("Unbound named " ^ Int.toString n ^ "\n")
 
 fun testReduce job =
-    (case reduce job of
+    (case tag job of
          NONE => print "Failed\n"
        | SOME file =>
          (Print.print (CorePrint.p_file CoreEnv.empty file);
@@ -330,6 +339,15 @@ fun testMonoize job =
     handle MonoEnv.UnboundNamed n =>
            print ("Unbound named " ^ Int.toString n ^ "\n")
 
+fun testUntangle job =
+    (case untangle 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 testMono_opt job =
     (case mono_opt job of
          NONE => print "Failed\n"
diff --git a/src/lacweb.grm b/src/lacweb.grm
index f04c93dd..62e3c9e8 100644
--- a/src/lacweb.grm
+++ b/src/lacweb.grm
@@ -345,6 +345,7 @@ xmlOne : NOTAGS                      (EApp ((EVar (["Basis"], "cdata"), s (NOTAG
                                                 (ErrorMsg.errorAt pos "Begin and end tags don't match.";
                                                  (EFold, pos))
                                         end)
+       | LBRACE eexp RBRACE          (eexp)
                                           
 attrs  :                                ([])
        | attr attrs                     (attr :: attrs)
diff --git a/src/sources b/src/sources
index 2453e1c5..9e2d8089 100644
--- a/src/sources
+++ b/src/sources
@@ -78,6 +78,9 @@ shake.sml
 tag.sig
 tag.sml
 
+untangle.sig
+untangle.sml
+
 mono.sml
 
 mono_util.sig
diff --git a/src/untangle.sig b/src/untangle.sig
new file mode 100644
index 00000000..522cc6d8
--- /dev/null
+++ b/src/untangle.sig
@@ -0,0 +1,32 @@
+(* Copyright (c) 2008, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+signature UNTANGLE = sig
+
+    val untangle : Mono.file -> Mono.file
+
+end
diff --git a/src/untangle.sml b/src/untangle.sml
new file mode 100644
index 00000000..f3e220b2
--- /dev/null
+++ b/src/untangle.sml
@@ -0,0 +1,192 @@
+(* Copyright (c) 2008, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+structure Untangle :> UNTANGLE = struct
+
+open Mono
+
+structure U = MonoUtil
+structure E = MonoEnv
+
+structure IS = IntBinarySet
+structure IM = IntBinaryMap
+
+fun typ (k, s) = s
+
+fun exp (e, s) =
+    case e of
+        ENamed n => IS.add (s, n)
+
+      | _ => s
+
+fun untangle file =
+    let
+        fun decl (dAll as (d, loc)) =
+            case d of
+                DValRec vis =>
+                let
+                    val thisGroup = foldl (fn ((_, n, _, _, _), thisGroup) =>
+                                              IS.add (thisGroup, n)) IS.empty vis
+
+                    val used = foldl (fn ((_, n, _, e, _), used) =>
+                                       let
+                                           val usedHere = U.Exp.fold {typ = typ,
+                                                                      exp = exp} IS.empty e
+                                       in
+                                           IM.insert (used, n, IS.intersection (usedHere, thisGroup))
+                                       end)
+                               IM.empty vis
+
+                    fun p_graph reachable =
+                        IM.appi (fn (n, reachableHere) =>
+                                    (print (Int.toString n);
+                                     print ":";
+                                     IS.app (fn n' => (print " ";
+                                                       print (Int.toString n'))) reachableHere;
+                                     print "\n")) reachable
+
+                    (*val () = print "used:\n"
+                    val () = p_graph used*)
+
+                    fun expand reachable =
+                        let
+                            val changed = ref false
+
+                            val reachable =
+                                IM.mapi (fn (n, reachableHere) =>
+                                            IS.foldl (fn (n', reachableHere) =>
+                                                         let
+                                                             val more = valOf (IM.find (reachable, n'))
+                                                         in
+                                                             if IS.isEmpty (IS.difference (more, reachableHere)) then
+                                                                 reachableHere
+                                                             else
+                                                                 (changed := true;
+                                                                  IS.union (more, reachableHere))
+                                                         end)
+                                                     reachableHere reachableHere) reachable
+                        in
+                            (reachable, !changed)
+                        end
+
+                    fun iterate reachable =
+                        let
+                            val (reachable, changed) = expand reachable
+                        in
+                            if changed then
+                                iterate reachable
+                            else
+                                reachable
+                        end
+
+                    val reachable = iterate used
+
+                    (*val () = print "reachable:\n"
+                    val () = p_graph reachable*)
+
+                    fun sccs (nodes, acc) =
+                        case IS.find (fn _ => true) nodes of
+                            NONE => acc
+                          | SOME rep =>
+                            let
+                                val reachableHere = valOf (IM.find (reachable, rep))
+
+                                val (nodes, scc) = IS.foldl (fn (node, (nodes, scc)) =>
+                                                                if node = rep then
+                                                                    (nodes, scc)
+                                                                else
+                                                                    let
+                                                                        val reachableThere =
+                                                                            valOf (IM.find (reachable, node))
+                                                                    in
+                                                                        if IS.member (reachableThere, rep) then
+                                                                            (IS.delete (nodes, node),
+                                                                             IS.add (scc, node))
+                                                                        else
+                                                                            (nodes, scc)
+                                                                    end)
+                                                   (IS.delete (nodes, rep), IS.singleton rep) reachableHere
+                            in
+                                sccs (nodes, scc :: acc)
+                            end
+
+                    val sccs = rev (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
+                    (*val () = app (fn nodes => (print "SCC':";
+                                               IS.app (fn i => (print " ";
+                                                                print (Int.toString i))) nodes;
+                                               print "\n")) sccs*)
+
+                    fun isNonrec nodes =
+                        case IS.find (fn _ => true) nodes of
+                            NONE => NONE
+                          | SOME node =>
+                            let
+                                val nodes = IS.delete (nodes, node)
+                                val reachableHere = valOf (IM.find (reachable, node))
+                            in
+                                if IS.isEmpty nodes then
+                                    if IS.member (reachableHere, node) then
+                                        NONE
+                                    else
+                                        SOME node
+                                else
+                                    NONE
+                            end
+
+                    val ds = map (fn nodes =>
+                                     case isNonrec nodes of
+                                         SOME node =>
+                                         let
+                                             val vi = valOf (List.find (fn (_, n, _, _, _) => n = node) vis)
+                                         in
+                                             (DVal vi, loc)
+                                         end
+                                       | NONE =>
+                                         (DValRec (List.filter (fn (_, n, _, _, _) => IS.member (nodes, n)) vis), loc))
+                                 sccs
+                in
+                    ds
+                end
+              | _ => [dAll]
+    in
+        ListUtil.mapConcat decl file
+    end
+
+end