Mercurial > urweb
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