summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--include/urweb/types_cpp.h28
-rw-r--r--include/urweb/urweb_cpp.h6
-rw-r--r--src/c/openssl.c4
-rw-r--r--src/c/urweb.c78
-rw-r--r--src/lru_cache.sml12
-rw-r--r--src/sqlcache.sml174
6 files changed, 221 insertions, 81 deletions
diff --git a/include/urweb/types_cpp.h b/include/urweb/types_cpp.h
index 7b9a90a4..84423105 100644
--- a/include/urweb/types_cpp.h
+++ b/include/urweb/types_cpp.h
@@ -123,31 +123,31 @@ typedef struct {
#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
diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h
index 3fac7041..05e3e4a0 100644
--- a/include/urweb/urweb_cpp.h
+++ b/include/urweb/urweb_cpp.h
@@ -406,8 +406,8 @@ void uw_Basis_writec(struct uw_context *, char);
#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
diff --git a/src/c/openssl.c b/src/c/openssl.c
index 6d018707..533c3e21 100644
--- a/src/c/openssl.c
+++ b/src/c/openssl.c
@@ -35,7 +35,7 @@ static void random_password() {
// 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 @@ void uw_init_crypto() {
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");
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 66fedfa2..61742693 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -4498,7 +4498,7 @@ void uw_set_remoteSock(uw_context ctx, int sock) {
// 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 @@ void uw_sqlcache_listDelete(uw_sqlcache_CacheList *list, uw_sqlcache_CacheEntry
--(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 @@ void uw_sqlcache_listAdd(uw_sqlcache_CacheList *list, uw_sqlcache_CacheEntry *en
++(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_freeuw_sqlcache_CacheValue(uw_sqlcache_CacheValue *value) {
}
}
-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);
+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;
+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_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_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_flushHelper(uw_sqlcache_Cache *cache, char **keys, int timeNow)
}
}
-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());
}
diff --git a/src/lru_cache.sml b/src/lru_cache.sml
index 26590312..0030777f 100644
--- a/src/lru_cache.sml
+++ b/src/lru_cache.sml
@@ -64,7 +64,7 @@ fun setupQuery {index, params} =
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 @@ fun setupQuery {index, params} =
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 @@ fun setupQuery {index, params} =
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 @@ fun setupQuery {index, params} =
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 @@ fun setupQuery {index, params} =
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 @@ fun setupQuery {index, params} =
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,
diff --git a/src/sqlcache.sml b/src/sqlcache.sml
index 8fae15eb..8efe999c 100644
--- a/src/sqlcache.sml
+++ b/src/sqlcache.sml
@@ -1,4 +1,4 @@
-structure Sqlcache (* DEBUG: add back :> SQLCACHE. *) = struct
+structure Sqlcache :> SQLCACHE = struct
open Mono
@@ -9,6 +9,12 @@ structure SS = BinarySetFn(SK)
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 @@ val ffiEffectful =
"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 @@ fun getCache () = !cache
(* 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 @@ fun effectful (effs : IS.set) =
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 @@ fun effectful (effs : IS.set) =
| EWrite _ => false
| ESeq _ => false
| ELet _ => false
- (* ASK: what should we do about closures? *)
- | EClosure _ => false
| EUnurlify _ => false
+ (* ASK: what should we do about closures? *)
(* 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 effectful (effs : IS.set) =
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 @@ structure ConflictMaps = struct
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 cacheWrap (query, i, urlifiedRel0, resultTyp, args) =
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 factorOutNontrivial text =
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 addChecking file =
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 @@ fun addChecking file =
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 @@ fun go file =
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-14 16:38:14 +0000