changeset 908:ed06e25c70ef

Convert to requiring explicit 'rpc' marker
author Adam Chlipala <adamc@hcoop.net>
date Sat, 22 Aug 2009 12:55:18 -0400
parents 5fe49effbc83
children 1d3f60e74ec7
files demo/batch.ur demo/batchFun.ur demo/chat.ur demo/increment.ur demo/noisy.ur demo/roundTrip.ur lib/ur/basis.urs lib/ur/list.ur lib/ur/list.urs src/core.sml src/core_print.sml src/core_util.sml src/effectize.sml src/monoize.sml src/reduce.sml src/reduce_local.sml src/rpcify.sml src/shake.sml
diffstat 18 files changed, 204 insertions(+), 408 deletions(-) [+]
line wrap: on
line diff
--- a/demo/batch.ur	Tue Aug 11 12:01:54 2009 -0400
+++ b/demo/batch.ur	Sat Aug 22 12:55:18 2009 -0400
@@ -25,7 +25,8 @@
                 Nil => <xml/>
               | Cons ((id, a), ls) => <xml>
                 <tr><td>{[id]}</td> <td>{[a]}</td> {if withDel then
-                                                        <xml><td><button value="Delete" onclick={del id}/></td></xml>
+                                                        <xml><td><button value="Delete" onclick={rpc (del id)}/>
+                                                        </td></xml>
                                                     else
                                                         <xml/>} </tr>
                 {show' ls}
@@ -55,7 +56,7 @@
         fun exec () =
             ls <- get batched;
 
-            doBatch ls;
+            rpc (doBatch ls);
             set batched Nil
     in
         return <xml><body>
@@ -63,7 +64,7 @@
 
           {show True lss}
 
-          <button value="Update" onclick={ls <- allRows (); set lss ls}/><br/>
+          <button value="Update" onclick={ls <- rpc (allRows ()); set lss ls}/><br/>
           <br/>
 
           <h2>Batch new rows to add</h2>
--- a/demo/batchFun.ur	Tue Aug 11 12:01:54 2009 -0400
+++ b/demo/batchFun.ur	Sat Aug 22 12:55:18 2009 -0400
@@ -78,7 +78,7 @@
                                    <xml><td>{m.Show v}</td></xml>)
                                [M.cols] M.fl M.cols (r -- #Id)}
                       {if withDel then
-                           <xml><td><button value="Delete" onclick={del r.Id}/></td></xml>
+                           <xml><td><button value="Delete" onclick={rpc (del r.Id)}/></td></xml>
                        else
                            <xml/>}
                     </tr>
@@ -129,7 +129,7 @@
             fun exec () =
                 ls <- get batched;
 
-                doBatch ls;
+                rpc (doBatch ls);
                 set batched Nil
         in
             return <xml><body>
@@ -137,7 +137,7 @@
 
               {show True lss}
 
-              <button value="Update" onclick={ls <- allRows (); set lss ls}/><br/>
+              <button value="Update" onclick={ls <- rpc (allRows ()); set lss ls}/><br/>
               <br/>
 
               <h2>Batch new rows to add</h2>
--- a/demo/chat.ur	Tue Aug 11 12:01:54 2009 -0400
+++ b/demo/chat.ur	Sat Aug 22 12:55:18 2009 -0400
@@ -35,7 +35,7 @@
         fun doSpeak () =
             line <- get newLine;
             set newLine "";
-            speak line
+            rpc (speak line)
     in
         return <xml><body onload={onload ()}>
           <h1>{[r.T.Title]}</h1>
--- a/demo/increment.ur	Tue Aug 11 12:01:54 2009 -0400
+++ b/demo/increment.ur	Sat Aug 22 12:55:18 2009 -0400
@@ -6,5 +6,5 @@
     src <- source 0;
     return <xml><body>
       <dyn signal={n <- signal src; return <xml>{[n]}</xml>}/>
-      <button value="Update" onclick={n <- increment (); set src n}/>
+      <button value="Update" onclick={n <- rpc (increment ()); set src n}/>
     </body></xml>
--- a/demo/noisy.ur	Tue Aug 11 12:01:54 2009 -0400
+++ b/demo/noisy.ur	Sat Aug 22 12:55:18 2009 -0400
@@ -19,7 +19,7 @@
     case ls of
         Nil => return ()
       | Cons (id, ls') =>
-        ao <- lookup id;
+        ao <- rpc (lookup id);
         alert (case ao of
                    None => "Nada"
                  | Some a => a);
@@ -34,10 +34,10 @@
     return <xml><body>
       <button value="Check values of 1, 2, and 3" onclick={check (Cons (1, Cons (2, Cons (3, Nil))))}/><br/>
       <br/>
-      <button value="Add" onclick={id <- get idAdd; a <- get aAdd; add (readError id) a}/>
+      <button value="Add" onclick={id <- get idAdd; a <- get aAdd; rpc (add (readError id) a)}/>
       <ctextbox source={idAdd}/>
       <ctextbox source={aAdd}/><br/>
       <br/>
-      <button value="Delete" onclick={id <- get idDel; del (readError id)}/>
+      <button value="Delete" onclick={id <- get idDel; rpc (del (readError id))}/>
       <ctextbox source={idDel}/>
     </body></xml>
--- a/demo/roundTrip.ur	Tue Aug 11 12:01:54 2009 -0400
+++ b/demo/roundTrip.ur	Sat Aug 22 12:55:18 2009 -0400
@@ -21,7 +21,7 @@
 
         fun sender s n f =
             sleep 2000;
-            writeBack (s, n, f);
+            rpc (writeBack (s, n, f));
             sender (s ^ "!") (n + 1) (f + 1.23)
     in
         return <xml><body onload={spawn (receiver ()); sender "" 0 0.0}>
--- a/lib/ur/basis.urs	Tue Aug 11 12:01:54 2009 -0400
+++ b/lib/ur/basis.urs	Sat Aug 22 12:55:18 2009 -0400
@@ -125,6 +125,8 @@
 val spawn : transaction unit -> transaction unit
 val sleep : int -> transaction unit
 
+val rpc : t ::: Type -> transaction t -> transaction t
+
 
 (** Channels *)
 
--- a/lib/ur/list.ur	Tue Aug 11 12:01:54 2009 -0400
+++ b/lib/ur/list.ur	Sat Aug 22 12:55:18 2009 -0400
@@ -217,6 +217,13 @@
         app'
     end
 
+fun mapQuery [tables ::: {{Type}}] [exps ::: {Type}] [t ::: Type]
+             [tables ~ exps] (q : sql_query tables exps)
+             (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) -> t) =
+    query q
+          (fn fs acc => return (f fs :: acc))
+          []
+
 fun assoc [a] [b] (_ : eq a) (x : a) =
     let
         fun assoc' (ls : list (a * b)) =
--- a/lib/ur/list.urs	Tue Aug 11 12:01:54 2009 -0400
+++ b/lib/ur/list.urs	Sat Aug 22 12:55:18 2009 -0400
@@ -43,6 +43,11 @@
 val app : m ::: (Type -> Type) -> monad m -> a ::: Type
           -> (a -> m unit) -> t a -> m unit
 
+val mapQuery : tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type
+               -> [tables ~ exps] =>
+    sql_query tables exps
+    -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) -> t)
+    -> transaction (list t)
 
 (** Association lists *)
 
