Fusing writes with recursive function calls

9 files changed, 211 insertions, 2 deletions

diff --git a/src/compiler.sig b/src/compiler.sig
index af086675..8c52ea32 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -76,6 +76,7 @@ signature COMPILER = sig
     val untangle : (Mono.file, Mono.file) phase
     val mono_reduce : (Mono.file, Mono.file) phase
     val mono_shake : (Mono.file, Mono.file) phase
+    val fuse : (Mono.file, Mono.file) phase
     val pathcheck : (Mono.file, Mono.file) phase
     val cjrize : (Mono.file, Cjr.file) phase
     val prepare : (Cjr.file, Cjr.file) phase
@@ -104,6 +105,9 @@ signature COMPILER = sig
     val toMono_reduce : (string, Mono.file) transform
     val toMono_shake : (string, Mono.file) transform
     val toMono_opt2 : (string, Mono.file) transform
+    val toFuse : (string, Mono.file) transform
+    val toUntangle2 : (string, Mono.file) transform
+    val toMono_shake2 : (string, Mono.file) transform
     val toPathcheck : (string, Mono.file) transform
     val toCjrize : (string, Cjr.file) transform
     val toPrepare : (string, Cjr.file) transform
diff --git a/src/compiler.sml b/src/compiler.sml
index 6a6c4391..aac4a924 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -523,12 +523,23 @@ val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce
 
 val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake
 
+val fuse = {
+    func = Fuse.fuse,
+    print = MonoPrint.p_file MonoEnv.empty
+}
+
+val toFuse = transform fuse "fuse" o toMono_opt2
+
+val toUntangle2 = transform untangle "untangle2" o toFuse
+
+val toMono_shake2 = transform mono_shake "mono_shake2" o toUntangle2
+
 val pathcheck = {
     func = (fn file => (PathCheck.check file; file)),
     print = MonoPrint.p_file MonoEnv.empty
 }
 
