Start of RPCification

12 files changed, 251 insertions, 22 deletions

diff --git a/src/compiler.sig b/src/compiler.sig
index b126fb51..1b4995ee 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -66,6 +66,7 @@ signature COMPILER = sig
     val especialize : (Core.file, Core.file) phase
     val core_untangle : (Core.file, Core.file) phase
     val shake : (Core.file, Core.file) phase
+    val rpcify : (Core.file, Core.file) phase
     val tag : (Core.file, Core.file) phase
     val reduce : (Core.file, Core.file) phase
     val unpoly : (Core.file, Core.file) phase
@@ -92,6 +93,7 @@ signature COMPILER = sig
     val toEspecialize : (string, Core.file) transform 
     val toCore_untangle : (string, Core.file) transform
     val toShake1 : (string, Core.file) transform
+    val toRpcify : (string, Core.file) transform
     val toTag : (string, Core.file) transform
     val toReduce : (string, Core.file) transform
     val toUnpoly : (string, Core.file) transform 
diff --git a/src/compiler.sml b/src/compiler.sml
index 52181401..aecefbcf 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -446,12 +446,19 @@ val shake = {
 
 val toShake1 = transform shake "shake1" o toCore_untangle
 
+val rpcify = {
+    func = Rpcify.frob,
+    print = CorePrint.p_file CoreEnv.empty
+}
+
+val toRpcify = transform rpcify "rpcify" o toShake1
+
 val tag = {
     func = Tag.tag,
     print = CorePrint.p_file CoreEnv.empty
 }
 
-val toTag = transform tag "tag" o toShake1
+val toTag = transform tag "tag" o toRpcify
 
 val reduce = {
     func = Reduce.reduce,
diff --git a/src/core.sml b/src/core.sml
index 4623bb49..fbe150c1 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -106,6 +106,8 @@ datatype exp' =
 
        | ELet of string * con * exp * exp
 
+       | EServerCall of int * exp list * exp
+
 withtype exp = exp' located
 
 datatype export_kind =
diff --git a/src/core_print.sml b/src/core_print.sml
index 53922936..64cead70 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -394,6 +394,15 @@ 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 "]"]
+
 and p_exp env = p_exp' false env
 
 fun p_named x n =
diff --git a/src/core_util.sml b/src/core_util.sml
index 02cb86ca..3d6808f9 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -479,6 +479,13 @@ fun compare ((e1, _), (e2, _)) =
       | (ELet (_, _, x1, e1), ELet (_, _, x2, e2)) =>
         join (compare (x1, x2),
               fn () => compare (e1, e2))
+      | (ELet _, _) => LESS
+      | (_, ELet _) => GREATER
+
+      | (EServerCall (n1, es1, e1), EServerCall (n2, es2, e2)) =>
+        join (Int.compare (n1, n2),
+              fn () => join (joinL compare (es1, es2),
+                             fn () => compare (e1, e2)))
 
 datatype binder =
          RelC of string * kind
@@ -653,6 +660,13 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
                                           fn e2' =>
                                              (ELet (x, t', e1', e2'), loc))))
 
+              | EServerCall (n, es, e) =>
+                S.bind2 (ListUtil.mapfold (mfe ctx) es,
+                      fn es' =>
+                         S.map2 (mfe ctx e,
+                                 fn e' =>
+                                    (EServerCall (n, es', e'), loc)))
+                         
         and mfp ctx (pAll as (p, loc)) =
             case p of
                 PWild => S.return2 pAll
diff --git a/src/monoize.sml b/src/monoize.sml
index 80661d03..a1f61143 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2224,6 +2224,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             in
                 ((L'.ELet (x, t', e1, e2), loc), fm)
             end
+
+          | L.EServerCall _ => raise Fail "Monoize EServerCall"
     end
 
 fun monoDecl (env, fm) (all as (d, loc)) =
diff --git a/src/reduce.sml b/src/reduce.sml
index a08feb26..89fce664 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -366,7 +366,9 @@ fun conAndExp (namedC, namedE) =
               | EWrite e => (EWrite (exp env e), loc)
               | EClosure (n, es) => (EClosure (n, map (exp env) es), loc)
 
-              | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (UnknownE :: env) e2), loc))
+              | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (UnknownE :: env) e2), loc)
+
+              | EServerCall (n, es, e) => (EServerCall (n, map (exp env) es, exp env e), loc))
     in
         {con = con, exp = exp}
     end
diff --git a/src/reduce_local.sml b/src/reduce_local.sml
index d80d5770..55bb5198 100644
--- a/src/reduce_local.sml
+++ b/src/reduce_local.sml
@@ -131,6 +131,8 @@ 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) => (EServerCall (n, map (exp env) es, exp env e), loc)
+
 fun reduce file =
     let
         fun doDecl (d as (_, loc)) =