--- a/src/core.sml	Tue Aug 11 12:01:54 2009 -0400
+++ b/src/core.sml	Sat Aug 22 12:55:18 2009 -0400
@@ -115,7 +115,7 @@
 
        | ELet of string * con * exp * exp
 
-       | EServerCall of int * exp list * exp * con
+       | EServerCall of int * exp list * exp * con * con
 
 withtype exp = exp' located
 
--- a/src/core_print.sml	Tue Aug 11 12:01:54 2009 -0400
+++ b/src/core_print.sml	Sat Aug 22 12:55:18 2009 -0400
@@ -437,14 +437,14 @@
                                     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 "]"]
+      | 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 "]"]
 
       | EKAbs (x, e) => box [string x,
                              space,
--- a/src/core_util.sml	Tue Aug 11 12:01:54 2009 -0400
+++ b/src/core_util.sml	Sat Aug 22 12:55:18 2009 -0400
@@ -532,7 +532,7 @@
       | (ELet _, _) => LESS
       | (_, ELet _) => GREATER
 
-      | (EServerCall (n1, es1, e1, _), EServerCall (n2, es2, e2, _)) =>
+      | (EServerCall (n1, es1, e1, _, _), EServerCall (n2, es2, e2, _, _)) =>
         join (Int.compare (n1, n2),
               fn () => join (joinL compare (es1, es2),
                              fn () => compare (e1, e2)))
@@ -718,14 +718,16 @@
                                           fn e2' =>
                                              (ELet (x, t', e1', e2'), loc))))
 
-              | EServerCall (n, es, e, t) =>
+              | EServerCall (n, es, e, t1, t2) =>
                 S.bind2 (ListUtil.mapfold (mfe ctx) es,
                       fn es' =>
                          S.bind2 (mfe ctx e,
                                  fn e' =>
-                                    S.map2 (mfc ctx t,
-                                            fn t' =>
-                                               (EServerCall (n, es', e', t'), loc))))
+                                    S.bind2 (mfc ctx t1,
+                                          fn t1' =>
+                                             S.map2 (mfc ctx t2,
+                                                  fn t2' =>
+                                                     (EServerCall (n, es', e', t1', t2'), loc)))))
 
               | EKAbs (x, e) =>
                 S.map2 (mfe (bind (ctx, RelK x)) e,
--- a/src/effectize.sml	Tue Aug 11 12:01:54 2009 -0400
+++ b/src/effectize.sml	Sat Aug 22 12:55:18 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/monoize.sml	Tue Aug 11 12:01:54 2009 -0400
+++ b/src/monoize.sml	Sat Aug 22 12:55:18 2009 -0400
@@ -3137,7 +3137,7 @@
                 ((L'.ELet (x, t', e1, e2), loc), fm)
             end
 
-          | L.EServerCall (n, es, ek, t) =>
+          | L.EServerCall (n, es, ek, t, (L.TRecord (L.CRecord (_, []), _), _)) =>
             let
                 val t = monoType env t
                 val (_, ft, _, name) = Env.lookupENamed env n
@@ -3192,6 +3192,9 @@
             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	Tue Aug 11 12:01:54 2009 -0400
+++ b/src/reduce.sml	Sat Aug 22 12:55:18 2009 -0400
@@ -33,6 +33,14 @@
 
 structure IM = IntBinaryMap
 
+structure E = CoreEnv
+
+fun multiLiftExpInExp n e =
+    if n = 0 then
+        e
+    else
+        multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e)
+
 datatype env_item =
          UnknownK
        | KnownK of kind
@@ -254,6 +262,98 @@
               | EFfi _ => all
               | EFfiApp (m, f, es) => (EFfiApp (m, f, map (exp env) es), loc)
 
+              | EApp (
+                (EApp
+                     ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
+                             _), _),
+                      (EApp (
+                       (EApp (
+                        (ECApp (
+                         (ECApp ((EFfi ("Basis", "return"), _), _), _),
+                         _), _),
+                        _), _), v), _)), _), trans2) => exp env (EApp (trans2, v), loc)
+
+              (*| EApp (
+                (EApp
+                     ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
+                             (EFfi ("Basis", "transaction_monad"), _)), _),
+                      (ECase (ed, pes, {disc, ...}), _)), _),
+                trans2) =>
+                let
+                    val e' = (EFfi ("Basis", "bind"), loc)
+                    val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
+                    val e' = (ECApp (e', t1), loc)
+                    val e' = (ECApp (e', t2), loc)
+                    val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
+
+                    val pes = map (fn (p, e) =>
+                                      let
+                                          val e' = (EApp (e', e), loc)
+                                          val e' = (EApp (e',
+                                                          multiLiftExpInExp (E.patBindsN p)
+                                                                            trans2), loc)
+                                          val e' = exp env e'
+                                      in
+                                          (p, e')
+                                      end) pes
+                in
+                    (ECase (exp env ed,
+                            pes,
+                            {disc = con env disc,
+                             result = (CApp ((CFfi ("Basis", "transaction"), loc), con env t2), loc)}),
+                     loc)
+                end*)
+
+              | EApp (
+                (EApp
+                     ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
+                             (EFfi ("Basis", "transaction_monad"), _)), _),
+                      (EServerCall (n, es, ke, dom, ran), _)), _),
+                trans2) =>
+                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', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc)
+                    val e' = (EApp (e', E.liftExpInExp 0 trans2), loc)
+                    val e' = (EAbs ("x", dom, t2, e'), loc)
+                    val e' = (EServerCall (n, es, e', dom, t2), loc)
+                in
+                    exp env e'
+                end
+
+              | EApp (
+                (EApp
+                     ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), _), _), t3), _),
+                             (EFfi ("Basis", "transaction_monad"), _)), _),
+                      (EApp ((EApp
+                                  ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _),
+                                          (EFfi ("Basis", "transaction_monad"), _)), _),
+                                   trans1), _), trans2), _)), _),
+                trans3) =>
+                let
+                    val e'' = (EFfi ("Basis", "bind"), loc)
+                    val e'' = (ECApp (e'', (CFfi ("Basis", "transaction"), loc)), loc)
+                    val e'' = (ECApp (e'', t2), loc)
+                    val e'' = (ECApp (e'', t3), loc)
+                    val e'' = (EApp (e'', (EFfi ("Basis", "transaction_monad"), loc)), loc)
+                    val e'' = (EApp (e'', (EApp (E.liftExpInExp 0 trans2, (ERel 0, loc)), loc)), loc)
+                    val e'' = (EApp (e'', E.liftExpInExp 0 trans3), loc)
+                    val e'' = (EAbs ("x", t1, (CApp ((CFfi ("Basis", "transaction"), loc), t3), loc), e''), loc)
+
+                    val e' = (EFfi ("Basis", "bind"), loc)
+                    val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
+                    val e' = (ECApp (e', t1), loc)
+                    val e' = (ECApp (e', t3), loc)
+                    val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
+                    val e' = (EApp (e', trans1), loc)
+                    val e' = (EApp (e', e''), loc)
+                in
+                    exp env e'
+                end
+
               | EApp (e1, e2) =>
                 let
                     val e1 = exp env e1
