Mercurial > urweb
changeset 506:65d8541c130b
Fusing writes with recursive function calls
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 25 Nov 2008 10:05:44 -0500 |
| parents | e18c747dd945 |
| children | ca95f9e4d45f |
| files | CHANGELOG src/compiler.sig src/compiler.sml src/fuse.sig src/fuse.sml src/mono_opt.sig src/mono_opt.sml src/mono_util.sig src/mono_util.sml src/sources |
| diffstat | 10 files changed, 216 insertions(+), 2 deletions(-) [+] |
line wrap: on
line diff
--- a/CHANGELOG Sun Nov 23 11:47:28 2008 -0500 +++ b/CHANGELOG Tue Nov 25 10:05:44 2008 -0500 @@ -1,3 +1,8 @@ +======== +======== + +- Optimization: Fusing page writes with calls to recursive functions + ======== 20081120 ========
--- a/src/compiler.sig Sun Nov 23 11:47:28 2008 -0500 +++ b/src/compiler.sig Tue Nov 25 10:05:44 2008 -0500 @@ -76,6 +76,7 @@ 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 @@ 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
--- a/src/compiler.sml Sun Nov 23 11:47:28 2008 -0500 +++ b/src/compiler.sml Tue Nov 25 10:05:44 2008 -0500 @@ -523,12 +523,23 @@ 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,
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/fuse.sig Tue Nov 25 10:05:44 2008 -0500 @@ -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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/fuse.sml Tue Nov 25 10:05:44 2008 -0500 @@ -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
--- a/src/mono_opt.sig Sun Nov 23 11:47:28 2008 -0500 +++ b/src/mono_opt.sig Tue Nov 25 10:05:44 2008 -0500 @@ -28,5 +28,6 @@ signature MONO_OPT = sig val optimize : Mono.file -> Mono.file + val optExp : Mono.exp -> Mono.exp end
--- a/src/mono_opt.sml Sun Nov 23 11:47:28 2008 -0500 +++ b/src/mono_opt.sml Tue Nov 25 10:05:44 2008 -0500 @@ -366,4 +366,6 @@ val optimize = U.File.map {typ = typ, exp = exp, decl = decl} +val optExp = U.Exp.map {typ = typ, exp = exp} + end
--- a/src/mono_util.sig Sun Nov 23 11:47:28 2008 -0500 +++ b/src/mono_util.sig Tue Nov 25 10:05:44 2008 -0500 @@ -90,6 +90,11 @@ 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 @@ exp : Mono.exp' * 'state -> 'state, decl : Mono.decl' * 'state -> 'state} -> 'state -> Mono.file -> 'state + + val maxName : Mono.file -> int end end
--- a/src/mono_util.sml Sun Nov 23 11:47:28 2008 -0500 +++ b/src/mono_util.sml Tue Nov 25 10:05:44 2008 -0500 @@ -422,6 +422,13 @@ 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 @@ 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 @@ 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