diff --git a/src/rpcify.sig b/src/rpcify.sig
new file mode 100644
index 00000000..7da53b79
--- /dev/null
+++ b/src/rpcify.sig
@@ -0,0 +1,32 @@
+(* 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 RPCIFY = sig
+
+    val frob : Core.file -> Core.file
+
+end
diff --git a/src/rpcify.sml b/src/rpcify.sml
new file mode 100644
index 00000000..dec8dc18
--- /dev/null
+++ b/src/rpcify.sml
@@ -0,0 +1,149 @@
+(* 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 Rpcify :> RPCIFY = struct
+
+open Core
+
+structure U = CoreUtil
+structure E = CoreEnv
+
+structure IS = IntBinarySet
+structure IM = IntBinaryMap
+
+structure SS = BinarySetFn(struct
+                           type ord_key = string
+                           val compare = String.compare
+                           end)
+
+val ssBasis = SS.addList (SS.empty,
+                          ["requestHeader",
+                           "query",
+                           "dml",
+                           "nextval"])
+
+val csBasis = SS.addList (SS.empty,
+                          ["source",
+                           "get",
+                           "set",
+                           "alert"])
+
+type state = {
+     exps : int IM.map,
+     decls : (string * int * con * exp * string) list
+}
+
+fun frob file =
+    let
+        fun sideish (basis, ssids) =
+            U.Exp.exists {kind = fn _ => false,
+                          con = fn _ => false,
+                          exp = fn ENamed n => IS.member (ssids, n)
+                                 | EFfi ("Basis", x) => SS.member (basis, x)
+                                 | EFfiApp ("Basis", x, _) => SS.member (basis, x)
+                                 | _ => false}
+
+        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 ssBasis
+        val csids = whichIds csBasis
+
+        val serverSide = sideish (ssBasis, ssids)
+        val clientSide = sideish (csBasis, csids)
+
+        fun exp (e, st) =
+            case e of
+                EApp (
+                (EApp
+                     ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
+                             (EFfi ("Basis", "transaction_monad"), _)), _),
+                      trans1), _),
+                trans2) =>
+                (case (serverSide trans1, clientSide trans1, serverSide trans2, clientSide trans2) of
+                     (true, false, false, _) =>
+                     let
+                         fun getApp (e, args) =
+                             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";
+                                       (0, []))
+
+                         val (n, args) = getApp (trans1, [])
+                     in
+                         (EServerCall (n, args, trans2), st)
+                     end
+                   | _ => (e, st))
+              | _ => (e, st)
+
+        fun decl (d, st : state) =
+            let
+                val (d, st) = U.Decl.foldMap {kind = fn x => x,
+                                              con = fn x => x,
+                                              exp = exp,
+                                              decl = fn x => x}
+                              st d
+            in
+                (case #decls st of
+                     [] => [d]
+                   | ds =>
+                     case d of
+                         (DValRec vis, loc) => [(DValRec (ds @ vis), loc)]
+                       | (_, loc) => [(DValRec ds, loc), d],
+                 {decls = [],
+                  exps = #exps st})
+            end
+
+        val (file, _) = ListUtil.foldlMapConcat decl
+                        {decls = [],
+                         exps = IM.empty}
+                        file
+    in
+        file
+    end
+
+end
diff --git a/src/shake.sml b/src/shake.sml
index e062743d..58c1d2c6 100644
--- a/src/shake.sml
+++ b/src/shake.sml
@@ -94,26 +94,31 @@ fun shake file =
         and shakeCon s = U.Con.fold {kind = kind, con = con} s
 
         fun exp (e, s) =
-            case e of
-                ENamed n =>
-                if IS.member (#exp s, n) then
-                    s
-                else
-                    let
-                        val s' = {exp = IS.add (#exp s, n),
-                                  con = #con s}
-                    in
-                        (*print ("Need " ^ Int.toString n ^ "\n");*)
-                        case IM.find (edef, n) of
-                            NONE => s'
-                          | SOME (ns, t, e) =>
-                            let
-                                val s' = shakeExp (shakeCon s' t) e
-                            in
-                                foldl (fn (n, s') => exp (ENamed n, s')) s' ns
-                            end
-                    end
-              | _ => s
+            let
+                fun check n =
+                    if IS.member (#exp s, n) then
+                        s
+                    else
+                        let
+                            val s' = {exp = IS.add (#exp s, n),
+                                      con = #con s}
+                        in
+                            (*print ("Need " ^ Int.toString n ^ "\n");*)
+                            case IM.find (edef, n) of
+                                NONE => s'
+                              | SOME (ns, t, e) =>
+                                let
+                                    val s' = shakeExp (shakeCon s' t) e
+                                in
+                                    foldl (fn (n, s') => exp (ENamed n, s')) s' ns
+                                end
+                        end
+            in
+                case e of
+                    ENamed n => check n
+                  | EServerCall (n, _, _) => check n
+                  | _ => s
+            end
 
         and shakeExp s = U.Exp.fold {kind = kind, con = con, exp = exp} s
 
diff --git a/src/sources b/src/sources
index 05b1cc54..f5574365 100644
--- a/src/sources
+++ b/src/sources
@@ -108,6 +108,9 @@ especialize.sml
 defunc.sig
 defunc.sml
 
+rpcify.sig
+rpcify.sml
+
 tag.sig
 tag.sml