@@ -424,7 +524,8 @@
 
               | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (UnknownE :: env) e2), loc)
 
-              | EServerCall (n, es, e, t) => (EServerCall (n, map (exp env) es, exp env e, con env t), loc))
+              | EServerCall (n, es, e, t1, t2) => (EServerCall (n, map (exp env) es, exp env e,
+                                                                con env t1, con env t2), loc))
     in
         {kind = kind, con = con, exp = exp}
     end
--- a/src/reduce_local.sml	Tue Aug 11 12:01:54 2009 -0400
+++ b/src/reduce_local.sml	Sat Aug 22 12:55:18 2009 -0400
@@ -139,7 +139,7 @@
 
       | ELet (x, t, e1, e2) => (ELet (x, t, exp env e1, exp (Unknown :: env) e2), loc)
 
-      | EServerCall (n, es, e, t) => (EServerCall (n, map (exp env) es, exp env e, t), loc)
+      | EServerCall (n, es, e, t1, t2) => (EServerCall (n, map (exp env) es, exp env e, t1, t2), loc)
 
 fun reduce file =
     let
--- a/src/rpcify.sml	Tue Aug 11 12:01:54 2009 -0400
+++ b/src/rpcify.sml	Sat Aug 22 12:55:18 2009 -0400
@@ -40,67 +40,22 @@
                            val compare = String.compare
                            end)
 
