summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2010-02-27 16:49:11 -0500
committerGravatar Adam Chlipala <adamc@hcoop.net>2010-02-27 16:49:11 -0500
commit0c209d971e2813d9a5e3cac699f3f5c8ad278f7d (patch)
tree64c89f63745865e9d0e443dc8cc8ecc2cac7900b /src
parent3e9d47d0248f71983209f5a8640aa160bcf564a5 (diff)
benignEffectful
Diffstat (limited to 'src')
-rw-r--r--src/compiler.sig1
-rw-r--r--src/compiler.sml9
-rw-r--r--src/demo.sml1
-rw-r--r--src/mono_reduce.sml6
-rw-r--r--src/settings.sig4
-rw-r--r--src/settings.sml33
6 files changed, 36 insertions, 18 deletions
diff --git a/src/compiler.sig b/src/compiler.sig
index 3d77a4cd..63da4e5c 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -44,6 +44,7 @@ signature COMPILER = sig
scripts : string list,
clientToServer : Settings.ffi list,
effectful : Settings.ffi list,
+ benignEffectful : Settings.ffi list,
clientOnly : Settings.ffi list,
serverOnly : Settings.ffi list,
jsFuncs : (Settings.ffi * string) list,
diff --git a/src/compiler.sml b/src/compiler.sml
index c74a0915..f0313c8b 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -48,6 +48,7 @@ type job = {
scripts : string list,
clientToServer : Settings.ffi list,
effectful : Settings.ffi list,
+ benignEffectful : Settings.ffi list,
clientOnly : Settings.ffi list,
serverOnly : Settings.ffi list,
jsFuncs : (Settings.ffi * string) list,
@@ -212,7 +213,7 @@ val parseUr = {
fun p_job ({prefix, database, exe, sql, sources, debug, profile,
timeout, ffi, link, headers, scripts,
- clientToServer, effectful, clientOnly, serverOnly, jsFuncs, ...} : job) =
+ clientToServer, effectful, benignEffectful, clientOnly, serverOnly, jsFuncs, ...} : job) =
let
open Print.PD
open Print
@@ -248,6 +249,7 @@ fun p_job ({prefix, database, exe, sql, sources, debug, profile,
p_list_sep (box []) (fn s => box [string "Link", space, string s, newline]) link,
p_ffi "ClientToServer" clientToServer,
p_ffi "Effectful" effectful,
+ p_ffi "BenignEffectful" benignEffectful,
p_ffi "ClientOnly" clientOnly,
p_ffi "ServerOnly" serverOnly,
p_list_sep (box []) (fn ((m, s), s') =>
@@ -371,6 +373,7 @@ fun parseUrp' accLibs fname =
val scripts = ref []
val clientToServer = ref []
val effectful = ref []
+ val benignEffectful = ref []
val clientOnly = ref []
val serverOnly = ref []
val jsFuncs = ref []
@@ -399,6 +402,7 @@ fun parseUrp' accLibs fname =
scripts = rev (!scripts),
clientToServer = rev (!clientToServer),
effectful = rev (!effectful),
+ benignEffectful = rev (!benignEffectful),
clientOnly = rev (!clientOnly),
serverOnly = rev (!serverOnly),
jsFuncs = rev (!jsFuncs),
@@ -439,6 +443,7 @@ fun parseUrp' accLibs fname =
scripts = #scripts old @ #scripts new,
clientToServer = #clientToServer old @ #clientToServer new,
effectful = #effectful old @ #effectful new,
+ benignEffectful = #benignEffectful old @ #benignEffectful new,
clientOnly = #clientOnly old @ #clientOnly new,
serverOnly = #serverOnly old @ #serverOnly new,
jsFuncs = #jsFuncs old @ #jsFuncs new,
@@ -564,6 +569,7 @@ fun parseUrp' accLibs fname =
| "script" => scripts := arg :: !scripts
| "clientToServer" => clientToServer := ffiS () :: !clientToServer
| "effectful" => effectful := ffiS () :: !effectful
+ | "benignEffectful" => benignEffectful := ffiS () :: !benignEffectful
| "clientOnly" => clientOnly := ffiS () :: !clientOnly
| "serverOnly" => serverOnly := ffiS () :: !serverOnly
| "jsFunc" => jsFuncs := ffiM () :: !jsFuncs
@@ -626,6 +632,7 @@ fun parseUrp' accLibs fname =
Settings.setScripts (#scripts job);
Settings.setClientToServer (#clientToServer job);
Settings.setEffectful (#effectful job);
+ Settings.setBenignEffectful (#benignEffectful job);
Settings.setClientOnly (#clientOnly job);
Settings.setServerOnly (#serverOnly job);
Settings.setJsFuncs (#jsFuncs job);
diff --git a/src/demo.sml b/src/demo.sml
index 6280400b..6ae64264 100644
--- a/src/demo.sml
+++ b/src/demo.sml
@@ -105,6 +105,7 @@ fun make' {prefix, dirname, guided} =
scripts = [],
clientToServer = [],
effectful = [],
+ benignEffectful = [],
clientOnly = [],
serverOnly = [],
jsFuncs = [],
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 10de1c56..6bd5ceb8 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -52,7 +52,7 @@ fun simpleImpure (tsyms, syms) =
| EDml _ => true
| ENextval _ => true
| ESetval _ => true
- | EFfiApp (m, x, _) => Settings.isEffectful (m, x)
+ | EFfiApp (m, x, _) => Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x)
| EServerCall _ => true
| ERecv _ => true
| ESleep _ => true
@@ -87,7 +87,7 @@ fun impure (e, _) =
| ENone _ => false
| ESome (_, e) => impure e
| EFfi _ => false
- | EFfiApp (m, x, _) => Settings.isEffectful (m, x)
+ | EFfiApp (m, x, _) => Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x)
| EApp ((EFfi _, _), _) => false
| EApp _ => true
@@ -372,7 +372,7 @@ fun reduce file =
| ESome (_, e) => summarize d e
| EFfi _ => []
| EFfiApp (m, x, es) =>
- if Settings.isEffectful (m, x) then
+ if Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x) then
List.concat (map (summarize d) es) @ [Unsure]
else
List.concat (map (summarize d) es)
diff --git a/src/settings.sig b/src/settings.sig
index 348c47d4..3179c229 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -58,6 +58,10 @@ signature SETTINGS = sig
val setEffectful : ffi list -> unit
val isEffectful : ffi -> bool
+ (* Which FFI functions should not have their calls removed or reordered, but cause no lasting effects? *)
+ val setBenignEffectful : ffi list -> unit
+ val isBenignEffectful : ffi -> bool
+
(* Which FFI functions may only be run in clients? *)
val setClientOnly : ffi list -> unit
val isClientOnly : ffi -> bool
diff --git a/src/settings.sml b/src/settings.sml
index f600d2ac..cd081725 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -80,28 +80,33 @@ fun mayClientToServer x = S.member (!clientToServer, x)
val effectfulBase = basis ["dml",
"nextval",
"setval",
- "get_cookie",
"set_cookie",
"clear_cookie",
- "new_client_source",
- "get_client_source",
- "set_client_source",
- "current",
- "alert",
"new_channel",
- "send",
- "onError",
- "onFail",
- "onConnectFail",
- "onDisconnect",
- "onServerError",
- "kc",
- "debug"]
+ "send"]
val effectful = ref effectfulBase
fun setEffectful ls = effectful := S.addList (effectfulBase, ls)
fun isEffectful x = S.member (!effectful, x)
+val benignBase = basis ["get_cookie",
+ "new_client_source",
+ "get_client_source",
+ "set_client_source",
+ "current",
+ "alert",
+ "onError",
+ "onFail",
+ "onConnectFail",
+ "onDisconnect",
+ "onServerError",
+ "kc",
+ "debug"]
+
+val benign = ref benignBase
+fun setBenignEffectful ls = benign := S.addList (benignBase, ls)
+fun isBenignEffectful x = S.member (!benign, x)
+
val clientBase = basis ["get",
"set",
"current",