Mercurial > urweb
changeset 1020:dfe34fad749d
RPC uses VM support for call/cc
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 25 Oct 2009 14:07:10 -0400 |
| parents | 68ba074e260f |
| children | 7a4a55e05081 |
| files | CHANGELOG lib/js/urweb.js src/compiler.sig src/compiler.sml src/core.sml src/core_print.sml src/core_untangle.sml src/core_util.sml src/effectize.sml src/jscomp.sml src/mono.sml src/mono_print.sml src/mono_reduce.sml src/mono_util.sml src/monoize.sml src/reduce.sml src/reduce_local.sml src/rpcify.sml src/shake.sml src/sources src/tailify.sig src/tailify.sml |
| diffstat | 22 files changed, 59 insertions(+), 471 deletions(-) [+] |
line wrap: on
line diff
--- a/CHANGELOG Sun Oct 25 13:12:24 2009 -0400 +++ b/CHANGELOG Sun Oct 25 14:07:10 2009 -0400 @@ -1,3 +1,12 @@ +======== +Next +======== + +- Bug fixes +- Optimization improvements +- Removed a restriction that prevented some RPCs from compiling +- New extra demo: conference1 + ======== 20091012 ========
--- a/lib/js/urweb.js Sun Oct 25 13:12:24 2009 -0400 +++ b/lib/js/urweb.js Sun Oct 25 14:07:10 2009 -0400 @@ -632,7 +632,7 @@ if (isok) { try { - execF(k, parse(xhr.responseText)); + k(parse(xhr.responseText)); } catch (v) { doExn(v); } @@ -854,7 +854,11 @@ } function exec0(env, e) { - var stack = null; + return exec1(env, null, e); +} + +function exec1(env, stack, e) { + var stack, usedK = false; var saveEnv = function() { if (stack.next != null && stack.next.data.c != "<") @@ -883,8 +887,9 @@ case "f": fr.args[fr.pos++] = v; if (fr.a == null) { + stack = stack.next; e = {c: "c", v: fr.f.apply(null, fr.args)}; - stack = stack.next; + if (usedK) return null; } else { e = fr.a.data; fr.a = fr.a.next; @@ -1014,6 +1019,11 @@ env = e.env; e = e.body; break; + case "K": + { var savedStack = stack.next, savedEnv = env; + e = {c: "c", v: function(v) { return exec1(savedEnv, savedStack, {c: "c", v: v}); } };} + usedK = true; + break; default: whine("Unknown Ur expression kind " + e.c); }
--- a/src/compiler.sig Sun Oct 25 13:12:24 2009 -0400 +++ b/src/compiler.sig Sun Oct 25 14:07:10 2009 -0400 @@ -86,7 +86,6 @@ val reduce : (Core.file, Core.file) phase val unpoly : (Core.file, Core.file) phase val specialize : (Core.file, Core.file) phase - val tailify : (Core.file, Core.file) phase val marshalcheck : (Core.file, Core.file) phase val effectize : (Core.file, Core.file) phase val monoize : (Core.file, Mono.file) phase @@ -121,7 +120,6 @@ val toSpecialize : (string, Core.file) transform val toShake3 : (string, Core.file) transform val toEspecialize : (string, Core.file) transform - val toTailify : (string, Core.file) transform val toReduce2 : (string, Core.file) transform val toShake4 : (string, Core.file) transform val toMarshalcheck : (string, Core.file) transform
--- a/src/compiler.sml Sun Oct 25 13:12:24 2009 -0400 +++ b/src/compiler.sml Sun Oct 25 14:07:10 2009 -0400 @@ -779,14 +779,7 @@ val toEspecialize = transform especialize "especialize" o toShake3 -val tailify = { - func = Tailify.frob, - print = CorePrint.p_file CoreEnv.empty -} - -val toTailify = transform tailify "tailify" o toEspecialize - -val toReduce2 = transform reduce "reduce2" o toTailify +val toReduce2 = transform reduce "reduce2" o toEspecialize val toShake4 = transform shake "shake4" o toReduce2
--- a/src/core.sml Sun Oct 25 13:12:24 2009 -0400 +++ b/src/core.sml Sun Oct 25 14:07:10 2009 -0400 @@ -115,8 +115,7 @@ | ELet of string * con * exp * exp - | EServerCall of int * exp list * exp * con * con - | ETailCall of int * exp list * exp * con * con + | EServerCall of int * exp list * con withtype exp = exp' located
--- a/src/core_print.sml Sun Oct 25 13:12:24 2009 -0400 +++ b/src/core_print.sml Sun Oct 25 14:07:10 2009 -0400 @@ -438,22 +438,12 @@ newline, p_exp (E.pushERel env x t) e2] - | EServerCall (n, es, e, _, _) => box [string "Server(", - p_enamed env n, - string ",", - space, - p_list (p_exp env) es, - string ")[", - p_exp env e, - string "]"] - | ETailCall (n, es, e, _, _) => box [string "Tail(", - p_enamed env n, - string ",", - space, - p_list (p_exp env) es, - string ")[", - p_exp env e, - string "]"] + | EServerCall (n, es, _) => box [string "Server(", + p_enamed env n, + string ",", + space, + p_list (p_exp env) es, + string ")"] | EKAbs (x, e) => box [string x, space,
--- a/src/core_untangle.sml Sun Oct 25 13:12:24 2009 -0400 +++ b/src/core_untangle.sml Sun Oct 25 14:07:10 2009 -0400 @@ -48,8 +48,7 @@ case e of ENamed n => try n | EClosure (n, _) => try n - | EServerCall (n, _, _, _, _) => try n - | ETailCall (n, _, _, _, _) => try n + | EServerCall (n, _, _) => try n | _ => s end
--- a/src/core_util.sml Sun Oct 25 13:12:24 2009 -0400 +++ b/src/core_util.sml Sun Oct 25 14:07:10 2009 -0400 @@ -532,20 +532,12 @@ | (ELet _, _) => LESS | (_, ELet _) => GREATER - | (EServerCall (n1, es1, e1, _, _), EServerCall (n2, es2, e2, _, _)) => + | (EServerCall (n1, es1, _), EServerCall (n2, es2, _)) => join (Int.compare (n1, n2), - fn () => join (joinL compare (es1, es2), - fn () => compare (e1, e2))) + fn () => joinL compare (es1, es2)) | (EServerCall _, _) => LESS | (_, EServerCall _) => GREATER - | (ETailCall (n1, es1, e1, _, _), ETailCall (n2, es2, e2, _, _)) => - join (Int.compare (n1, n2), - fn () => join (joinL compare (es1, es2), - fn () => compare (e1, e2))) - | (ETailCall _, _) => LESS - | (_, ETailCall _) => GREATER - | (EKAbs (_, e1), EKAbs (_, e2)) => compare (e1, e2) | (EKAbs _, _) => LESS | (_, EKAbs _) => GREATER @@ -725,27 +717,12 @@ fn e2' => (ELet (x, t', e1', e2'), loc)))) - | EServerCall (n, es, e, t1, t2) => + | EServerCall (n, es, t) => S.bind2 (ListUtil.mapfold (mfe ctx) es, fn es' => - S.bind2 (mfe ctx e, - fn e' => - S.bind2 (mfc ctx t1, - fn t1' => - S.map2 (mfc ctx t2, - fn t2' => - (EServerCall (n, es', e', t1', t2'), loc))))) - - | ETailCall (n, es, e, t1, t2) => - S.bind2 (ListUtil.mapfold (mfe ctx) es, - fn es' => - S.bind2 (mfe ctx e, - fn e' => - S.bind2 (mfc ctx t1, - fn t1' => - S.map2 (mfc ctx t2, - fn t2' => - (ETailCall (n, es', e', t1', t2'), loc))))) + S.map2 (mfc ctx t, + fn t' => + (EServerCall (n, es', t'), loc))) | EKAbs (x, e) => S.map2 (mfe (bind (ctx, RelK x)) e,
--- a/src/effectize.sml Sun Oct 25 13:12:24 2009 -0400 +++ b/src/effectize.sml Sun Oct 25 14:07:10 2009 -0400 @@ -46,7 +46,7 @@ EFfi f => effectful f | EFfiApp (m, x, _) => effectful (m, x) | ENamed n => IM.inDomain (evs, n) - | EServerCall (n, _, _, _, _) => IM.inDomain (evs, n) + | EServerCall (n, _, _) => IM.inDomain (evs, n) | _ => false fun couldWriteOnload evs = U.Exp.exists {kind = fn _ => false, @@ -70,7 +70,7 @@ case e of EFfi ("Basis", "getCookie") => true | ENamed n => IM.inDomain (evs, n) - | EServerCall (n, _, _, _, _) => IM.inDomain (evs, n) + | EServerCall (n, _, _) => IM.inDomain (evs, n) | _ => false fun couldReadCookie evs = U.Exp.exists {kind = fn _ => false,
--- a/src/jscomp.sml Sun Oct 25 13:12:24 2009 -0400 +++ b/src/jscomp.sml Sun Oct 25 14:07:10 2009 -0400 @@ -900,10 +900,9 @@ st) end - | EServerCall (e, ek, t, eff) => + | EServerCall (e, t, eff) => let val (e, st) = jsE inner (e, st) - val (ek, st) = jsE inner (ek, st) val (unurl, st) = unurlifyExp loc (t, st) in (strcat [str ("{c:\"f\",f:rc,a:cons({c:\"c\",v:\"" @@ -911,9 +910,7 @@ ^ "\"},cons("), e, str (",cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return " - ^ unurl ^ "}},cons("), - ek, - str (",cons({c:\"c\",v:" + ^ unurl ^ "}},cons({c:\"K\"},cons({c:\"c\",v:" ^ (case eff of ReadCookieWrite => "true" | _ => "false") @@ -1165,12 +1162,11 @@ ((ESignalSource e, loc), st) end - | EServerCall (e1, e2, t, ef) => + | EServerCall (e1, t, ef) => let val (e1, st) = exp outer (e1, st) - val (e2, st) = exp outer (e2, st) in - ((EServerCall (e1, e2, t, ef), loc), st) + ((EServerCall (e1, t, ef), loc), st) end | ERecv (e1, e2, t) => let
--- a/src/mono.sml Sun Oct 25 13:12:24 2009 -0400 +++ b/src/mono.sml Sun Oct 25 14:07:10 2009 -0400 @@ -113,8 +113,8 @@ | ESignalReturn of exp | ESignalBind of exp * exp | ESignalSource of exp - - | EServerCall of exp * exp * typ * effect + + | EServerCall of exp * typ * effect | ERecv of exp * exp * typ | ESleep of exp * exp
--- a/src/mono_print.sml Sun Oct 25 13:12:24 2009 -0400 +++ b/src/mono_print.sml Sun Oct 25 14:07:10 2009 -0400 @@ -335,11 +335,9 @@ p_exp env e, string ")"] - | EServerCall (n, e, _, _) => box [string "Server(", - p_exp env n, - string ")[", - p_exp env e, - string "]"] + | EServerCall (n, _, _) => box [string "Server(", + p_exp env n, + string ")"] | ERecv (n, e, _) => box [string "Recv(", p_exp env n, string ")[",
--- a/src/mono_reduce.sml Sun Oct 25 13:12:24 2009 -0400 +++ b/src/mono_reduce.sml Sun Oct 25 14:07:10 2009 -0400 @@ -450,7 +450,7 @@ | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2 | ESignalSource e => summarize d e - | EServerCall (e, _, _, _) => summarize d e @ [Unsure] + | EServerCall (e, _, _) => summarize d e @ [Unsure] | ERecv (e, _, _) => summarize d e @ [Unsure] | ESleep (e, _) => summarize d e @ [Unsure] in
--- a/src/mono_util.sml Sun Oct 25 13:12:24 2009 -0400 +++ b/src/mono_util.sml Sun Oct 25 14:07:10 2009 -0400 @@ -362,14 +362,12 @@ fn e' => (ESignalSource e', loc)) - | EServerCall (s, ek, t, eff) => + | EServerCall (s, t, eff) => S.bind2 (mfe ctx s, fn s' => - S.bind2 (mfe ctx ek, - fn ek' => - S.map2 (mft t, - fn t' => - (EServerCall (s', ek', t', eff), loc)))) + S.map2 (mft t, + fn t' => + (EServerCall (s', t', eff), loc))) | ERecv (s, ek, t) => S.bind2 (mfe ctx s, fn s' =>
--- a/src/monoize.sml Sun Oct 25 13:12:24 2009 -0400 +++ b/src/monoize.sml Sun Oct 25 14:07:10 2009 -0400 @@ -3201,22 +3201,7 @@ ((L'.ELet (x, t', e1, e2), loc), fm) end - | L.ETailCall (n, es, ek, _, (L.TRecord (L.CRecord (_, []), _), _)) => - let - val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es - val (ek, fm) = monoExp (env, st, fm) ek - - val e = (L'.ENamed n, loc) - val e = foldl (fn (arg, e) => (L'.EApp (e, arg), loc)) e es - val e = (L'.EApp (e, ek), loc) - in - (e, fm) - end - | L.ETailCall _ => (E.errorAt loc "Full scope of tail call continuation isn't known"; - Print.eprefaces' [("Expression", CorePrint.p_exp env all)]; - (dummyExp, fm)) - - | L.EServerCall (n, es, ek, t, (L.TRecord (L.CRecord (_, []), _), _)) => + | L.EServerCall (n, es, t) => let val t = monoType env t val (_, ft, _, name) = Env.lookupENamed env n @@ -3239,37 +3224,19 @@ val call = foldl (fn (e, call) => (L'.EStrcat (call, e), loc)) (L'.EPrim (Prim.String name), loc) call - val (ek, fm) = monoExp (env, st, fm) ek - val unit = (L'.TRecord [], loc) - val ekf = (L'.EAbs ("f", - (L'.TFun (t, - (L'.TFun ((L'.TRecord [], loc), - (L'.TRecord [], loc)), loc)), loc), - (L'.TFun (t, - (L'.TRecord [], loc)), loc), - (L'.EAbs ("x", - t, - (L'.TRecord [], loc), - (L'.EApp ((L'.EApp ((L'.ERel 1, loc), - (L'.ERel 0, loc)), loc), - (L'.ERecord [], loc)), loc)), loc)), loc) - val ek = (L'.EApp (ekf, ek), loc) val eff = if IS.member (!readCookie, n) then L'.ReadCookieWrite else L'.ReadOnly - val e = (L'.EServerCall (call, ek, t, eff), loc) + val e = (L'.EServerCall (call, t, eff), loc) val e = liftExpInExp 0 e val e = (L'.EAbs ("_", unit, unit, e), loc) in (e, fm) end - | L.EServerCall _ => (E.errorAt loc "Full scope of server call continuation isn't known"; - Print.eprefaces' [("Expression", CorePrint.p_exp env all)]; - (dummyExp, fm)) | L.EKAbs _ => poly () | L.EKApp _ => poly ()
--- a/src/reduce.sml Sun Oct 25 13:12:24 2009 -0400 +++ b/src/reduce.sml Sun Oct 25 14:07:10 2009 -0400 @@ -409,102 +409,6 @@ case #1 e of EApp ((EApp - ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), - t1), - _), t2), _), - (EFfi ("Basis", "transaction_monad"), _)), _), - (EServerCall (n, es, (EAbs (_, _, _, ke), _), dom, ran), _)), _), - trans3) => - let - val e' = (EFfi ("Basis", "bind"), loc) - val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) - val e' = (ECApp (e', dom), loc) - val e' = (ECApp (e', t2), loc) - val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc) - val e' = (EApp (e', ke), loc) - val e' = (EApp (e', E.liftExpInExp 0 trans3), loc) - val e' = reassoc e' - val e' = (EAbs ("x", dom, t2, e'), loc) - val e' = (EServerCall (n, es, e', dom, t2), loc) - in - e' - end - - | EApp - ((EApp - ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), - t1), - _), t2), _), - (EFfi ("Basis", "transaction_monad"), _)), _), - (EServerCall (n, es, ke, dom, ran), _)), _), - trans3) => - let - val e' = (EFfi ("Basis", "bind"), loc) - val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) - val e' = (ECApp (e', dom), loc) - val e' = (ECApp (e', t2), loc) - val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc) - val e' = (EApp (e', exp (UnknownE :: env') - (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), - loc) - val e' = (EApp (e', E.liftExpInExp 0 trans3), loc) - val e' = reassoc e' - val e' = (EAbs ("x", dom, t2, e'), loc) - val e' = (EServerCall (n, es, e', dom, t2), loc) - in - e' - end - - | EApp - ((EApp - ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), - t1), - _), t2), _), - (EFfi ("Basis", "transaction_monad"), _)), _), - (ETailCall (n, es, (EAbs (_, _, _, ke), _), dom, ran), _)), _), - trans3) => - let - val e' = (EFfi ("Basis", "bind"), loc) - val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) - val e' = (ECApp (e', dom), loc) - val e' = (ECApp (e', t2), loc) - val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc) - val e' = (EApp (e', ke), loc) - val e' = (EApp (e', E.liftExpInExp 0 trans3), loc) - val e' = reassoc e' - val e' = (EAbs ("x", dom, t2, e'), loc) - val e' = (ETailCall (n, es, e', dom, t2), loc) - in - e' - end - - | EApp - ((EApp - ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), - t1), - _), t2), _), - (EFfi ("Basis", "transaction_monad"), _)), _), - (ETailCall (n, es, ke, dom, ran), _)), _), - trans3) => - let - val e' = (EFfi ("Basis", "bind"), loc) - val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) - val e' = (ECApp (e', dom), loc) - val e' = (ECApp (e', t2), loc) - val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc) - val e' = (EApp (e', exp (UnknownE :: env') - (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), - loc) - val e' = (EApp (e', E.liftExpInExp 0 trans3), loc) - val e' = reassoc e' - val e' = (EAbs ("x", dom, t2, e'), loc) - val e' = (ETailCall (n, es, e', dom, t2), loc) - in - e' - end - - | EApp - ((EApp ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), mt), _), _), _), t3), _), me), _), @@ -792,10 +696,7 @@ | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (UnknownE :: env) e2), loc) - | EServerCall (n, es, e, t1, t2) => (EServerCall (n, map (exp env) es, exp env e, - con env t1, con env t2), loc) - | ETailCall (n, es, e, t1, t2) => (ETailCall (n, map (exp env) es, exp env e, - con env t1, con env t2), loc) + | EServerCall (n, es, t) => (EServerCall (n, map (exp env) es, con env t), loc) in (*if dangling (edepth' (deKnown env)) r then (Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all),
--- a/src/reduce_local.sml Sun Oct 25 13:12:24 2009 -0400 +++ b/src/reduce_local.sml Sun Oct 25 14:07:10 2009 -0400 @@ -139,8 +139,7 @@ | ELet (x, t, e1, e2) => (ELet (x, t, exp env e1, exp (Unknown :: env) e2), loc) - | EServerCall (n, es, e, t1, t2) => (EServerCall (n, map (exp env) es, exp env e, t1, t2), loc) - | ETailCall (n, es, e, t1, t2) => (ETailCall (n, map (exp env) es, exp env e, t1, t2), loc) + | EServerCall (n, es, t) => (EServerCall (n, map (exp env) es, t), loc) fun reduce file = let
--- a/src/rpcify.sml Sun Oct 25 13:12:24 2009 -0400 +++ b/src/rpcify.sml Sun Oct 25 14:07:10 2009 -0400 @@ -112,11 +112,7 @@ val st = {exported = exported, export_decls = export_decls} - val k = (ECApp ((EFfi ("Basis", "return"), loc), - (CFfi ("Basis", "transaction"), loc)), loc) - val k = (ECApp (k, ran), loc) - val k = (EApp (k, (EFfi ("Basis", "transaction_monad"), loc)), loc) - val e' = EServerCall (n, args, k, ran, ran) + val e' = EServerCall (n, args, ran) in (e', st) end
--- a/src/shake.sml Sun Oct 25 13:12:24 2009 -0400 +++ b/src/shake.sml Sun Oct 25 14:07:10 2009 -0400 @@ -137,8 +137,7 @@ in case e of ENamed n => check n - | EServerCall (n, _, _, _, _) => check n - | ETailCall (n, _, _, _, _) => check n + | EServerCall (n, _, _) => check n | _ => s end
--- a/src/sources Sun Oct 25 13:12:24 2009 -0400 +++ b/src/sources Sun Oct 25 14:07:10 2009 -0400 @@ -131,9 +131,6 @@ rpcify.sig rpcify.sml -tailify.sig -tailify.sml - tag.sig tag.sml
--- a/src/tailify.sig Sun Oct 25 13:12:24 2009 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,32 +0,0 @@ -(* Copyright (c) 2009, 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 TAILIFY = sig - - val frob : Core.file -> Core.file - -end
--- a/src/tailify.sml Sun Oct 25 13:12:24 2009 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,206 +0,0 @@ -(* Copyright (c) 2009, 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 Tailify :> TAILIFY = struct - -open Core - -structure U = CoreUtil -structure E = CoreEnv - -fun multiLiftExpInExp n e = - if n = 0 then - e - else - multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e) - -structure IS = IntBinarySet -structure IM = IntBinaryMap - -type state = { - cpsed : exp' IM.map, - rpc : IS.set -} - -fun frob file = - let - fun exp (e, st : state) = - case e of - ENamed n => - (case IM.find (#cpsed st, n) of - NONE => (e, st) - | SOME re => (re, st)) - - | _ => (e, st) - - and doExp (e, st) = U.Exp.foldMap {kind = fn x => x, - con = fn x => x, - exp = exp} st (ReduceLocal.reduceExp e) - - fun decl (d, st : state) = - let - fun makesServerCall b (e, _) = - case e of - EServerCall _ => true - | ETailCall _ => raise Fail "Tailify: ETailCall too early" - | ENamed n => IS.member (#rpc st, n) - - | EPrim _ => false - | ERel n => List.nth (b, n) - | ECon (_, _, _, NONE) => false - | ECon (_, _, _, SOME e) => makesServerCall b e - | EFfi _ => false - | EFfiApp (_, _, es) => List.exists (makesServerCall b) es - | EApp (e1, e2) => makesServerCall b e1 orelse makesServerCall b e2 - | EAbs (_, _, _, e1) => makesServerCall (false :: b) e1 - | ECApp (e1, _) => makesServerCall b e1 - | ECAbs (_, _, e1) => makesServerCall b e1 - - | EKAbs (_, e1) => makesServerCall b e1 - | EKApp (e1, _) => makesServerCall b e1 - - | ERecord xes => List.exists (fn ((CName s, _), e, _) => - not (String.isPrefix "On" s) andalso makesServerCall b e - | (_, e, _) => makesServerCall b e) xes - | EField (e1, _, _) => makesServerCall b e1 - | EConcat (e1, _, e2, _) => makesServerCall b e1 orelse makesServerCall b e2 - | ECut (e1, _, _) => makesServerCall b e1 - | ECutMulti (e1, _, _) => makesServerCall b e1 - - | ECase (e1, pes, _) => makesServerCall b e1 - orelse List.exists (fn (p, e) => - makesServerCall (List.tabulate (E.patBindsN p, - fn _ => false) @ b) - e) pes - - | EWrite e1 => makesServerCall b e1 - - | EClosure (_, es) => List.exists (makesServerCall b) es - - | ELet (_, _, e1, e2) => makesServerCall (makesServerCall b e1 :: b) e2 - - val makesServerCall = makesServerCall [] - - val (d, st) = - case #1 d of - DValRec vis => - if List.exists (fn (_, _, _, e, _) => makesServerCall e) vis then - let - val rpc = foldl (fn ((_, n, _, _, _), rpc) => - IS.add (rpc, n)) (#rpc st) vis - - val (cpsed, vis') = - foldl (fn (vi as (x, n, t, e, s), (cpsed, vis')) => - let - fun getArgs (t, acc) = - case #1 t of - TFun (dom, ran) => - getArgs (ran, dom :: acc) - | _ => (rev acc, t) - val (ts, ran) = getArgs (t, []) - val ran = case #1 ran of - CApp (_, ran) => ran - | _ => raise Fail "Rpcify: Tail function not transactional" - val len = length ts - - val loc = #2 e - val args = ListUtil.mapi - (fn (i, _) => - (ERel (len - i - 1), loc)) - ts - val k = (EFfi ("Basis", "return"), loc) - val trans = (CFfi ("Basis", "transaction"), loc) - val k = (ECApp (k, trans), loc) - val k = (ECApp (k, ran), loc) - val k = (EApp (k, (EFfi ("Basis", "transaction_monad"), - loc)), loc) - val re = (ETailCall (n, args, k, ran, ran), loc) - val (re, _) = foldr (fn (dom, (re, ran)) => - ((EAbs ("x", dom, ran, re), - loc), - (TFun (dom, ran), loc))) - (re, ran) ts - - val be = multiLiftExpInExp (len + 1) e - val be = ListUtil.foldli - (fn (i, _, be) => - (EApp (be, (ERel (len - i), loc)), loc)) - be ts - val ne = (EFfi ("Basis", "bind"), loc) - val ne = (ECApp (ne, trans), loc) - val ne = (ECApp (ne, ran), loc) - val unit = (TRecord (CRecord ((KType, loc), []), - loc), loc) - val ne = (ECApp (ne, unit), loc) - val ne = (EApp (ne, (EFfi ("Basis", "transaction_monad"), - loc)), loc) - val ne = (EApp (ne, be), loc) - val ne = (EApp (ne, (ERel 0, loc)), loc) - val tunit = (CApp (trans, unit), loc) - val kt = (TFun (ran, tunit), loc) - val ne = (EAbs ("k", kt, tunit, ne), loc) - val (ne, res) = foldr (fn (dom, (ne, ran)) => - ((EAbs ("x", dom, ran, ne), loc), - (TFun (dom, ran), loc))) - (ne, (TFun (kt, tunit), loc)) ts - in - (IM.insert (cpsed, n, #1 re), - (x, n, res, ne, s) :: vis') - end) - (#cpsed st, []) vis - in - ((DValRec (rev vis'), ErrorMsg.dummySpan), - {cpsed = cpsed, - rpc = rpc}) - end - else - (d, st) - | DVal (x, n, t, e, s) => - (d, - {cpsed = #cpsed st, - rpc = if makesServerCall e then - IS.add (#rpc st, n) - else - #rpc st}) - | _ => (d, st) - in - U.Decl.foldMap {kind = fn x => x, - con = fn x => x, - exp = exp, - decl = fn x => x} - st d - end - - val (file, _) = ListUtil.foldlMap decl - {cpsed = IM.empty, - rpc = IS.empty} - file - in - file - end - -end