summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-05-02 11:27:26 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-05-02 11:27:26 -0400
commit4b3399b59d17ed32c8c2800267b8c59fd0378f21 (patch)
tree9918a955a048024a07e68cd466c19c0dbf56f867 /src
parent2307ccdcc5eb4ddfe719ddcbea999f7705ec79c3 (diff)
Successfully influenced effectful-ness status of FFI func
Diffstat (limited to 'src')
-rw-r--r--src/cjr_print.sml6
-rw-r--r--src/compiler.sig7
-rw-r--r--src/compiler.sml63
-rw-r--r--src/corify.sml3
-rw-r--r--src/demo.sml7
-rw-r--r--src/effectize.sml7
-rw-r--r--src/jscomp.sml38
-rw-r--r--src/marshalcheck.sml14
-rw-r--r--src/mono_reduce.sml36
-rw-r--r--src/rpcify.sml29
-rw-r--r--src/settings.sig25
-rw-r--r--src/settings.sml97
12 files changed, 219 insertions, 113 deletions
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index e1d6d88b..b40d4248 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1396,6 +1396,12 @@ fun p_exp' par env (e, loc) =
| EApp ((EReturnBlob {blob, mimeType, t = (TFun (_, ran), _)}, loc), _) =>
p_exp env (EReturnBlob {blob = blob, mimeType = mimeType, t = ran}, loc)
+ | EFfiApp (m, x, []) => box [string "uw_",
+ p_ident m,
+ string "_",
+ p_ident x,
+ string "(ctx)"]
+
| EFfiApp (m, x, es) => box [string "uw_",
p_ident m,
string "_",
diff --git a/src/compiler.sig b/src/compiler.sig
index cae86472..d49d34b0 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -40,7 +40,12 @@ signature COMPILER = sig
timeout : int,
ffi : string list,
link : string list,
- headers : string list
+ headers : string list,
+ clientToServer : Settings.ffi list,
+ effectful : Settings.ffi list,
+ clientOnly : Settings.ffi list,
+ serverOnly : Settings.ffi list,
+ jsFuncs : (Settings.ffi * string) list
}
val compile : string -> unit
val compileC : {cname : string, oname : string, ename : string, libs : string,
diff --git a/src/compiler.sml b/src/compiler.sml
index a5360f89..cdde57ad 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -44,7 +44,12 @@ type job = {
timeout : int,
ffi : string list,
link : string list,
- headers : string list
+ headers : string list,
+ clientToServer : Settings.ffi list,
+ effectful : Settings.ffi list,
+ clientOnly : Settings.ffi list,
+ serverOnly : Settings.ffi list,
+ jsFuncs : (Settings.ffi * string) list
}
type ('src, 'dst) phase = {
@@ -202,10 +207,15 @@ val parseUr = {
handle LrParser.ParseError => [],
print = SourcePrint.p_file}
-fun p_job {prefix, database, exe, sql, sources, debug, profile, timeout, ffi, link, headers} =
+fun p_job {prefix, database, exe, sql, sources, debug, profile,
+ timeout, ffi, link, headers,
+ clientToServer, effectful, clientOnly, serverOnly, jsFuncs} =
let
open Print.PD
open Print
+
+ fun p_ffi name = p_list_sep (box []) (fn (m, s) =>
+ box [string name, space, string m, string ".", string s, newline])
in
box [if debug then
box [string "DEBUG", newline]
@@ -232,6 +242,13 @@ fun p_job {prefix, database, exe, sql, sources, debug, profile, timeout, ffi, li
p_list_sep (box []) (fn s => box [string "Ffi", space, string s, newline]) ffi,
p_list_sep (box []) (fn s => box [string "Header", space, string s, newline]) headers,
p_list_sep (box []) (fn s => box [string "Link", space, string s, newline]) link,
+ p_ffi "ClientToServer" clientToServer,
+ p_ffi "Effectful" effectful,
+ p_ffi "ClientOnly" clientOnly,
+ p_ffi "ServerOnly" serverOnly,
+ p_list_sep (box []) (fn ((m, s), s') =>
+ box [string "JsFunc", space, string m, string ".", string s,
+ space, string "=", space, string s', newline]) jsFuncs,
string "Sources:",
p_list string sources,
newline]
@@ -288,6 +305,11 @@ val parseUrp = {
val ffi = ref []
val link = ref []
val headers = ref []
+ val clientToServer = ref []
+ val effectful = ref []
+ val clientOnly = ref []
+ val serverOnly = ref []
+ val jsFuncs = ref []
fun finish sources =
{prefix = Option.getOpt (!prefix, "/"),
@@ -298,9 +320,14 @@ val parseUrp = {
debug = !debug,
profile = !profile,
timeout = Option.getOpt (!timeout, 60),
- ffi = !ffi,
- link = !link,
- headers = !headers,
+ ffi = rev (!ffi),
+ link = rev (!link),
+ headers = rev (!headers),
+ clientToServer = rev (!clientToServer),
+ effectful = rev (!effectful),
+ clientOnly = rev (!clientOnly),
+ serverOnly = rev (!serverOnly),
+ jsFuncs = rev (!jsFuncs),
sources = sources}
fun read () =
@@ -312,6 +339,22 @@ val parseUrp = {
val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line)
val cmd = Substring.string (trim cmd)
val arg = Substring.string (trim arg)
+
+ fun ffiS () =
+ case String.fields (fn ch => ch = #".") arg of
+ [m, x] => (m, x)
+ | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func");
+ ("", ""))
+
+ fun ffiM () =
+ case String.fields (fn ch => ch = #"=") arg of
+ [f, s] =>
+ (case String.fields (fn ch => ch = #".") f of
+ [m, x] => ((m, x), s)
+ | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
+ (("", ""), "")))
+ | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
+ (("", ""), ""))
in
case cmd of
"prefix" =>
@@ -344,6 +387,11 @@ val parseUrp = {
| "ffi" => ffi := relify arg :: !ffi
| "link" => link := relifyA arg :: !link
| "include" => headers := relifyA arg :: !headers
+ | "clientToServer" => clientToServer := ffiS () :: !clientToServer
+ | "effectful" => effectful := ffiS () :: !effectful
+ | "clientOnly" => clientOnly := ffiS () :: !clientOnly
+ | "serverOnly" => serverOnly := ffiS () :: !serverOnly
+ | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs
| _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
read ()
end
@@ -354,6 +402,11 @@ val parseUrp = {
Settings.setUrlPrefix (#prefix job);
Settings.setTimeout (#timeout job);
Settings.setHeaders (#headers job);
+ Settings.setClientToServer (#clientToServer job);
+ Settings.setEffectful (#effectful job);
+ Settings.setClientOnly (#clientOnly job);
+ Settings.setServerOnly (#serverOnly job);
+ Settings.setJsFuncs (#jsFuncs job);
job
end,
print = p_job
diff --git a/src/corify.sml b/src/corify.sml
index 19568b8b..6cd2b753 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -539,6 +539,9 @@ fun corifyExp st (e, loc) =
case t of
(L'.TFun (dom as (L'.TRecord (L'.CRecord (_, []), _), _), ran), _) =>
(L'.EAbs ("arg", dom, ran, (L'.EFfiApp (m, x, []), loc)), loc)
+ | (L'.CApp ((L'.CFfi ("Basis", "transaction"), _), dom), _) =>
+ (L'.EAbs ("arg", dom, (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc),
+ (L'.EFfiApp (m, x, []), loc)), loc)
| t as (L'.TFun _, _) =>
let
fun getArgs (all as (t, _), args) =
diff --git a/src/demo.sml b/src/demo.sml
index 4e73faea..9fa08021 100644
--- a/src/demo.sml
+++ b/src/demo.sml
@@ -97,7 +97,12 @@ fun make {prefix, dirname, guided} =
profile = false,
ffi = [],
link = [],
- headers = []
+ headers = [],
+ clientToServer = [],
+ effectful = [],
+ clientOnly = [],
+ serverOnly = [],
+ jsFuncs = []
}
val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp")
diff --git a/src/effectize.sml b/src/effectize.sml
index 52fdec6d..e3d62ff8 100644
--- a/src/effectize.sml
+++ b/src/effectize.sml
@@ -37,15 +37,14 @@ structure SS = BinarySetFn(struct
val compare = String.compare
end)
-val effectful = ["dml", "nextval", "send", "setCookie"]
-val effectful = SS.addList (SS.empty, effectful)
+fun effectful x = Settings.isEffectful x andalso not (Settings.isClientOnly x)
fun effectize file =
let
fun exp evs e =
case e of
- EFfi ("Basis", s) => SS.member (effectful, s)
- | EFfiApp ("Basis", s, _) => SS.member (effectful, s)
+ EFfi f => effectful f
+ | EFfiApp (m, x, _) => effectful (m, x)
| ENamed n => IM.inDomain (evs, n)
| EServerCall (n, _, _, _) => IM.inDomain (evs, n)
| _ => false
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 1c5132c2..26558745 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -36,40 +36,6 @@ structure U = MonoUtil
structure IS = IntBinarySet
structure IM = IntBinaryMap
-val funcs = [(("Basis", "alert"), "alert"),
- (("Basis", "get_client_source"), "sg"),
- (("Basis", "htmlifyBool"), "bs"),
- (("Basis", "htmlifyFloat"), "ts"),
- (("Basis", "htmlifyInt"), "ts"),
- (("Basis", "htmlifyString"), "eh"),
- (("Basis", "new_client_source"), "sc"),
- (("Basis", "set_client_source"), "sv"),
- (("Basis", "stringToFloat_error"), "pfl"),
- (("Basis", "stringToInt_error"), "pi"),
- (("Basis", "urlifyInt"), "ts"),
- (("Basis", "urlifyFloat"), "ts"),
- (("Basis", "urlifyString"), "uf"),
- (("Basis", "recv"), "rv"),
- (("Basis", "strcat"), "cat"),
- (("Basis", "intToString"), "ts"),
- (("Basis", "floatToString"), "ts"),
- (("Basis", "onError"), "onError"),
- (("Basis", "onFail"), "onFail"),
- (("Basis", "onConnectFail"), "onConnectFail"),
- (("Basis", "onDisconnect"), "onDisconnect"),
- (("Basis", "onServerError"), "onServerError")]
-
-structure FM = BinaryMapFn(struct
- type ord_key = string * string
- fun compare ((m1, x1), (m2, x2)) =
- Order.join (String.compare (m1, m2),
- fn () => String.compare (x1, x2))
- end)
-
-val funcs = foldl (fn ((k, v), m) => FM.insert (m, k, v)) FM.empty funcs
-
-fun ffi k = FM.find (funcs, k)
-
type state = {
decls : decl list,
script : string list,
@@ -684,7 +650,7 @@ fun process file =
| EFfi k =>
let
- val name = case ffi k of
+ val name = case Settings.jsFunc k of
NONE => (EM.errorAt loc ("Unsupported FFI identifier " ^ #2 k
^ " in JavaScript");
"ERROR")
@@ -700,7 +666,7 @@ fun process file =
| ("Basis", "set_client_source", [e1, (EJavaScript (_, e2, _), _)]) => [e1, e2]
| _ => args
- val name = case ffi (m, x) of
+ val name = case Settings.jsFunc (m, x) of
NONE => (EM.errorAt loc ("Unsupported FFI function "
^ x ^ " in JavaScript");
"ERROR")
diff --git a/src/marshalcheck.sml b/src/marshalcheck.sml
index 7dea28f3..3dbf93fc 100644
--- a/src/marshalcheck.sml
+++ b/src/marshalcheck.sml
@@ -53,18 +53,6 @@ end
structure IM = IntBinaryMap
-val clientToServer = [("Basis", "int"),
- ("Basis", "float"),
- ("Basis", "string"),
- ("Basis", "time"),
- ("Basis", "file"),
- ("Basis", "unit"),
- ("Basis", "option"),
- ("Basis", "list"),
- ("Basis", "bool")]
-
-val clientToServer = PS.addList (PS.empty, clientToServer)
-
fun check file =
let
fun kind (_, st) = st
@@ -72,7 +60,7 @@ fun check file =
fun con cmap (c, st) =
case c of
CFfi mx =>
- if PS.member (clientToServer, mx) then
+ if Settings.mayClientToServer mx then
st
else
PS.add (st, mx)
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 4eee1f79..5d8afee3 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -53,20 +53,7 @@ fun impure (e, _) =
| ENone _ => false
| ESome (_, e) => impure e
| EFfi _ => false
- | EFfiApp ("Basis", "set_cookie", _) => true
- | EFfiApp ("Basis", "new_client_source", _) => true
- | EFfiApp ("Basis", "get_client_source", _) => true
- | EFfiApp ("Basis", "set_client_source", _) => true
- | EFfiApp ("Basis", "alert", _) => true
- | EFfiApp ("Basis", "new_channel", _) => true
- | EFfiApp ("Basis", "subscribe", _) => true
- | EFfiApp ("Basis", "send", _) => true
- | EFfiApp ("Basis", "onError", _) => true
- | EFfiApp ("Basis", "onFail", _) => true
- | EFfiApp ("Basis", "onConnectFail", _) => true
- | EFfiApp ("Basis", "onDisconnect", _) => true
- | EFfiApp ("Basis", "onServerError", _) => true
- | EFfiApp _ => false
+ | EFfiApp (m, x, _) => Settings.isEffectful (m, x)
| EApp ((EFfi _, _), _) => false
| EApp _ => true
@@ -271,8 +258,6 @@ fun reduce file =
fun summarize d (e, _) =
let
- fun ffi es = List.concat (map (summarize d) es) @ [Unsure]
-
val s =
case e of
EPrim _ => []
@@ -283,20 +268,11 @@ fun reduce file =
| ENone _ => []
| ESome (_, e) => summarize d e
| EFfi _ => []
- | EFfiApp ("Basis", "set_cookie", es) => ffi es
- | EFfiApp ("Basis", "new_client_source", es) => ffi es
- | EFfiApp ("Basis", "get_client_source", es) => ffi es
- | EFfiApp ("Basis", "set_client_source", es) => ffi es
- | EFfiApp ("Basis", "alert", es) => ffi es
- | EFfiApp ("Basis", "new_channel", es) => ffi es
- | EFfiApp ("Basis", "subscribe", es) => ffi es
- | EFfiApp ("Basis", "send", es) => ffi es
- | EFfiApp ("Basis", "onError", es) => ffi es
- | EFfiApp ("Basis", "onFail", es) => ffi es
- | EFfiApp ("Basis", "onConnectFail", es) => ffi es
- | EFfiApp ("Basis", "onDisconnect", es) => ffi es
- | EFfiApp ("Basis", "onServerError", es) => ffi es
- | EFfiApp (_, _, es) => List.concat (map (summarize d) es)
+ | EFfiApp (m, x, es) =>
+ if Settings.isEffectful (m, x) then
+ List.concat (map (summarize d) es) @ [Unsure]
+ else
+ List.concat (map (summarize d) es)
| EApp ((EFfi _, _), e) => summarize d e
| EApp _ =>
let
diff --git a/src/rpcify.sml b/src/rpcify.sml
index 6b7a3c90..1ed4cd54 100644
--- a/src/rpcify.sml
+++ b/src/rpcify.sml
@@ -46,23 +46,6 @@ fun multiLiftExpInExp n e =
else
multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e)
-val ssBasis = SS.addList (SS.empty,
- ["requestHeader",
- "query",
- "dml",
- "nextval",
- "channel",
- "subscribe",
- "send"])
-
-val csBasis = SS.addList (SS.empty,
- ["get",
- "set",
- "alert",
- "recv",
- "sleep",
- "spawn"])
-
type state = {
cpsed : int IM.map,
cpsed_range : con IM.map,
@@ -80,8 +63,8 @@ fun frob file =
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)
+ | EFfi x => basis x
+ | EFfiApp (m, x, _) => basis (m, x)
| _ => false}
(U.Exp.map {kind = fn x => x,
con = fn x => x,
@@ -110,14 +93,14 @@ fun frob file =
foldl decl IS.empty file
end
- val ssids = whichIds ssBasis
- val csids = whichIds csBasis
+ 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' (ssBasis, ssids)
- val clientSide = sideish' (csBasis, csids)
+ val serverSide = sideish' (Settings.isServerOnly, ssids)
+ val clientSide = sideish' (Settings.isClientOnly, csids)
val tfuncs = foldl
(fn ((d, _), tfuncs) =>
diff --git a/src/settings.sig b/src/settings.sig
index ba4e1b9a..4e764a78 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -27,13 +27,38 @@
signature SETTINGS = sig
+ (* How do all application URLs begin? *)
val setUrlPrefix : string -> unit
val getUrlPrefix : unit -> string
+ (* How many seconds should the server wait before assuming a Comet client has left? *)
val setTimeout : int -> unit
val getTimeout : unit -> int
+ (* Which C header files are needed? *)
val setHeaders : string list -> unit
val getHeaders : unit -> string list
+ type ffi = string * string
+
+ (* Which FFI types may be sent from clients to servers? *)
+ val setClientToServer : ffi list -> unit
+ val mayClientToServer : ffi -> bool
+
+ (* Which FFI functions have side effects? *)
+ val setEffectful : ffi list -> unit
+ val isEffectful : ffi -> bool
+
+ (* Which FFI functions may only be run in clients? *)
+ val setClientOnly : ffi list -> unit
+ val isClientOnly : ffi -> bool
+
+ (* Which FFI functions may only be run on servers? *)
+ val setServerOnly : ffi list -> unit
+ val isServerOnly : ffi -> bool
+
+ (* Which FFI functions may be run in JavaScript? (JavaScript function names included) *)
+ val setJsFuncs : (ffi * string) list -> unit
+ val jsFunc : ffi -> string option
+
end
diff --git a/src/settings.sml b/src/settings.sml
index 1bc14776..b022219d 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -46,4 +46,101 @@ fun setTimeout n = timeout := n
fun getHeaders () = !headers
fun setHeaders ls = headers := ls
+type ffi = string * string
+
+structure K = struct
+type ord_key = ffi
+fun compare ((m1, x1), (m2, x2)) =
+ Order.join (String.compare (m1, m2),
+ fn () => String.compare (x1, x2))
+end
+
+structure S = BinarySetFn(K)
+structure M = BinaryMapFn(K)
+
+fun basis x = S.addList (S.empty, map (fn x : string => ("Basis", x)) x)
+
+val clientToServerBase = basis ["int",
+ "float",
+ "string",
+ "time",
+ "file",
+ "unit",
+ "option",
+ "list",
+ "bool"]
+val clientToServer = ref clientToServerBase
+fun setClientToServer ls = clientToServer := S.addList (clientToServerBase, ls)
+fun mayClientToServer x = S.member (!clientToServer, x)
+
+val effectfulBase = basis ["set_cookie",
+ "new_client_source",
+ "get_client_source",
+ "set_client_source",
+ "alert",
+ "new_channel",
+ "send",
+ "onError",
+ "onFail",
+ "onConnectFail",
+ "onDisconnect",
+ "onServerError"]
+
+val effectful = ref effectfulBase
+fun setEffectful ls = effectful := S.addList (effectfulBase, ls)
+fun isEffectful x = S.member (!effectful, x)
+
+val clientBase = basis ["get",
+ "set",
+ "alert",
+ "recv",
+ "sleep",
+ "spawn",
+ "onError",
+ "onFail",
+ "onConnectFail",
+ "onDisconnect",
+ "onServerError"]
+val client = ref clientBase
+fun setClientOnly ls = client := S.addList (clientBase, ls)
+fun isClientOnly x = S.member (!client, x)
+
+val serverBase = basis ["requestHeader",
+ "query",
+ "dml",
+ "nextval",
+ "channel",
+ "send"]
+val server = ref serverBase
+fun setServerOnly ls = server := S.addList (serverBase, ls)
+fun isServerOnly x = S.member (!server, x)
+
+val basisM = foldl (fn ((k, v : string), m) => M.insert (m, ("Basis", k), v)) M.empty
+
+val jsFuncsBase = basisM [("alert", "alert"),
+ ("get_client_source", "sg"),
+ ("htmlifyBool", "bs"),
+ ("htmlifyFloat", "ts"),
+ ("htmlifyInt", "ts"),
+ ("htmlifyString", "eh"),
+ ("new_client_source", "sc"),
+ ("set_client_source", "sv"),
+ ("stringToFloat_error", "pfl"),
+ ("stringToInt_error", "pi"),
+ ("urlifyInt", "ts"),
+ ("urlifyFloat", "ts"),
+ ("urlifyString", "uf"),
+ ("recv", "rv"),
+ ("strcat", "cat"),
+ ("intToString", "ts"),
+ ("floatToString", "ts"),
+ ("onError", "onError"),
+ ("onFail", "onFail"),
+ ("onConnectFail", "onConnectFail"),
+ ("onDisconnect", "onDisconnect"),
+ ("onServerError", "onServerError")]
+val jsFuncs = ref jsFuncsBase
+fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls
+fun jsFunc x = M.find (!jsFuncs, x)
+
end