summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-09-17 16:35:11 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-09-17 16:35:11 -0400
commitae83d3e44959b43c167ba83736055bf94ace3113 (patch)
tree9d7a2e3bc1dff89e7399d555415ffae5c45c8b52
parentbf1a78ce9a5d60f8f4c40d0087f6caf90c10a796 (diff)
Basic tail recursion introduction seems to be working
-rw-r--r--demo/more/dlist.ur18
-rw-r--r--demo/more/dlist.urs2
-rw-r--r--demo/more/grid.ur17
-rw-r--r--src/core.sml1
-rw-r--r--src/core_print.sml8
-rw-r--r--src/core_untangle.sml27
-rw-r--r--src/core_util.sml18
-rw-r--r--src/monoize.sml15
-rw-r--r--src/reduce.sml2
-rw-r--r--src/reduce_local.sml1
-rw-r--r--src/rpcify.sml187
-rw-r--r--src/shake.sml1
-rw-r--r--tests/tail.ur15
-rw-r--r--tests/tail.urp3
-rw-r--r--tests/tail.urs1
15 files changed, 293 insertions, 23 deletions
diff --git a/demo/more/dlist.ur b/demo/more/dlist.ur
index a8c464a6..6e660ab8 100644
--- a/demo/more/dlist.ur
+++ b/demo/more/dlist.ur
@@ -48,6 +48,24 @@ fun append [t] dl v =
set tl new;
return (tailPos cur new tl)
+fun replace [t] dl ls =
+ case ls of
+ [] => set dl Empty
+ | x :: ls =>
+ tl <- source Nil;
+ let
+ fun build ls acc =
+ case ls of
+ [] => return acc
+ | x :: ls =>
+ this <- source (Cons (x, tl));
+ build ls this
+ in
+ hd <- build (List.rev ls) tl;
+ tlS <- source tl;
+ set dl (Nonempty {Head = Cons (x, hd), Tail = tlS})
+ end
+
fun renderDyn [ctx] [ctx ~ body] [t] (f : t -> position -> xml (ctx ++ body) [] []) filter dl = <xml>
<dyn signal={dl' <- signal dl;
return (case dl' of
diff --git a/demo/more/dlist.urs b/demo/more/dlist.urs
index b912139e..b25e41a1 100644
--- a/demo/more/dlist.urs
+++ b/demo/more/dlist.urs
@@ -4,6 +4,8 @@ type position
val create : t ::: Type -> transaction (dlist t)
val clear : t ::: Type -> dlist t -> transaction unit
val append : t ::: Type -> dlist t -> t -> transaction position
+val replace : t ::: Type -> dlist t -> list t -> transaction unit
+
val delete : position -> transaction unit
val elements : t ::: Type -> dlist t -> signal (list t)
val foldl : t ::: Type -> acc ::: Type -> (t -> acc -> signal acc) -> acc -> dlist t -> signal acc
diff --git a/demo/more/grid.ur b/demo/more/grid.ur
index 2b451456..a4157991 100644
--- a/demo/more/grid.ur
+++ b/demo/more/grid.ur
@@ -59,16 +59,20 @@ functor Make(M : sig
Selection : source bool,
Filters : $(map thd3 M.cols)}
- fun addRow cols rows row =
+ fun newRow cols row =
rowS <- source row;
cols <- makeAll cols row;
colsS <- source cols;
ud <- source False;
sd <- source False;
- Monad.ignore (Dlist.append rows {Row = rowS,
- Cols = colsS,
- Updating = ud,
- Selected = sd})
+ return {Row = rowS,
+ Cols = colsS,
+ Updating = ud,
+ Selected = sd}
+
+ fun addRow cols rows row =
+ r <- newRow cols row;
+ Monad.ignore (Dlist.append rows r)
val grid =
cols <- Monad.mapR [colMeta M.row] [fst3]
@@ -91,7 +95,8 @@ functor Make(M : sig
fun sync {Cols = cols, Rows = rows, ...} =
Dlist.clear rows;
init <- rpc M.list;
- List.app (addRow cols rows) init
+ rs <- List.mapM (newRow cols) init;
+ Dlist.replace rows rs
fun render grid = <xml>
<table class={tabl}>
diff --git a/src/core.sml b/src/core.sml
index 2b2d5ca5..04126cc0 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -116,6 +116,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
withtype exp = exp' located
diff --git a/src/core_print.sml b/src/core_print.sml
index 84b247a2..64a4e461 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -446,6 +446,14 @@ fun p_exp' par env (e, _) =
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 "]"]
| EKAbs (x, e) => box [string x,
space,
diff --git a/src/core_untangle.sml b/src/core_untangle.sml
index 480ec7a4..f00bd95b 100644
--- a/src/core_untangle.sml
+++ b/src/core_untangle.sml
@@ -38,19 +38,20 @@ structure IM = IntBinaryMap
fun default (k, s) = s
fun exp thisGroup (e, s) =
- case e of
- ENamed n =>
- if IS.member (thisGroup, n) then
- IS.add (s, n)
- else
- s
- | EClosure (n, _) =>
- if IS.member (thisGroup, n) then
- IS.add (s, n)
- else
- s
-
- | _ => s
+ let
+ fun try n =
+ if IS.member (thisGroup, n) then
+ IS.add (s, n)
+ else
+ s
+ in
+ case e of
+ ENamed n => try n
+ | EClosure (n, _) => try n
+ | EServerCall (n, _, _, _, _) => try n
+ | ETailCall (n, _, _, _, _) => try n
+ | _ => s
+ end
fun untangle file =
let
diff --git a/src/core_util.sml b/src/core_util.sml
index 197f688a..4722eca1 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -539,6 +539,13 @@ fun compare ((e1, _), (e2, _)) =
| (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
@@ -729,6 +736,17 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
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)))))
+
| EKAbs (x, e) =>
S.map2 (mfe (bind (ctx, RelK x)) e,
fn e' =>
diff --git a/src/monoize.sml b/src/monoize.sml
index 9a3858f8..83a520c8 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3137,6 +3137,21 @@ 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 (e, arg) => (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 (_, []), _), _)) =>
let
val t = monoType env t
diff --git a/src/reduce.sml b/src/reduce.sml
index bcd502cc..137dd02f 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -745,6 +745,8 @@ fun kindConAndExp (namedC, namedE) =
| 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)
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 9ea5a16d..ae752304 100644
--- a/src/reduce_local.sml
+++ b/src/reduce_local.sml
@@ -140,6 +140,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)
fun reduce file =
let
diff --git a/src/rpcify.sml b/src/rpcify.sml
index 75f80940..0a1ac8ef 100644
--- a/src/rpcify.sml
+++ b/src/rpcify.sml
@@ -32,6 +32,12 @@ 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
@@ -42,7 +48,10 @@ structure SS = BinarySetFn(struct
type state = {
exported : IS.set,
- export_decls : decl list
+ export_decls : decl list,
+
+ cpsed : exp' IM.map,
+ rpc : IS.set
}
fun frob file =
@@ -115,7 +124,9 @@ fun frob file =
(DExport (Rpc ReadWrite, n), loc) :: #export_decls st)
val st = {exported = exported,
- export_decls = export_decls}
+ export_decls = export_decls,
+ cpsed = #cpsed st,
+ rpc = #rpc st}
val k = (ECApp ((EFfi ("Basis", "return"), loc),
(CFfi ("Basis", "transaction"), loc)), loc)
@@ -134,6 +145,11 @@ fun frob file =
else
(e, st)
+ | ENamed n =>
+ (case IM.find (#cpsed st, n) of
+ NONE => (e, st)
+ | SOME re => (re, st))
+
| _ => (e, st)
end
@@ -143,6 +159,165 @@ fun frob file =
fun decl (d, st : state) =
let
+ val makesServerCall = U.Exp.exists {kind = fn _ => false,
+ con = fn _ => false,
+ exp = fn EFfi ("Basis", "rpc") => true
+ | ENamed n => IS.member (#rpc st, n)
+ | _ => false}
+
+ val (d, st) =
+ case #1 d of
+ DValRec vis =>
+ if List.exists (fn (_, _, _, e, _) => makesServerCall e) vis then
+ let
+ val all = foldl (fn ((_, n, _, _, _), all) => IS.add (all, n)) IS.empty vis
+
+ val usesRec = U.Exp.exists {kind = fn _ => false,
+ con = fn _ => false,
+ exp = fn ENamed n => IS.member (all, n)
+ | _ => false}
+
+ val noRec = not o usesRec
+
+ fun tailOnly (e, _) =
+ case e of
+ EPrim _ => true
+ | ERel _ => true
+ | ENamed _ => true
+ | ECon (_, _, _, SOME e) => noRec e
+ | ECon _ => true
+ | EFfi _ => true
+ | EFfiApp (_, _, es) => List.all noRec es
+ | EApp (e1, e2) => noRec e2 andalso tailOnly e1
+ | EAbs (_, _, _, e) => noRec e
+ | ECApp (e1, _) => tailOnly e1
+ | ECAbs (_, _, e) => noRec e
+
+ | EKAbs (_, e) => noRec e
+ | EKApp (e1, _) => tailOnly e1
+
+ | ERecord xes => List.all (noRec o #2) xes
+ | EField (e1, _, _) => noRec e1
+ | EConcat (e1, _, e2, _) => noRec e1 andalso noRec e2
+ | ECut (e1, _, _) => noRec e1
+ | ECutMulti (e1, _, _) => noRec e1
+
+ | ECase (e1, pes, _) => noRec e1 andalso List.all (tailOnly o #2) pes
+
+ | EWrite e1 => noRec e1
+
+ | EClosure (_, es) => List.all noRec es
+
+ | ELet (_, _, e1, e2) => noRec e1 andalso tailOnly e2
+
+ | EServerCall (_, es, (EAbs (_, _, _, e), _), _, _) =>
+ List.all noRec es andalso tailOnly e
+ | EServerCall (_, es, e, _, _) => List.all noRec es andalso noRec e
+
+ | ETailCall _ => raise Fail "Rpcify: ETailCall too early"
+
+ fun tailOnlyF e =
+ case #1 e of
+ EAbs (_, _, _, e) => tailOnlyF e
+ | ECAbs (_, _, e) => tailOnlyF e
+ | EKAbs (_, e) => tailOnlyF e
+ | _ => tailOnly e
+
+ val nonTail = foldl (fn ((_, n, _, e, _), nonTail) =>
+ if tailOnlyF e then
+ nonTail
+ else
+ IS.add (nonTail, n)) IS.empty vis
+ in
+ if IS.isEmpty nonTail then
+ (d, {exported = #exported st,
+ export_decls = #export_decls st,
+ cpsed = #cpsed st,
+ rpc = IS.union (#rpc st, all)})
+ else
+ 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')) =>
+ if IS.member (nonTail, n) then
+ 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 = (EAbs ("x", ran, ran, (ERel 0, 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 trans = (CFfi ("Basis", "transaction"), 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
+ else
+ (cpsed, vi :: vis'))
+ (#cpsed st, []) vis
+ in
+ ((DValRec (rev vis'), ErrorMsg.dummySpan),
+ {exported = #exported st,
+ export_decls = #export_decls st,
+ cpsed = cpsed,
+ rpc = rpc})
+ end
+ end
+ else
+ (d, st)
+ | DVal (x, n, t, e, s) =>
+ (d,
+ {exported = #exported st,
+ export_decls = #export_decls st,
+ cpsed = #cpsed st,
+ rpc = if makesServerCall e then
+ IS.add (#rpc st, n)
+ else
+ #rpc st})
+ | _ => (d, st)
+
val (d, st) = U.Decl.foldMap {kind = fn x => x,
con = fn x => x,
exp = exp,
@@ -151,12 +326,16 @@ fun frob file =
in
(#export_decls st @ [d],
{exported = #exported st,
- export_decls = []})
+ export_decls = [],
+ cpsed = #cpsed st,
+ rpc = #rpc st})
end
val (file, _) = ListUtil.foldlMapConcat decl
{exported = IS.empty,
- export_decls = []}
+ export_decls = [],
+ cpsed = IM.empty,
+ rpc = rpcBaseIds}
file
in
file
diff --git a/src/shake.sml b/src/shake.sml
index e27e9839..501f8209 100644
--- a/src/shake.sml
+++ b/src/shake.sml
@@ -138,6 +138,7 @@ fun shake file =
case e of
ENamed n => check n
| EServerCall (n, _, _, _, _) => check n
+ | ETailCall (n, _, _, _, _) => check n
| _ => s
end
diff --git a/tests/tail.ur b/tests/tail.ur
new file mode 100644
index 00000000..259b5f34
--- /dev/null
+++ b/tests/tail.ur
@@ -0,0 +1,15 @@
+fun one () = return 1
+
+fun addEm n =
+ if n = 0 then
+ return 0
+ else
+ n1 <- rpc (one ());
+ n2 <- addEm (n - 1);
+ return (n1 + n2)
+
+fun main () =
+ s <- source 0;
+ return <xml><body onload={n <- addEm 3; set s n}>
+ <dyn signal={n <- signal s; return (txt n)}/>
+ </body></xml>
diff --git a/tests/tail.urp b/tests/tail.urp
new file mode 100644
index 00000000..5063c0b7
--- /dev/null
+++ b/tests/tail.urp
@@ -0,0 +1,3 @@
+debug
+
+tail
diff --git a/tests/tail.urs b/tests/tail.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/tail.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page