Mono optimizations (start with string concat and space eating)

7 files changed, 140 insertions, 1 deletions

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,13 +215,22 @@ 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
+        else
             SOME (Cloconv.cloconv file)
 
 fun cjrize job =
@@ -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