summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-07-17 12:19:44 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-07-17 12:19:44 -0400
commit1527e77c3c2c99fbb9fb832250a6cc00c06d70b0 (patch)
treefd4a0b102dcd522d169c716f72d4f16971ddeada
parentd5fd0e7403767670197f0422c99ba62176323624 (diff)
Untangle
-rw-r--r--src/compiler.sig2
-rw-r--r--src/compiler.sml22
-rw-r--r--src/lacweb.grm1
-rw-r--r--src/sources3
-rw-r--r--src/untangle.sig32
-rw-r--r--src/untangle.sml192
-rw-r--r--tests/recReal.lac8
-rw-r--r--tests/recReal2.lac13
-rw-r--r--tests/recReal3.lac18
9 files changed, 289 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
diff --git a/tests/recReal.lac b/tests/recReal.lac
new file mode 100644
index 00000000..e3d46e81
--- /dev/null
+++ b/tests/recReal.lac
@@ -0,0 +1,8 @@
+val rec endlessList = fn () => <body>
+ <li> Buy eggs.</li>
+ {endlessList ()}
+</body>
+
+val main = fn () => <html><body>
+ {endlessList ()}
+</body></html>
diff --git a/tests/recReal2.lac b/tests/recReal2.lac
new file mode 100644
index 00000000..efe24004
--- /dev/null
+++ b/tests/recReal2.lac
@@ -0,0 +1,13 @@
+val rec endlessList1 = fn () => <body>
+ <li> Buy eggs.</li>
+ {endlessList2 ()}
+</body>
+
+and endlessList2 = fn () => <body>
+ <li> Buy milk.</li>
+ {endlessList1 ()}
+</body>
+
+val main = fn () => <html><body>
+ {endlessList1 ()}
+</body></html>
diff --git a/tests/recReal3.lac b/tests/recReal3.lac
new file mode 100644
index 00000000..0ebc489a
--- /dev/null
+++ b/tests/recReal3.lac
@@ -0,0 +1,18 @@
+val rec endlessList1 = fn () => <body>
+ <li> Buy eggs.</li>
+ {endlessList2 ()}
+</body>
+
+and endlessList2 = fn () => <body>
+ <li> Buy milk.</li>
+ {endlessList1 ()}
+ {endlessList3 ()}
+</body>
+
+and endlessList3 = fn () => <body>
+ <li> Buy goat.</li>
+</body>
+
+val main = fn () => <html><body>
+ {endlessList1 ()}
+</body></html>