Basic tail recursion introduction seems to be working

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