-val toPathcheck = transform pathcheck "pathcheck" o toMono_opt2
+val toPathcheck = transform pathcheck "pathcheck" o toMono_shake2
 
 val cjrize = {
     func = Cjrize.cjrize,
diff --git a/src/fuse.sig b/src/fuse.sig
new file mode 100644
index 00000000..3ad45ac9
--- /dev/null
+++ b/src/fuse.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 FUSE = sig
+
+    val fuse : Mono.file -> Mono.file
+
+end
diff --git a/src/fuse.sml b/src/fuse.sml
new file mode 100644
index 00000000..b6bd6b47
--- /dev/null
+++ b/src/fuse.sml
@@ -0,0 +1,130 @@
+(* 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 Fuse :> FUSE = struct
+
+open Mono
+structure U = MonoUtil
+
+structure IM = IntBinaryMap
+
+fun returnsString (t, loc) =
+    let
+        fun rs (t, loc) =
+            case t of
+                TFfi ("Basis", "string") => SOME ([], (TRecord [], loc))
+              | TFun (dom, ran) =>
+                (case rs ran of
+                     NONE => NONE
+                   | SOME (args, ran') => SOME (dom :: args, (TFun (dom, ran'), loc)))
+              | _ => NONE
+    in
+        case t of
+            TFun (dom, ran) =>
+            (case rs ran of
+                 NONE => NONE
+               | SOME (args, ran') => SOME (dom :: args, (TFun (dom, ran'), loc)))
+          | _ => NONE
+    end
+
+fun fuse file =
+    let
+        fun doDecl (d as (_, loc), (funcs, maxName)) =
+            let
+                val (d, funcs, maxName) =
+                    case #1 d of
+                        DValRec vis =>
+                        let
+                            val (vis', funcs, maxName) =
+                                foldl (fn ((x, n, t, e, s), (vis', funcs, maxName)) =>
+                                          case returnsString t of
+                                              NONE => (vis', funcs, maxName)
+                                            | SOME (args, t') =>
+                                              let
+                                                  fun getBody (e, args) =
+                                                      case (#1 e, args) of
+                                                          (_, []) => (e, [])
+                                                        | (EAbs (x, t, _, e), _ :: args) =>
+                                                          let
+                                                              val (body, args') = getBody (e, args)
+                                                          in
+                                                              (body, (x, t) :: args')
+                                                          end
+                                                        | _ => raise Fail "Fuse: getBody"
+
+                                                  val (body, args) = getBody (e, args)
+                                                  val body = MonoOpt.optExp (EWrite body, loc)
+                                                  val (body, _) = foldl (fn ((x, dom), (body, ran)) =>
+                                                                            ((EAbs (x, dom, ran, body), loc),
+                                                                             (TFun (dom, ran), loc)))
+                                                                        (body, (TRecord [], loc)) args
+                                              in
+                                                  ((x, maxName, t', body, s) :: vis',
+                                                   IM.insert (funcs, n, maxName),
+                                                   maxName + 1)
+                                              end)
+                                ([], funcs, maxName) vis
+                        in
+                            ((DValRec (vis @ vis'), loc), funcs, maxName)
+                        end
+                      | _ => (d, funcs, maxName)
+
+                fun exp e =
+                    case e of
+                        EWrite e' =>
+                        let
+                            fun unravel (e, loc) =
+                                case e of
+                                    ENamed n =>
+                                    (case IM.find (funcs, n) of
+                                         NONE => NONE
+                                       | SOME n' => SOME (ENamed n', loc))
+                                  | EApp (e1, e2) =>
+                                    (case unravel e1 of
+                                         NONE => NONE
+                                       | SOME e1 => SOME (EApp (e1, e2), loc))
+                                  | _ => NONE
+                        in
+                            case unravel e' of
+                                NONE => e
+                              | SOME (e', _) => e'
+                        end
+                      | _ => e
+            in
+                (U.Decl.map {typ = fn x => x,
+                             exp = exp,
+                             decl = fn x => x} 
+                            d,
+                 (funcs, maxName))
+            end
+
+        val (file, _) = ListUtil.foldlMap doDecl (IM.empty, U.File.maxName file + 1) file
+    in
+        file
+    end
+
+end
diff --git a/src/mono_opt.sig b/src/mono_opt.sig
index d147e7bc..d0268087 100644
--- a/src/mono_opt.sig
+++ b/src/mono_opt.sig
@@ -28,5 +28,6 @@
 signature MONO_OPT = sig
 
     val optimize : Mono.file -> Mono.file
+    val optExp : Mono.exp -> Mono.exp
 
 end
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index b56372c7..6c0e6e21 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -366,4 +366,6 @@ and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
 
 val optimize = U.File.map {typ = typ, exp = exp, decl = decl}
 
+val optExp = U.Exp.map {typ = typ, exp = exp}
+
 end
diff --git a/src/mono_util.sig b/src/mono_util.sig
index 4e9d5d91..32a83855 100644
--- a/src/mono_util.sig
+++ b/src/mono_util.sig
@@ -90,6 +90,11 @@ structure Decl : sig
                 exp : Mono.exp' * 'state -> 'state,
                 decl : Mono.decl' * 'state -> 'state}
                -> 'state -> Mono.decl -> 'state
+
+    val map : {typ : Mono.typ' -> Mono.typ',
+               exp : Mono.exp' -> Mono.exp',
+               decl : Mono.decl' -> Mono.decl'}
+              -> Mono.decl -> Mono.decl
 end
 
 structure File : sig
@@ -121,6 +126,8 @@ structure File : sig
                 exp : Mono.exp' * 'state -> 'state,
                 decl : Mono.decl' * 'state -> 'state}
                -> 'state -> Mono.file -> 'state
+
+    val maxName : Mono.file -> int
 end
 
 end
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 14ab1674..2b2476e7 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -422,6 +422,13 @@ fun fold {typ, exp, decl} s d =
         S.Continue (_, s) => s
       | S.Return _ => raise Fail "MonoUtil.Decl.fold: 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 "MonoUtil.Decl.map: Impossible"
+      | S.Continue (e, ()) => e
+
 end
 
 structure File = struct
@@ -490,7 +497,7 @@ 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.Return () => raise Fail "MonoUtil.File.map: Impossible"
       | S.Continue (e, ()) => e
 
 fun fold {typ, exp, decl} s d =
@@ -500,6 +507,18 @@ fun fold {typ, exp, decl} s d =
         S.Continue (_, s) => s
       | S.Return _ => raise Fail "MonoUtil.File.fold: Impossible"
 
+val maxName = foldl (fn ((d, _) : decl, count) =>
+                        case d of
+                            DDatatype (_, n, ns) =>
+                            foldl (fn ((_, n', _), m) => Int.max (n', m))
+                                  (Int.max (n, count)) ns
+                          | DVal (_, n, _, _, _) => Int.max (n, count)
+                          | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis
+                          | DExport _ => count
+                          | DTable _ => count
+                          | DSequence _ => count
+                          | DDatabase _ => count) 0
+
 end
 
 end
diff --git a/src/sources b/src/sources
index bddcac67..13f505d0 100644
--- a/src/sources
+++ b/src/sources
@@ -140,6 +140,9 @@ mono_shake.sml
 pathcheck.sig
 pathcheck.sml
 
+fuse.sig
+fuse.sml
+
 cjr.sml
 
 cjr_env.sig