summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--CHANGELOG9
-rw-r--r--lib/js/urweb.js16
-rw-r--r--src/compiler.sig2
-rw-r--r--src/compiler.sml9
-rw-r--r--src/core.sml3
-rw-r--r--src/core_print.sml22
-rw-r--r--src/core_untangle.sml3
-rw-r--r--src/core_util.sml35
-rw-r--r--src/effectize.sml4
-rw-r--r--src/jscomp.sml12
-rw-r--r--src/mono.sml4
-rw-r--r--src/mono_print.sml8
-rw-r--r--src/mono_reduce.sml2
-rw-r--r--src/mono_util.sml10
-rw-r--r--src/monoize.sml37
-rw-r--r--src/reduce.sml101
-rw-r--r--src/reduce_local.sml3
-rw-r--r--src/rpcify.sml6
-rw-r--r--src/shake.sml3
-rw-r--r--src/sources3
-rw-r--r--src/tailify.sig32
-rw-r--r--src/tailify.sml206
22 files changed, 59 insertions, 471 deletions
diff --git a/CHANGELOG b/CHANGELOG
index b45fbe74..f1a1b7db 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,4 +1,13 @@
========
+Next
+========
+
+- Bug fixes
+- Optimization improvements
+- Removed a restriction that prevented some RPCs from compiling
+- New extra demo: conference1
+
+========
20091012
========
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index 653f8d2f..6ca4becd 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -632,7 +632,7 @@ function rc(prefix, uri, parse, k, needsSig) {
if (isok) {
try {
- execF(k, parse(xhr.responseText));
+ k(parse(xhr.responseText));
} catch (v) {
doExn(v);
}
@@ -854,7 +854,11 @@ function execP(env, p, v) {
}
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 @@ function exec0(env, e) {
case "f":
fr.args[fr.pos++] = v;
if (fr.a == null) {
- e = {c: "c", v: fr.f.apply(null, fr.args)};
stack = stack.next;
+ e = {c: "c", v: fr.f.apply(null, fr.args)};
+ if (usedK) return null;
} else {
e = fr.a.data;
fr.a = fr.a.next;
@@ -1014,6 +1019,11 @@ function exec0(env, e) {
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);
}
diff --git a/src/compiler.sig b/src/compiler.sig
index 5192cf6e..3f04801f 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -86,7 +86,6 @@ signature COMPILER = sig
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 @@ signature COMPILER = sig
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
diff --git a/src/compiler.sml b/src/compiler.sml
index b1939356..6fd107a7 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -779,14 +779,7 @@ val toShake3 = transform shake "shake3" o toSpecialize
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
diff --git a/src/core.sml b/src/core.sml
index 04126cc0..6bead3dc 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -115,8 +115,7 @@ datatype exp' =
| 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
diff --git a/src/core_print.sml b/src/core_print.sml
index 64a4e461..02407f01 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -438,22 +438,12 @@ fun p_exp' par env (e, _) =
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,
diff --git a/src/core_untangle.sml b/src/core_untangle.sml
index f00bd95b..d734cc6f 100644
--- a/src/core_untangle.sml
+++ b/src/core_untangle.sml
@@ -48,8 +48,7 @@ fun exp thisGroup (e, s) =
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
diff --git a/src/core_util.sml b/src/core_util.sml
index 4722eca1..cedde841 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -532,20 +532,12 @@ fun compare ((e1, _), (e2, _)) =
| (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 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
fn e2' =>
(ELet (x, t', e1', e2'), loc))))
- | EServerCall (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' =>
- (EServerCall (n, es', e', t1', t2'), loc)))))
-
- | ETailCall (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' =>
- (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,
diff --git a/src/effectize.sml b/src/effectize.sml
index d458561d..fcaaa79e 100644
--- a/src/effectize.sml
+++ b/src/effectize.sml
@@ -46,7 +46,7 @@ fun effectize file =
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 @@ fun effectize file =
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,
diff --git a/src/jscomp.sml b/src/jscomp.sml
index b6e4a3b6..9d456c5c 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -900,10 +900,9 @@ fun process file =
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 @@ fun process file =
^ "\"},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 @@ fun process file =
((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
diff --git a/src/mono.sml b/src/mono.sml
index 64ed448c..7ce6cee1 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -113,8 +113,8 @@ datatype exp' =
| 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
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 71bc734a..49b636c3 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -335,11 +335,9 @@ fun p_exp' par env (e, _) =
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 ")[",
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 40d3c9e5..d09c957c 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -450,7 +450,7 @@ fun reduce file =
| 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
diff --git a/src/mono_util.sml b/src/mono_util.sml
index c660a4a3..24024470 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -362,14 +362,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
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' =>
diff --git a/src/monoize.sml b/src/monoize.sml
index 0a9f8e86..ff01b7f7 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3201,22 +3201,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
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 ()
diff --git a/src/reduce.sml b/src/reduce.sml
index 38465fda..1310c7d0 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -409,102 +409,6 @@ fun kindConAndExp (namedC, namedE) =
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 @@ fun kindConAndExp (namedC, namedE) =
| 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),
diff --git a/src/reduce_local.sml b/src/reduce_local.sml
index ae752304..a9f28617 100644
--- a/src/reduce_local.sml
+++ b/src/reduce_local.sml
@@ -139,8 +139,7 @@ fun exp env (all as (e, loc)) =
| 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
diff --git a/src/rpcify.sml b/src/rpcify.sml
index 0e5a1076..3569e2bc 100644
--- a/src/rpcify.sml
+++ b/src/rpcify.sml
@@ -112,11 +112,7 @@ fun frob file =
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
diff --git a/src/shake.sml b/src/shake.sml
index 501f8209..ea97dafa 100644
--- a/src/shake.sml
+++ b/src/shake.sml
@@ -137,8 +137,7 @@ fun shake file =
in
case e of
ENamed n => check n
- | EServerCall (n, _, _, _, _) => check n
- | ETailCall (n, _, _, _, _) => check n
+ | EServerCall (n, _, _) => check n
| _ => s
end
diff --git a/src/sources b/src/sources
index 54910b8f..ddc7deff 100644
--- a/src/sources
+++ b/src/sources
@@ -131,9 +131,6 @@ especialize.sml
rpcify.sig
rpcify.sml
-tailify.sig
-tailify.sml
-
tag.sig
tag.sml
diff --git a/src/tailify.sig b/src/tailify.sig
deleted file mode 100644
index c0d1fb35..00000000
--- a/src/tailify.sig
+++ /dev/null
@@ -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
diff --git a/src/tailify.sml b/src/tailify.sml
deleted file mode 100644
index 4b086e09..00000000
--- a/src/tailify.sml
+++ /dev/null
@@ -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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-08 20:20:29 +0000