Mercurial > urweb
changeset 131:5df655503288
Untangle
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 17 Jul 2008 12:19:44 -0400 |
| parents | 96bd3350e77d |
| children | 25b28625d4df |
| files | src/compiler.sig src/compiler.sml src/lacweb.grm src/sources src/untangle.sig src/untangle.sml tests/recReal.lac tests/recReal2.lac tests/recReal3.lac |
| diffstat | 9 files changed, 289 insertions(+), 2 deletions(-) [+] |
line wrap: on
line diff
--- a/src/compiler.sig Thu Jul 17 11:20:07 2008 -0400 +++ b/src/compiler.sig Thu Jul 17 12:19:44 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 untangle : job -> Mono.file option val mono_opt : job -> Mono.file option val cjrize : job -> Cjr.file option @@ -60,6 +61,7 @@ val testShake : job -> unit val testMonoize : job -> unit val testMono_opt : job -> unit + val testUntangle : job -> unit val testCjrize : job -> unit end
--- a/src/compiler.sml Thu Jul 17 11:20:07 2008 -0400 +++ b/src/compiler.sml Thu Jul 17 12:19:44 2008 -0400 @@ -232,8 +232,17 @@ else SOME (Monoize.monoize CoreEnv.empty file) +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 monoize job of + case untangle job of NONE => NONE | SOME file => if ErrorMsg.anyErrors () then @@ -304,7 +313,7 @@ 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 @@ 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"
--- a/src/lacweb.grm Thu Jul 17 11:20:07 2008 -0400 +++ b/src/lacweb.grm Thu Jul 17 12:19:44 2008 -0400 @@ -345,6 +345,7 @@ (ErrorMsg.errorAt pos "Begin and end tags don't match."; (EFold, pos)) end) + | LBRACE eexp RBRACE (eexp) attrs : ([]) | attr attrs (attr :: attrs)
--- a/src/sources Thu Jul 17 11:20:07 2008 -0400 +++ b/src/sources Thu Jul 17 12:19:44 2008 -0400 @@ -78,6 +78,9 @@ tag.sig tag.sml +untangle.sig +untangle.sml + mono.sml mono_util.sig
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/untangle.sig Thu Jul 17 12:19:44 2008 -0400 @@ -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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/untangle.sml Thu Jul 17 12:19:44 2008 -0400 @@ -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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/recReal.lac Thu Jul 17 12:19:44 2008 -0400 @@ -0,0 +1,8 @@ +val rec endlessList = fn () => <body> + <li> Buy eggs.</li> + {endlessList ()} +</body> + +val main = fn () => <html><body> + {endlessList ()} +</body></html>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/recReal2.lac Thu Jul 17 12:19:44 2008 -0400 @@ -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>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/recReal3.lac Thu Jul 17 12:19:44 2008 -0400 @@ -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>