-fun multiLiftExpInExp n e =
-    if n = 0 then
-        e
-    else
-        multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e)
-
 type state = {
-     cpsed : int IM.map,
-     cpsed_range : con IM.map,
-     cps_decls : (string * int * con * exp * string) list,
-
      exported : IS.set,
-     export_decls : decl list,
-
-     maxName : int
+     export_decls : decl list
 }
 
 fun frob file =
     let
-        fun sideish (basis, ssids) e =
-            U.Exp.exists {kind = fn _ => false,
-                          con = fn _ => false,
-                          exp = fn ENamed n => IS.member (ssids, n)
-                                 | EFfi x => basis x
-                                 | EFfiApp (m, x, _) => basis (m, x)
-                                 | _ => false}
-                         (U.Exp.map {kind = fn x => x,
-                                     con = fn x => x,
-                                     exp = fn ERecord _ => ERecord []
-                                            | x => x} e)
-
-        fun whichIds basis =
-            let
-                fun decl ((d, _), ssids) =
-                    let
-                        val impure = sideish (basis, ssids)
-                    in
-                        case d of
-                            DVal (_, n, _, e, _) => if impure e then
-                                                        IS.add (ssids, n)
-                                                    else
-                                                        ssids
-                          | DValRec xes => if List.exists (fn (_, _, _, e, _) => impure e) xes then
-                                               foldl (fn ((_, n, _, _, _), ssids) => IS.add (ssids, n))
-                                                     ssids xes
-                                           else
-                                               ssids
-                          | _ => ssids
-                    end
-            in
-                foldl decl IS.empty file
-            end
-
-        val ssids = whichIds Settings.isServerOnly
-        val csids = whichIds Settings.isClientOnly
-
-        fun sideish' (basis, ids) extra =
-            sideish (basis, IM.foldli (fn (id, _, ids) => IS.add (ids, id)) ids extra)
-
-        val serverSide = sideish' (Settings.isServerOnly, ssids)
-        val clientSide = sideish' (Settings.isClientOnly, csids)
+        val rpcBaseIds = foldl (fn ((d, _), rpcIds) =>
+                                   case d of
+                                       DVal (_, n, _, (EFfi ("Basis", "rpc"), _), _) => IS.add (rpcIds, n)
+                                     | DVal (_, n, _, (ENamed n', _), _) => if IS.member (rpcIds, n') then
+                                                                                IS.add (rpcIds, n)
+                                                                            else
+                                                                                rpcIds
+                                     | _ => rpcIds)
+                               IS.empty file
 
         val tfuncs = foldl
                      (fn ((d, _), tfuncs) =>
@@ -134,312 +89,50 @@
         fun exp (e, st) =
             let
                 fun getApp (e', args) =
-                    let
-                        val loc = #2 e'
-                    in
-                        case #1 e' of
-                            ENamed n => (n, args)
-                          | EApp (e1, e2) => getApp (e1, e2 :: args)
-                          | _ => (ErrorMsg.errorAt loc "Mixed client/server code doesn't use a named function for server part";
-                                  (*Print.prefaces "Bad" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))];*)
-                                  (0, []))
-                    end
+                    case e' of
+                        ENamed n => SOME (n, args)
+                      | EApp (e1, e2) => getApp (#1 e1, e2 :: args)
+                      | _ => NONE
 
-                fun newRpc (trans1, trans2, st : state) =
-                    let
-                        val loc = #2 trans1
+                fun newRpc (trans : exp, st : state) =
+                    case getApp (#1 trans, []) of
+                        NONE => (ErrorMsg.errorAt (#2 trans)
+                                                  "RPC code doesn't use a named function or transaction";
+                                 (#1 trans, st))
+                      | SOME (n, args) =>
+                        case IM.find (tfuncs, n) of
+                            NONE => ((*Print.prefaces "BAD" [("e", CorePrint.p_exp CoreEnv.empty (e, loc))];*)
+                                     raise Fail ("Rpcify: Undetected transaction function " ^ Int.toString n))
+                          | SOME (_, _, ran, _) =>
+                            let
+                                val loc = #2 trans
 
-                        val (n, args) = getApp (trans1, [])
+                                val (exported, export_decls) =
+                                    if IS.member (#exported st, n) then
+                                        (#exported st, #export_decls st)
+                                    else
+                                        (IS.add (#exported st, n),
+                                         (DExport (Rpc ReadWrite, n), loc) :: #export_decls st)
 
-                        val (exported, export_decls) =
-                            if IS.member (#exported st, n) then
-                                (#exported st, #export_decls st)
-                            else
-                                (IS.add (#exported st, n),
-                                 (DExport (Rpc ReadWrite, n), loc) :: #export_decls st)
+                                val st = {exported = exported,
+                                          export_decls = export_decls}
 
-                        val st = {cpsed = #cpsed st,
-                                  cpsed_range = #cpsed_range st,
-                                  cps_decls = #cps_decls st,
-
-                                  exported = exported,
-                                  export_decls = export_decls,
-
-                                  maxName = #maxName st}
-
-                        val ran =
-                            case IM.find (tfuncs, n) of
-                                NONE => ((*Print.prefaces "BAD" [("e", CorePrint.p_exp CoreEnv.empty (e, loc))];*)
-                                         raise Fail ("Rpcify: Undetected transaction function " ^ Int.toString n))
-                              | SOME (_, _, ran, _) => ran
-
-                        val e' = EServerCall (n, args, trans2, ran)
-                    in
-                        (e', st)
-                    end
-
-                fun newCps (t1, t2, trans1, trans2, st) =
-                    let
-                        val loc = #2 trans1
-
-                        val (n, args) = getApp (trans1, [])
-
-                        fun makeCall n' =
-                            let
-                                val e = (ENamed n', loc)
-                                val e = (EApp (e, trans2), loc)
+                                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)
                             in
-                                #1 (foldl (fn (arg, e) => (EApp (e, arg), loc)) e args)
+                                (e', st)
                             end
-                    in
-                        case IM.find (#cpsed_range st, n) of
-                            SOME kdom =>
-                            (case args of
-                                 [] => raise Fail "Rpcify: cps'd function lacks first argument"
-                               | ke :: args =>
-                                 let
-                                     val ke' = (EFfi ("Basis", "bind"), loc)
-                                     val ke' = (ECApp (ke', (CFfi ("Basis", "transaction"), loc)), loc)
-                                     val ke' = (ECApp (ke', kdom), loc)
-                                     val ke' = (ECApp (ke', t2), loc)
-                                     val ke' = (EApp (ke', (EFfi ("Basis", "transaction_monad"), loc)), loc)
-                                     val ke' = (EApp (ke', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc)
-                                     val ke' = (EApp (ke', E.liftExpInExp 0 trans2), loc)
-                                     val ke' = (EAbs ("x", kdom,
-                                                      (CApp ((CFfi ("Basis", "transaction"), loc), t2), loc),
-                                                      ke'), loc)
-
-                                     val e' = (ENamed n, loc)
-                                     val e' = (EApp (e', ke'), loc)
-                                     val e' = foldl (fn (arg, e') => (EApp (e', arg), loc)) e' args
-                                     val (e', st) = doExp (e', st)
-                                 in
-                                     (#1 e', st)
-                                 end)
-                          | NONE =>
-                            case IM.find (#cpsed st, n) of
-                                SOME n' => (makeCall n', st)
-                              | NONE =>
-                                let
-                                    val (name, fargs, ran, e) =
-                                        case IM.find (tfuncs, n) of
-                                            NONE => (Print.prefaces "BAD" [("e",
-                                                                            CorePrint.p_exp CoreEnv.empty (e, loc))];
-                                                     raise Fail "Rpcify: Undetected transaction function [2]")
-                                          | SOME x => x
-                                                      
-                                    val n' = #maxName st
-
-                                    val st = {cpsed = IM.insert (#cpsed st, n, n'),
-                                              cpsed_range = IM.insert (#cpsed_range st, n', ran),
-                                              cps_decls = #cps_decls st,
-                                              exported = #exported st,
-                                              export_decls = #export_decls st,
-                                              maxName = n' + 1}
-
-                                    val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
-                                    val body = (EFfi ("Basis", "bind"), loc)
-                                    val body = (ECApp (body, (CFfi ("Basis", "transaction"), loc)), loc)
-                                    val body = (ECApp (body, t1), loc)
-                                    val body = (ECApp (body, unit), loc)
-                                    val body = (EApp (body, (EFfi ("Basis", "transaction_monad"), loc)), loc)
-                                    val body = (EApp (body, e), loc)
-                                    val body = (EApp (body, (ERel (length args), loc)), loc)
-                                    val bt = (CApp ((CFfi ("Basis", "transaction"), loc), unit), loc)
-                                    val (body, bt) = foldr (fn ((x, t), (body, bt)) =>
-                                                               ((EAbs (x, t, bt, body), loc),
-                                                                (TFun (t, bt), loc)))
-                                                           (body, bt) fargs
-                                    val kt = (TFun (ran, (CApp ((CFfi ("Basis", "transaction"), loc),
-                                                                unit),
-                                                          loc)), loc)
-                                    val body = (EAbs ("k", kt, bt, body), loc)
-                                    val bt = (TFun (kt, bt), loc)
-
-                                    val (body, st) = doExp (body, st)
-
-                                    val vi = (name ^ "_cps",
-                                              n',
-                                              bt,
-                                              body,
-                                              "")
-
-                                    val st = {cpsed = #cpsed st,
-                                              cpsed_range = #cpsed_range st,
-                                              cps_decls = vi :: #cps_decls st,
-                                              exported = #exported st,
-                                              export_decls = #export_decls st,
-                                              maxName = #maxName st}
-                                in
-                                    (makeCall n', st)
-                                end
-                    end
-
-                fun dummyK loc =
-                    let
-                        val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
-                                   
-                        val k = (EFfi ("Basis", "return"), loc)
-                        val k = (ECApp (k, (CFfi ("Basis", "transaction"), loc)), loc)
-                        val k = (ECApp (k, unit), loc)
-                        val k = (EApp (k, (EFfi ("Basis", "transaction_monad"), loc)), loc)
-                        val k = (EApp (k, (ERecord [], loc)), loc)
-                    in
-                        (EAbs ("_", unit, unit, k), loc)
-                    end
             in
                 case e of
-                    EApp (
-                    (EApp
-                         ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
-                                 (EFfi ("Basis", "transaction_monad"), _)), _),
-                          (ECase (ed, pes, {disc, ...}), _)), _),
-                    trans2) =>
-                    let
-                        val e' = (EFfi ("Basis", "bind"), loc)
-                        val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
-                        val e' = (ECApp (e', t1), loc)
-                        val e' = (ECApp (e', t2), loc)
-                        val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
-
-                        val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) =>
-                                                              let
-                                                                  val e' = (EApp (e', e), loc)
-                                                                  val e' = (EApp (e',
-                                                                                  multiLiftExpInExp (E.patBindsN p)
-                                                                                                    trans2), loc)
-                                                                  val (e', st) = doExp (e', st)
-                                                              in
-                                                                  ((p, e'), st)
-                                                              end) st pes
-                    in
-                        (ECase (ed, pes, {disc = disc,
-                                          result = (CApp ((CFfi ("Basis", "transaction"), loc), t2), loc)}),
-                         st)
-                    end
-
-                  | EApp (
-                    (EApp
-                         ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
-                                 (EFfi ("Basis", "transaction_monad"), _)), _),
-                          (EServerCall (n, es, ke, t), _)), _),
-                    trans2) =>
-                    let
-                        val e' = (EFfi ("Basis", "bind"), loc)
-                        val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
-                        val e' = (ECApp (e', t), loc)
-                        val e' = (ECApp (e', t2), loc)
-                        val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
-                        val e' = (EApp (e', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc)
-                        val e' = (EApp (e', E.liftExpInExp 0 trans2), loc)
-                        val e' = (EAbs ("x", t, t2, e'), loc)
-                        val e' = (EServerCall (n, es, e', t), loc)
-                        val (e', st) = doExp (e', st)
-                    in
-                        (#1 e', st)
-                    end
-
-                  | EApp (
-                    (EApp
-                         ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), _), _), t3), _),
-                                 (EFfi ("Basis", "transaction_monad"), _)), _),
-                          (EApp ((EApp
-                                      ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _),
-                                              (EFfi ("Basis", "transaction_monad"), _)), _),
-                                       trans1), _), trans2), _)), _),
-                    trans3) =>
-                    let
-                        val e'' = (EFfi ("Basis", "bind"), loc)
-                        val e'' = (ECApp (e'', (CFfi ("Basis", "transaction"), loc)), loc)
-                        val e'' = (ECApp (e'', t2), loc)
-                        val e'' = (ECApp (e'', t3), loc)
-                        val e'' = (EApp (e'', (EFfi ("Basis", "transaction_monad"), loc)), loc)
-                        val e'' = (EApp (e'', (EApp (E.liftExpInExp 0 trans2, (ERel 0, loc)), loc)), loc)
-                        val e'' = (EApp (e'', E.liftExpInExp 0 trans3), loc)
-                        val e'' = (EAbs ("x", t1, (CApp ((CFfi ("Basis", "transaction"), loc), t3), loc), e''), loc)
-
-                        val e' = (EFfi ("Basis", "bind"), loc)
-                        val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
-                        val e' = (ECApp (e', t1), loc)
-                        val e' = (ECApp (e', t3), loc)
-                        val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
-                        val e' = (EApp (e', trans1), loc)
-                        val e' = (EApp (e', e''), loc)
-                        val (e', st) = doExp (e', st)
-                    in
-                        (#1 e', st)
-                    end
-
-                  | EApp (
-                    (EApp
-                         ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), _), _), _), _),
-                                 (EFfi ("Basis", "transaction_monad"), _)), _),
-                          _), loc),
-                    (EAbs (_, _, _, (EWrite _, _)), _)) => (e, st)
-
-                  | EApp (
-                    (EApp
-                         ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _),
-                                 (EFfi ("Basis", "transaction_monad"), _)), _),
-                          trans1), loc),
-                    trans2) =>
-                    (case (serverSide (#cpsed_range st) trans1, clientSide (#cpsed_range st) trans1,
-                           serverSide (#cpsed_range st) trans2, clientSide (#cpsed_range st) trans2) of
-                         (true, false, _, true) => newRpc (trans1, trans2, st)
-                       | (_, true, true, false) =>
-                         (case #1 trans2 of
-                              EAbs (x, dom, ran, trans2) =>
-                              let
-                                  val (trans2, st) = newRpc (trans2, dummyK loc, st)
-                                  val trans2 = (EAbs (x, dom, ran, (trans2, loc)), loc)
-
-                                  val e = (EFfi ("Basis", "bind"), loc)
-                                  val e = (ECApp (e, (CFfi ("Basis", "transaction"), loc)), loc)
-                                  val e = (ECApp (e, t1), loc)
-                                  val e = (ECApp (e, t2), loc)
-                                  val e = (EApp (e, (EFfi ("Basis", "transaction_monad"), loc)), loc)
-                                  val e = (EApp (e, trans1), loc)
-                                  val e = EApp (e, trans2)
-                              in
-                                  (e, st)
-                              end
-                            | _ => (e, st))
-                       | (true, true, _, _) => newCps (t1, t2, trans1, trans2, st)
-
-                       | _ => (e, st))
-
-                  | ERecord xes =>
-                    let
-                        val loc = case xes of
-                                      [] => ErrorMsg.dummySpan
-                                    | (_, (_, loc), _) :: _ => loc
-
-                        fun candidate (x, e) =
-                            String.isPrefix "On" x
-                            andalso serverSide (#cpsed_range st) e
-                            andalso not (clientSide (#cpsed_range st) e)
-                    in
-                        if List.exists (fn ((CName x, _), e, _) => candidate (x, e)
-                                         | _ => false) xes then
-                            let
-                                val (xes, st) = ListUtil.foldlMap
-                                                (fn (y as (nm as (CName x, _), e, t), st) =>
-                                                    if candidate (x, e) then
-                                                        let
-                                                            val (e, st) = newRpc (e, dummyK loc, st)
-                                                        in
-                                                            ((nm, (e, loc), t), st)
-                                                        end
-                                                    else
-                                                        (y, st)
-                                                  | y => y)
-                                                st xes
-                            in
-                                (ERecord xes, st)
-                            end
-                        else
-                            (e, st)
-                    end
+                    EApp ((ECApp ((EFfi ("Basis", "rpc"), _), ran), _), trans) => newRpc (trans, st)
+                  | EApp ((ECApp ((ENamed n, _), ran), _), trans) =>
+                    if IS.member (rpcBaseIds, n) then
+                        newRpc (trans, st)
+                    else
+                        (e, st)
 
                   | _ => (e, st)
             end
@@ -456,32 +149,14 @@
                                               decl = fn x => x}
                               st d
             in
-                (List.revAppend (case #cps_decls st of
-                                     [] => [d]
-                                   | ds =>
-                                     case d of
-                                         (DValRec vis, loc) => [(DValRec (ds @ vis), loc)]
-                                       | (_, loc) => [d, (DValRec ds, loc)],
-                                 #export_decls st),
-                 {cpsed = #cpsed st,
-                  cpsed_range = #cpsed_range st,
-                  cps_decls = [],
-                  
-                  exported = #exported st,
-                  export_decls = [],
-
-                  maxName = #maxName st})
+                (#export_decls st @ [d],
+                 {exported = #exported st,
+                  export_decls = []})
             end
 
         val (file, _) = ListUtil.foldlMapConcat decl
-                        {cpsed = IM.empty,
-                         cpsed_range = IM.empty,
-                         cps_decls = [],
-
-                         exported = IS.empty,
-                         export_decls = [],
-
-                         maxName = U.File.maxName file + 1}
+                        {exported = IS.empty,
+                         export_decls = []}
                         file
     in
         file
--- a/src/shake.sml	Tue Aug 11 12:01:54 2009 -0400
+++ b/src/shake.sml	Sat Aug 22 12:55:18 2009 -0400
@@ -137,7 +137,7 @@
             in
                 case e of
                     ENamed n => check n
-                  | EServerCall (n, _, _, _) => check n
+                  | EServerCall (n, _, _, _, _) => check n
                   | _ => s
             end