From 8d4e252a0d4ac2c89805cd2785f79572cdfe7d82 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 3 Jul 2008 18:06:52 -0400 Subject: Mono optimizations (start with string concat and space eating) --- src/compiler.sig | 2 ++ src/compiler.sml | 20 +++++++++++++++- src/mono_opt.sig | 32 +++++++++++++++++++++++++ src/mono_opt.sml | 72 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/mono_util.sig | 5 ++++ src/mono_util.sml | 7 ++++++ src/sources | 3 +++ 7 files changed, 140 insertions(+), 1 deletion(-) create mode 100644 src/mono_opt.sig create mode 100644 src/mono_opt.sml (limited to 'src') diff --git a/src/compiler.sig b/src/compiler.sig index 5a421db7..c85eba39 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -46,6 +46,7 @@ signature COMPILER = sig 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 @@ signature COMPILER = sig 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 diff --git a/src/compiler.sml b/src/compiler.sml index 1b97e874..592191c8 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -215,9 +215,18 @@ fun monoize job = else SOME (Monoize.monoize CoreEnv.empty file) -fun cloconv job = +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 mono_opt job of + NONE => NONE | SOME file => if ErrorMsg.anyErrors () then NONE @@ -304,6 +313,15 @@ fun testMonoize job = 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" diff --git a/src/mono_opt.sig b/src/mono_opt.sig new file mode 100644 index 00000000..d147e7bc --- /dev/null +++ b/src/mono_opt.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 MONO_OPT = sig + + val optimize : Mono.file -> Mono.file + +end diff --git a/src/mono_opt.sml b/src/mono_opt.sml new file mode 100644 index 00000000..2f98a9c7 --- /dev/null +++ b/src/mono_opt.sml @@ -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 diff --git a/src/mono_util.sig b/src/mono_util.sig index 750a4d3c..ab851aea 100644 --- a/src/mono_util.sig +++ b/src/mono_util.sig @@ -109,6 +109,11 @@ structure File : sig 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} diff --git a/src/mono_util.sml b/src/mono_util.sml index 5309244a..54eb9be7 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -266,6 +266,13 @@ fun mapB {typ, exp, decl, bind} ctx ds = 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)), diff --git a/src/sources b/src/sources index 20bb2011..3cf2bb94 100644 --- a/src/sources +++ b/src/sources @@ -89,6 +89,9 @@ mono_env.sml mono_print.sig mono_print.sml +mono_opt.sig +mono_opt.sml + flat.sml flat_util.sig -- cgit v1.2.3