Mercurial > urweb
changeset 96:82aaa1c406d3
Mono optimizations (start with string concat and space eating)
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 03 Jul 2008 18:06:52 -0400 |
| parents | 274116d1a4cd |
| children | 713e01fd7924 |
| files | src/compiler.sig src/compiler.sml src/mono_opt.sig src/mono_opt.sml src/mono_util.sig src/mono_util.sml src/sources |
| diffstat | 7 files changed, 140 insertions(+), 1 deletions(-) [+] |
line wrap: on
line diff
--- a/src/compiler.sig Thu Jul 03 17:53:28 2008 -0400 +++ b/src/compiler.sig Thu Jul 03 18:06:52 2008 -0400 @@ -46,6 +46,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 cloconv : job -> Flat.file option val cjrize : job -> Cjr.file option @@ -57,6 +58,7 @@ val testReduce : job -> unit val testShake : job -> unit val testMonoize : job -> unit + val testMono_opt : job -> unit val testCloconv : job -> unit val testCjrize : job -> unit
--- a/src/compiler.sml Thu Jul 03 17:53:28 2008 -0400 +++ b/src/compiler.sml Thu Jul 03 18:06:52 2008 -0400 @@ -215,8 +215,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 cloconv job = - case monoize job of + case mono_opt job of NONE => NONE | SOME file => if ErrorMsg.anyErrors () then @@ -304,6 +313,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 testCloconv job = (case cloconv job of NONE => print "Failed\n"
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/mono_opt.sig Thu Jul 03 18:06:52 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 MONO_OPT = sig + + val optimize : Mono.file -> Mono.file + +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/mono_opt.sml Thu Jul 03 18:06:52 2008 -0400 @@ -0,0 +1,72 @@ +(* 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 MonoOpt :> MONO_OPT = struct + +open Mono +structure U = MonoUtil + +fun typ t = t +fun decl d = d + +fun exp e = + case e of + EPrim (Prim.String s) => + let + val (_, chs) = + CharVector.foldl (fn (ch, (lastSpace, chs)) => + let + val isSpace = Char.isSpace ch + in + if isSpace andalso lastSpace then + (true, chs) + else + (isSpace, ch :: chs) + end) + (false, []) s + in + EPrim (Prim.String (String.implode (rev chs))) + end + + + | EStrcat ((EPrim (Prim.String s1), loc), (EPrim (Prim.String s2), _)) => + let + val s = + if size s1 > 0 andalso size s2 > 0 + andalso Char.isSpace (String.sub (s1, size s1 - 1)) + andalso Char.isSpace (String.sub (s2, 0)) then + s1 ^ String.extract (s2, 1, NONE) + else + s1 ^ s2 + in + EPrim (Prim.String s) + end + | _ => e + +val optimize = U.File.map {typ = typ, exp = exp, decl = decl} + +end
--- a/src/mono_util.sig Thu Jul 03 17:53:28 2008 -0400 +++ b/src/mono_util.sig Thu Jul 03 18:06:52 2008 -0400 @@ -109,6 +109,11 @@ bind : 'typtext * binder -> 'typtext} -> 'typtext -> Mono.file -> Mono.file + val map : {typ : Mono.typ' -> Mono.typ', + exp : Mono.exp' -> Mono.exp', + decl : Mono.decl' -> Mono.decl'} + -> Mono.file -> Mono.file + val fold : {typ : Mono.typ' * 'state -> 'state, exp : Mono.exp' * 'state -> 'state, decl : Mono.decl' * 'state -> 'state}
--- a/src/mono_util.sml Thu Jul 03 17:53:28 2008 -0400 +++ b/src/mono_util.sml Thu Jul 03 18:06:52 2008 -0400 @@ -266,6 +266,13 @@ S.Continue (ds, ()) => ds | S.Return _ => raise Fail "MonoUtil.File.mapB: Impossible" +fun map {typ, exp, decl} e = + case mapfold {typ = fn c => fn () => S.Continue (typ c, ()), + exp = fn e => fn () => S.Continue (exp e, ()), + decl = fn d => fn () => S.Continue (decl d, ())} e () of + S.Return () => raise Fail "Mono_util.File.map" + | S.Continue (e, ()) => e + fun fold {typ, exp, decl} s d = case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)), exp = fn e => fn s => S.Continue (e, exp (e, s)),