changeset 2250:c275bbc41194

Start work on pure expression caching.
author Ziv Scully <ziv@mit.edu>
date Sun, 13 Sep 2015 16:02:45 -0400
parents c05851bf7861
children 25874084bf1f
files include/urweb/types_cpp.h include/urweb/urweb_cpp.h src/c/openssl.c src/c/urweb.c src/lru_cache.sml src/sqlcache.sml
diffstat 6 files changed, 226 insertions(+), 86 deletions(-) [+]
line wrap: on
line diff
--- a/include/urweb/types_cpp.h	Sat Sep 12 17:11:33 2015 -0400
+++ b/include/urweb/types_cpp.h	Sun Sep 13 16:02:45 2015 -0400
@@ -123,31 +123,31 @@
 
 #include "uthash.h"
 
-typedef struct uw_sqlcache_CacheValue {
+typedef struct uw_Sqlcache_CacheValue {
   char *result;
   char *output;
-} uw_sqlcache_CacheValue;
+} uw_Sqlcache_CacheValue;
 
-typedef struct uw_sqlcache_CacheEntry {
+typedef struct uw_Sqlcache_CacheEntry {
   char *key;
   void *value;
   time_t timeValid;
-  struct uw_sqlcache_CacheEntry *prev;
-  struct uw_sqlcache_CacheEntry *next;
+  struct uw_Sqlcache_CacheEntry *prev;
+  struct uw_Sqlcache_CacheEntry *next;
   UT_hash_handle hh;
-} uw_sqlcache_CacheEntry;
+} uw_Sqlcache_CacheEntry;
 
-typedef struct uw_sqlcache_CacheList {
-  uw_sqlcache_CacheEntry *first;
-  uw_sqlcache_CacheEntry *last;
+typedef struct uw_Sqlcache_CacheList {
+  uw_Sqlcache_CacheEntry *first;
+  uw_Sqlcache_CacheEntry *last;
   int size;
-} uw_sqlcache_CacheList;
+} uw_Sqlcache_CacheList;
 
-typedef struct uw_sqlcache_Cache {
-  uw_sqlcache_CacheEntry *table;
+typedef struct uw_Sqlcache_Cache {
+  uw_Sqlcache_CacheEntry *table;
   time_t timeInvalid;
-  uw_sqlcache_CacheList *lru;
+  uw_Sqlcache_CacheList *lru;
   int height;
-} uw_sqlcache_Cache;
+} uw_Sqlcache_Cache;
 
 #endif
--- a/include/urweb/urweb_cpp.h	Sat Sep 12 17:11:33 2015 -0400
+++ b/include/urweb/urweb_cpp.h	Sun Sep 13 16:02:45 2015 -0400
@@ -406,8 +406,8 @@
 
 #include "uthash.h"
 
-uw_sqlcache_CacheValue *uw_sqlcache_check(uw_sqlcache_Cache *, char **);
-uw_sqlcache_CacheValue *uw_sqlcache_store(uw_sqlcache_Cache *, char **, uw_sqlcache_CacheValue *);
-uw_sqlcache_CacheValue *uw_sqlcache_flush(uw_sqlcache_Cache *, char **);
+uw_Sqlcache_CacheValue *uw_Sqlcache_check(uw_Sqlcache_Cache *, char **);
+uw_Sqlcache_CacheValue *uw_Sqlcache_store(uw_Sqlcache_Cache *, char **, uw_Sqlcache_CacheValue *);
+uw_Sqlcache_CacheValue *uw_Sqlcache_flush(uw_Sqlcache_Cache *, char **);
 
 #endif
