benignEffectful

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",