summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-02-14 14:07:56 -0500
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-02-14 14:07:56 -0500
commita89a3e41b94c294e1f08d369f2558e12b532e430 (patch)
treed009d124587d5ea580081e4d2fccfb6ac9c21d69 /src
parentf9fc82e21b19e56f2f43f0e26d421c6364a1bf51 (diff)
Start of RPCification
Diffstat (limited to 'src')
-rw-r--r--src/compiler.sig2
-rw-r--r--src/compiler.sml9
-rw-r--r--src/core.sml2
-rw-r--r--src/core_print.sml9
-rw-r--r--src/core_util.sml14
-rw-r--r--src/monoize.sml2
-rw-r--r--src/reduce.sml4
-rw-r--r--src/reduce_local.sml2
-rw-r--r--src/rpcify.sig32
-rw-r--r--src/rpcify.sml149
-rw-r--r--src/shake.sml45
-rw-r--r--src/sources3
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