--- a/src/c/openssl.c	Sat Sep 12 17:11:33 2015 -0400
+++ b/src/c/openssl.c	Sun Sep 13 16:02:45 2015 -0400
@@ -35,7 +35,7 @@
 
 // OpenSSL callbacks
 static void thread_id(CRYPTO_THREADID *const result) {
-  CRYPTO_THREADID_set_numeric(result, pthread_self());
+  CRYPTO_THREADID_set_numeric(result, (unsigned long)pthread_self());
 }
 static void lock_or_unlock(const int mode, const int type, const char *file,
                            const int line) {
@@ -73,7 +73,7 @@
 
     if (access(uw_sig_file, F_OK)) {
       random_password();
-      
+
       if ((fd = open(uw_sig_file, O_WRONLY | O_CREAT, 0700)) < 0) {
         fprintf(stderr, "Can't open signature file %s\n", uw_sig_file);
         perror("open");
--- a/src/c/urweb.c	Sat Sep 12 17:11:33 2015 -0400
+++ b/src/c/urweb.c	Sun Sep 13 16:02:45 2015 -0400
@@ -4498,7 +4498,7 @@
 
 // Sqlcache
 
-void uw_sqlcache_listDelete(uw_sqlcache_CacheList *list, uw_sqlcache_CacheEntry *entry) {
+void uw_Sqlcache_listDelete(uw_Sqlcache_CacheList *list, uw_Sqlcache_CacheEntry *entry) {
   if (list->first == entry) {
     list->first = entry->next;
   }
@@ -4516,7 +4516,7 @@
   --(list->size);
 }
 
-void uw_sqlcache_listAdd(uw_sqlcache_CacheList *list, uw_sqlcache_CacheEntry *entry) {
+void uw_Sqlcache_listAdd(uw_Sqlcache_CacheList *list, uw_Sqlcache_CacheEntry *entry) {
   if (list->last) {
     list->last->next = entry;
     entry->prev = list->last;
@@ -4528,22 +4528,22 @@
   ++(list->size);
 }
 
-void uw_sqlcache_listBump(uw_sqlcache_CacheList *list, uw_sqlcache_CacheEntry *entry) {
-  uw_sqlcache_listDelete(list, entry);
-  uw_sqlcache_listAdd(list, entry);
+void uw_Sqlcache_listBump(uw_Sqlcache_CacheList *list, uw_Sqlcache_CacheEntry *entry) {
+  uw_Sqlcache_listDelete(list, entry);
+  uw_Sqlcache_listAdd(list, entry);
 }
 
 // TODO: deal with time properly.
 
-time_t uw_sqlcache_getTimeNow() {
+time_t uw_Sqlcache_getTimeNow() {
   return time(NULL);
 }
 
-time_t uw_sqlcache_timeMax(time_t x, time_t y) {
+time_t uw_Sqlcache_timeMax(time_t x, time_t y) {
   return difftime(x, y) > 0 ? x : y;
 }
 
-void uw_sqlcache_freeuw_sqlcache_CacheValue(uw_sqlcache_CacheValue *value) {
+void uw_Sqlcache_freeuw_Sqlcache_CacheValue(uw_Sqlcache_CacheValue *value) {
   if (value) {
     free(value->result);
     free(value->output);
@@ -4551,83 +4551,83 @@
   }
 }
 
-void uw_sqlcache_delete(uw_sqlcache_Cache *cache, uw_sqlcache_CacheEntry* entry) {
-  //uw_sqlcache_listUw_Sqlcache_Delete(cache->lru, entry);
+void uw_Sqlcache_delete(uw_Sqlcache_Cache *cache, uw_Sqlcache_CacheEntry* entry) {
+  //uw_Sqlcache_listUw_Sqlcache_Delete(cache->lru, entry);
   HASH_DELETE(hh, cache->table, entry);
-  uw_sqlcache_freeuw_sqlcache_CacheValue(entry->value);
+  uw_Sqlcache_freeuw_Sqlcache_CacheValue(entry->value);
   free(entry->key);
   free(entry);
 }
 
-uw_sqlcache_CacheValue *uw_sqlcache_checkHelper(uw_sqlcache_Cache *cache, char **keys, int timeInvalid) {
+uw_Sqlcache_CacheValue *uw_Sqlcache_checkHelper(uw_Sqlcache_Cache *cache, char **keys, int timeInvalid) {
   char *key = keys[cache->height];
-  uw_sqlcache_CacheEntry *entry;
+  uw_Sqlcache_CacheEntry *entry;
   HASH_FIND(hh, cache->table, key, strlen(key), entry);
-  timeInvalid = uw_sqlcache_timeMax(timeInvalid, cache->timeInvalid);
+  timeInvalid = uw_Sqlcache_timeMax(timeInvalid, cache->timeInvalid);
   if (entry && difftime(entry->timeValid, timeInvalid) > 0) {
     if (cache->height == 0) {
       // At height 0, entry->value is the desired value.
-      //uw_sqlcache_listBump(cache->lru, entry);
+      //uw_Sqlcache_listBump(cache->lru, entry);
       return entry->value;
     } else {
       // At height n+1, entry->value is a pointer to a cache at heignt n.
-      return uw_sqlcache_checkHelper(entry->value, keys, timeInvalid);
+      return uw_Sqlcache_checkHelper(entry->value, keys, timeInvalid);
     }
   } else {
     return NULL;
   }
 }
 
-uw_sqlcache_CacheValue *uw_sqlcache_check(uw_sqlcache_Cache *cache, char **keys) {
-  return uw_sqlcache_checkHelper(cache, keys, 0);
-}
-
-void uw_sqlcache_storeHelper(uw_sqlcache_Cache *cache, char **keys, uw_sqlcache_CacheValue *value, int timeNow) {
-  uw_sqlcache_CacheEntry *entry;
+uw_Sqlcache_CacheValue *uw_Sqlcache_check(uw_Sqlcache_Cache *cache, char **keys) {
+  return uw_Sqlcache_checkHelper(cache, keys, 0);
+}
+
+void uw_Sqlcache_storeHelper(uw_Sqlcache_Cache *cache, char **keys, uw_Sqlcache_CacheValue *value, int timeNow) {
+  uw_Sqlcache_CacheEntry *entry;
   char *key = keys[cache->height];
   HASH_FIND(hh, cache->table, key, strlen(key), entry);
   if (!entry) {
-    entry = malloc(sizeof(uw_sqlcache_CacheEntry));
+    entry = malloc(sizeof(uw_Sqlcache_CacheEntry));
     entry->key = strdup(key);
     entry->value = NULL;
     HASH_ADD_KEYPTR(hh, cache->table, entry->key, strlen(entry->key), entry);
   }
   entry->timeValid = timeNow;
   if (cache->height == 0) {
-    //uw_sqlcache_listAdd(cache->lru, entry);
-    uw_sqlcache_freeuw_sqlcache_CacheValue(entry->value);
+    //uw_Sqlcache_listAdd(cache->lru, entry);
+    uw_Sqlcache_freeuw_Sqlcache_CacheValue(entry->value);
     entry->value = value;
     //if (cache->lru->size > MAX_SIZE) {
-      //uw_sqlcache_delete(cache, cache->lru->first);
+      //uw_Sqlcache_delete(cache, cache->lru->first);
       // TODO: return flushed value.
     //}
   } else {
     if (!entry->value) {
-      uw_sqlcache_Cache *newuw_sqlcache_Cache = malloc(sizeof(uw_sqlcache_Cache));
-      newuw_sqlcache_Cache->table = NULL;
-      newuw_sqlcache_Cache->timeInvalid = timeNow;
-      newuw_sqlcache_Cache->lru = cache->lru;
-      newuw_sqlcache_Cache->height = cache->height - 1;
-      entry->value = newuw_sqlcache_Cache;
+      uw_Sqlcache_Cache *newuw_Sqlcache_Cache = malloc(sizeof(uw_Sqlcache_Cache));
+      newuw_Sqlcache_Cache->table = NULL;
+      newuw_Sqlcache_Cache->timeInvalid = timeNow;
+      newuw_Sqlcache_Cache->lru = cache->lru;
+      newuw_Sqlcache_Cache->height = cache->height - 1;
+      entry->value = newuw_Sqlcache_Cache;
     }
-    uw_sqlcache_storeHelper(entry->value, keys, value, timeNow);
+    uw_Sqlcache_storeHelper(entry->value, keys, value, timeNow);
   }
 }
 
-void uw_sqlcache_store(uw_sqlcache_Cache *cache, char **keys, uw_sqlcache_CacheValue *value) {
-  uw_sqlcache_storeHelper(cache, keys, value, uw_sqlcache_getTimeNow());
-}
-
-void uw_sqlcache_flushHelper(uw_sqlcache_Cache *cache, char **keys, int timeNow) {
-  uw_sqlcache_CacheEntry *entry;
+void uw_Sqlcache_store(uw_Sqlcache_Cache *cache, char **keys, uw_Sqlcache_CacheValue *value) {
+  uw_Sqlcache_storeHelper(cache, keys, value, uw_Sqlcache_getTimeNow());
+}
+
+void uw_Sqlcache_flushHelper(uw_Sqlcache_Cache *cache, char **keys, int timeNow) {
+  uw_Sqlcache_CacheEntry *entry;
   char *key = keys[cache->height];
   if (key) {
     HASH_FIND(hh, cache->table, key, strlen(key), entry);
     if (entry) {
       if (cache->height == 0) {
-        uw_sqlcache_delete(cache, entry);
+        uw_Sqlcache_delete(cache, entry);
       } else {
-        uw_sqlcache_flushHelper(entry->value, keys, timeNow);
+        uw_Sqlcache_flushHelper(entry->value, keys, timeNow);
       }
     }
   } else {
@@ -4636,6 +4636,6 @@
   }
 }
 
-void uw_sqlcache_flush(uw_sqlcache_Cache *cache, char **keys) {
-  uw_sqlcache_flushHelper(cache, keys, uw_sqlcache_getTimeNow());
-}
+void uw_Sqlcache_flush(uw_Sqlcache_Cache *cache, char **keys) {
+  uw_Sqlcache_flushHelper(cache, keys, uw_Sqlcache_getTimeNow());
+}
--- a/src/lru_cache.sml	Sat Sep 12 17:11:33 2015 -0400
+++ b/src/lru_cache.sml	Sun Sep 13 16:02:45 2015 -0400
@@ -64,7 +64,7 @@
 
     in
         Print.box
-            [string ("static uw_sqlcache_Cache cacheStruct" ^ i ^ " = {"),
+            [string ("static uw_Sqlcache_Cache cacheStruct" ^ i ^ " = {"),
              newline,
              string "  .table = NULL,",
              newline,
@@ -74,7 +74,7 @@
              newline,
              string ("  .height = " ^ Int.toString (params - 1) ^ "};"),
              newline,
-             string ("static uw_sqlcache_Cache *cache" ^ i ^ " = &cacheStruct" ^ i ^ ";"),
+             string ("static uw_Sqlcache_Cache *cache" ^ i ^ " = &cacheStruct" ^ i ^ ";"),
              newline,
              newline,
 
@@ -83,7 +83,7 @@
              newline,
              string ("  char *ks[] = {" ^ revArgs ^ "};"),
              newline,
-             string ("  uw_sqlcache_CacheValue *v = uw_sqlcache_check(cache" ^ i ^ ", ks);"),
+             string ("  uw_Sqlcache_CacheValue *v = uw_Sqlcache_check(cache" ^ i ^ ", ks);"),
              newline,
              string "  if (v) {",
              newline,
@@ -112,7 +112,7 @@
              newline,
              string ("  char *ks[] = {" ^ revArgs ^ "};"),
              newline,
-             string ("  uw_sqlcache_CacheValue *v = malloc(sizeof(uw_sqlcache_CacheValue));"),
+             string ("  uw_Sqlcache_CacheValue *v = malloc(sizeof(uw_Sqlcache_CacheValue));"),
              newline,
              string "  v->result = strdup(s);",
              newline,
@@ -120,7 +120,7 @@
              newline,
              string ("  puts(\"SQLCACHE: stored " ^ i ^ ".\");"),
              newline,
-             string ("  uw_sqlcache_store(cache" ^ i ^ ", ks, v);"),
+             string ("  uw_Sqlcache_store(cache" ^ i ^ ", ks, v);"),
              newline,
              string "  return uw_unit_v;",
              newline,
@@ -133,7 +133,7 @@
              newline,
              string ("  char *ks[] = {" ^ revArgs ^ "};"),
              newline,
-             string ("  uw_sqlcache_flush(cache" ^ i ^ ", ks);"),
+             string ("  uw_Sqlcache_flush(cache" ^ i ^ ", ks);"),
              newline,
              string "  return uw_unit_v;",
              newline,
--- a/src/sqlcache.sml	Sat Sep 12 17:11:33 2015 -0400
+++ b/src/sqlcache.sml	Sun Sep 13 16:02:45 2015 -0400
@@ -1,4 +1,4 @@
-structure Sqlcache (* DEBUG: add back :> SQLCACHE. *) = struct
+structure Sqlcache :> SQLCACHE = struct
 
 open Mono
 
@@ -9,6 +9,12 @@
 structure SM = BinaryMapFn(SK)
 structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS)
 
+fun iterate f n x = if n < 0
+                    then raise Fail "Can't iterate function negative number of times."
+                    else if n = 0
+                    then x
+                    else iterate f (n-1) (f x)
+
 (* Filled in by [cacheWrap] during [Sqlcache]. *)
 val ffiInfo : {index : int, params : int} list ref = ref []
 
@@ -36,7 +42,7 @@
                               "urlifyChannel_w"]
     in
         fn (m, f) => Settings.isEffectful (m, f)
-                     andalso not (m = "Basis" andalso SS.member (fs, f))
+                     orelse not (m = "Basis" andalso SS.member (fs, f))
     end
 
 val cache = ref LruCache.cache
@@ -45,8 +51,8 @@
 
 (* Used to have type context for local variables in MonoUtil functions. *)
 val doBind =
- fn (ctx, MonoUtil.Exp.RelE (_, t)) => t :: ctx
-  | (ctx, _) => ctx
+ fn (env, MonoUtil.Exp.RelE (s, t)) => MonoEnv.pushERel env s t NONE
+  | (env, _) => env
 
 
 (*******************)
@@ -59,12 +65,12 @@
         val isFunction =
          fn (TFun _, _) => true
           | _ => false
-        fun doExp (ctx, e) =
+        fun doExp (env, e) =
             case e of
                 EPrim _ => false
               (* For now: variables of function type might be effectful, but
                  others are fully evaluated and are therefore not effectful. *)
-              | ERel n => isFunction (List.nth (ctx, n))
+              | ERel n => isFunction (#2 (MonoEnv.lookupERel env n))
               | ENamed n => IS.member (effs, n)
               | EFfi (m, f) => ffiEffectful (m, f)
               | EFfiApp (m, f, _) => ffiEffectful (m, f)
@@ -84,9 +90,8 @@
               | EWrite _ => false
               | ESeq _ => false
               | ELet _ => false
+              | EUnurlify _ => false
               (* ASK: what should we do about closures? *)
-              | EClosure _ => false
-              | EUnurlify _ => false
               (* Everything else is some sort of effect. We could flip this and
                  explicitly list bits of Mono that are effectful, but this is
                  conservatively robust to future changes (however unlikely). *)
@@ -99,7 +104,7 @@
 fun effectfulDecls (decls, _) =
     let
         fun doVal ((_, name, _, e, _), effs) =
-            if effectful effs [] e
+            if effectful effs MonoEnv.empty e
             then IS.add (effs, name)
             else effs
         val doDecl =
@@ -362,9 +367,9 @@
     val markDml : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula ->
                   (Sql.cmp * atomExp option * atomExp option) formula =
         mapFormula (toAtomExps DmlRel)
+
     (* No eqs should have key conflicts because no variable is in two
        equivalence classes, so the [#1] could be [#2]. *)
-
     val mergeEqs : (atomExp IntBinaryMap.map option list
                     -> atomExp IntBinaryMap.map option) =
         List.foldr (fn (SOME eqs, SOME acc) => SOME (IM.unionWith #1 (eqs, acc)) | _ => NONE)
@@ -511,10 +516,10 @@
 fun fileMapfold doExp file start =
     case MonoUtil.File.mapfoldB
              {typ = Search.return2,
-              exp = fn ctx => fn e' => fn s => Search.Continue (doExp ctx e' s),
+              exp = fn env => fn e' => fn s => Search.Continue (doExp env e' s),
               decl = fn _ => Search.return2,
               bind = doBind}
-             [] file start of
+             MonoEnv.empty file start of
         Search.Continue x => x
       | Search.Return _ => raise Match
 
@@ -556,8 +561,9 @@
 
 fun addChecking file =
     let
-        fun doExp ctx (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) =
+        fun doExp env (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) =
          fn e' as EQuery {query = origQueryText,
+                          (* ASK: could this get messed up by inlining? *)
                           sqlcacheInfo = urlifiedRel0,
                           state = resultTyp,
                           initial, body, tables, exps} =>
@@ -581,10 +587,14 @@
                 fun guard b x = if b then x else NONE
                 val effs = effectfulDecls file
                 (* We use dummyTyp here. I think this is okay because databases
-                   don't store (effectful) functions, but there could be some
-                   corner case I missed. *)
+                   don't store (effectful) functions, but perhaps there's some
+                   pathalogical corner case missing.... *)
                 fun safe bound =
-                    not o effectful effs (List.tabulate (bound, fn _ => dummyTyp) @ ctx)
+                    not
+                    o effectful effs
+                                (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE)
+                                         bound
+                                         env)
                 val attempt =
                     (* Ziv misses Haskell's do notation.... *)
                     guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) (
@@ -602,7 +612,7 @@
             end
           | e' => (e', queryInfo)
     in
-        fileMapfold (fn ctx => fn exp => fn state => doExp ctx state exp)
+        fileMapfold (fn env => fn exp => fn state => doExp env state exp)
                     file
                     (SIMM.empty, IM.empty, 0)
     end
@@ -716,4 +726,134 @@
         file'
     end
 
+
+(**********************)
+(* Mono Type Checking *)
+(**********************)
+
+val typOfPrim =
+ fn Prim.Int _ => TFfi ("Basis", "int")
+  | Prim.Float _ => TFfi ("Basis", "int")
+
+fun typOfExp' (env : MonoEnv.env) : exp' -> typ option =
+ fn EPrim p => SOME (TFfi ("Basis", case p of
+                                        Prim.Int _ => "int"
+                                      | Prim.Float _ => "double"
+                                      | Prim.String _ => "string"
+                                      | Prim.Char _ => "char"),
+                     dummyLoc)
+  | ERel n => SOME (#2 (MonoEnv.lookupERel env n))
+  | ENamed n => SOME (#2 (MonoEnv.lookupENamed env n))
+  (* ASK: okay to make a new [ref] each time? *)
+  | ECon (dk, PConVar nCon, _) =>
+    let
+        val (_, _, nData) = MonoEnv.lookupConstructor env nCon
+        val (_, cs) = MonoEnv.lookupDatatype env nData
+    in
+        SOME (TDatatype (nData, ref (dk, cs)), dummyLoc)
+    end
+  | ECon (_, PConFfi {mod = s, datatyp, ...}, _) => SOME (TFfi (s, datatyp), dummyLoc)
+  | ENone t => SOME (TOption t, dummyLoc)
+  | ESome (t, _) => SOME (TOption t, dummyLoc)
+  | EFfi _ => NONE
+  | EFfiApp _ => NONE
+  | EApp (e1, e2) => (case typOfExp env e1 of
+                          SOME (TFun (_, t), _) => SOME t
+                        | _ => NONE)
+  | EAbs (_, t1, t2, _) => SOME (TFun (t1, t2), dummyLoc)
+  (* ASK: is this right? *)
+  | EUnop (unop, e) => (case unop of
+                            "!" => SOME (TFfi ("Basis", "bool"), dummyLoc)
+                          | "-" => typOfExp env e
+                          | _ => NONE)
+  (* ASK: how should this (and other "=> NONE" cases) work? *)
+  | EBinop _ => NONE
+  | ERecord fields => SOME (TRecord (map (fn (s, _, t) => (s, t)) fields), dummyLoc)
+  | EField (e, s) => (case typOfExp env e of
+                          SOME (TRecord fields, _) =>
+                          (case List.find (fn (s', _) => s = s') fields of
+                               SOME (_, t) => SOME t
+                             | _ => NONE)
+                        | _ => NONE)
+  | ECase (_, _, {result, ...}) => SOME result
+  | EStrcat _ => SOME (TFfi ("Basis", "string"), dummyLoc)
+  | EWrite _ => SOME (TRecord [], dummyLoc)
+  | ESeq (_, e) => typOfExp env e
+  | ELet (s, t, e1, e2) => typOfExp (MonoEnv.pushERel env s t (SOME e1)) e2
+  | EClosure _ => NONE
+  | EUnurlify (_, t, _) => SOME t
+
+and typOfExp env (e', loc) = typOfExp' env e'
+
+
+(*******************************)
+(* Caching Pure Subexpressions *)
+(*******************************)
+
+datatype subexp = Pure of unit -> exp | Impure of exp
+
+val isImpure =
+ fn Pure _ => false
+  | Impure _ => true
+
+val expOfSubexp =
+ fn Pure f => f ()
+  | Impure e => e
+
+val makeCache : MonoEnv.env -> exp' -> exp' = fn _ => fn _ => raise Fail "TODO"
+
+fun pureCache (effs : IS.set) (env : MonoEnv.env) (exp as (exp', loc)) : subexp =
+    let
+        fun wrapBindN f (args : (MonoEnv.env * exp) list) =
+            let
+                val subexps = map (fn (env, exp) => pureCache effs env exp) args
+            in
+                if List.exists isImpure subexps
+                then Impure (f (map expOfSubexp subexps), loc)
+                else Pure (fn () => (makeCache env (f (map #2 args)), loc))
+            end
+        fun wrapBind1 f arg =
+            wrapBindN (fn [arg] => f arg | _ => raise Match) [arg]
+        fun wrapBind2 f (arg1, arg2) =
+            wrapBindN (fn [arg1, arg2] => f (arg1, arg2) | _ => raise Match) [arg1, arg2]
+        fun wrapN f es = wrapBindN f (map (fn e => (env, e)) es)
+        fun wrap1 f e = wrapBind1 f (env, e)
+        fun wrap2 f (e1, e2) = wrapBind2 f ((env, e1), (env, e2))
+    in
+        case exp' of
+            ECon (dk, pc, SOME e) => wrap1 (fn e => ECon (dk, pc, SOME e)) e
+          | ESome (t, e) => wrap1 (fn e => ESome (t, e)) e
+          | EFfiApp (s1, s2, args) =>
+            wrapN (fn es => EFfiApp (s1, s2, ListPair.map (fn (e, (_, t)) => (e, t)) (es, args)))
+                  (map #1 args)
+          | EApp (e1, e2) => wrap2 EApp (e1, e2)
+          | EAbs (s, t1, t2, e) =>
+            wrapBind1 (fn e => EAbs (s, t1, t2, e))
+                      (MonoEnv.pushERel env s t1 NONE, e)
+          | EUnop (s, e) => wrap1 (fn e => EUnop (s, e)) e
+          | EBinop (bi, s, e1, e2) => wrap2 (fn (e1, e2) => EBinop (bi, s, e1, e2)) (e1, e2)
+          | ERecord fields =>
+            wrapN (fn es => ERecord (ListPair.map (fn (e, (s, _, t)) => (s, e, t)) (es, fields)))
+                  (map #2 fields)
+          | EField (e, s) => wrap1 (fn e => EField (e, s)) e
+          | ECase (e, cases, {disc, result}) =>
+            wrapBindN (fn (e::es) =>
+                          ECase (e,
+                                 (ListPair.map (fn (e, (p, _)) => (p, e)) (es, cases)),
+                                 {disc = disc, result = result}))
+                      ((env, e) :: map (fn (p, e) => (MonoEnv.patBinds env p, e)) cases)
+          | EStrcat (e1, e2) => wrap2 EStrcat (e1, e2)
+          (* We record page writes, so they're cachable. *)
+          | EWrite e => wrap1 EWrite e
+          | ESeq (e1, e2) => wrap2 ESeq (e1, e2)
+          | ELet (s, t, e1, e2) =>
+            wrapBind2 (fn (e1, e2) => ELet (s, t, e1, e2))
+                      ((env, e1), (MonoEnv.pushERel env s t (SOME e1), e2))
+          (* ASK: | EClosure (n, es) => ? *)
+          | EUnurlify (e, t, b) => wrap1 (fn e => EUnurlify (e, t, b)) e
+          | _ => if effectful effs env exp
+                 then Impure exp
+                 else Pure (fn () => (makeCache env exp', loc))
+    end
+
 end