From 940865b04fa534983982b261386a3b1926bd5531 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 25 Nov 2008 10:05:44 -0500 Subject: Fusing writes with recursive function calls --- CHANGELOG | 5 +++ src/compiler.sig | 4 ++ src/compiler.sml | 13 +++++- src/fuse.sig | 32 ++++++++++++++ src/fuse.sml | 130 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/mono_opt.sig | 1 + src/mono_opt.sml | 2 + src/mono_util.sig | 7 +++ src/mono_util.sml | 21 ++++++++- src/sources | 3 ++ 10 files changed, 216 insertions(+), 2 deletions(-) create mode 100644 src/fuse.sig create mode 100644 src/fuse.sml diff --git a/CHANGELOG b/CHANGELOG index a9cc96db..cbd67118 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,8 @@ +======== +======== + +- Optimization: Fusing page writes with calls to recursive functions + ======== 20081120 ======== 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 -- cgit v1.2.3