summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-11-25 10:05:44 -0500
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-11-25 10:05:44 -0500
commit940865b04fa534983982b261386a3b1926bd5531 (patch)
treefc3097de1fda1a8cf47dbbeaddc9dc1df9ba6035 /src
parent261ebaa5168b307ad38825c95d60c5bea5d9858f (diff)
Fusing writes with recursive function calls
Diffstat (limited to 'src')
-rw-r--r--src/compiler.sig4
-rw-r--r--src/compiler.sml13
-rw-r--r--src/fuse.sig32
-rw-r--r--src/fuse.sml130
-rw-r--r--src/mono_opt.sig1
-rw-r--r--src/mono_opt.sml2
-rw-r--r--src/mono_util.sig7
-rw-r--r--src/mono_util.sml21
-rw-r--r--src/sources3
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