summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/cjr_print.sml14
-rw-r--r--src/sql.sig6
-rw-r--r--src/sqlcache.sml67
3 files changed, 42 insertions, 45 deletions
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index b2e8d2a7..8ca35234 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -3393,7 +3393,7 @@ fun p_file env (ds, ps) =
newline,
newline,
- (* For caching. *)
+ (* For sqlcache. *)
box (List.map
(fn index =>
let val i = Int.toString index
@@ -3403,19 +3403,21 @@ fun p_file env (ds, ps) =
newline,
string "static uw_Basis_bool uw_Cache_check",
string i,
- string "(uw_context ctx) { puts(\"Checked cache ",
+ string "(uw_context ctx) { puts(\"SQLCACHE: checked ",
string i,
string ".\"); if (cache",
string i,
string " == NULL) { uw_recordingStart(ctx); return uw_Basis_False; } else { uw_write(ctx, cache",
string i,
- string "); return uw_Basis_True; } };",
+ string "); puts(\"SQLCACHE: used ",
+ string i,
+ string ".\"); return uw_Basis_True; } };",
newline,
string "static uw_unit uw_Cache_store",
string i,
string "(uw_context ctx) { cache",
string i,
- string " = uw_recordingRead(ctx); puts(\"Stored cache ",
+ string " = uw_recordingRead(ctx); puts(\"SQLCACHE: stored ",
string i,
string ".\"); return uw_unit_v; };",
newline,
@@ -3425,7 +3427,7 @@ fun p_file env (ds, ps) =
string i,
string "); cache",
string i,
- string " = NULL; puts(\"Flushed cache ",
+ string " = NULL; puts(\"SQLCACHE: flushed ",
string i,
string ".\"); return uw_unit_v; };",
newline,
@@ -3564,7 +3566,7 @@ fun p_file env (ds, ps) =
newline,
string ("uw_write_header(ctx, \"Content-Length: " ^ Int.toString (Word8Vector.length (#Bytes r)) ^ "\\r\\n\");"),
newline,
- string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"),
+ string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"),
newline,
string "uw_replace_page(ctx, \"",
string (hexify (#Bytes r)),
diff --git a/src/sql.sig b/src/sql.sig
index 573a8baf..2623f5e7 100644
--- a/src/sql.sig
+++ b/src/sql.sig
@@ -39,11 +39,7 @@ datatype prop =
| Reln of reln * exp list
| Cond of exp * prop
-datatype chunk =
- String of string
- | Exp of Mono.exp
-
-type 'a parser = chunk list -> ('a * chunk list) option
+type 'a parser
val parse : 'a parser -> Mono.exp -> 'a option
diff --git a/src/sqlcache.sml b/src/sqlcache.sml
index 2e7f6e42..b01de4c9 100644
--- a/src/sqlcache.sml
+++ b/src/sqlcache.sml
@@ -12,6 +12,37 @@ structure SIMM = MultimapFn (structure KeyMap = SM structure ValSet = IS)
val ffiIndices : int list ref = ref []
+(* Expression construction utilities. *)
+
+fun intExp (n, loc) = (EPrim (Prim.Int (Int64.fromInt n)), loc)
+fun intTyp loc = (TFfi ("Basis", "int"), loc)
+fun boolPat (b, loc) = (PCon (Enum,
+ PConFfi {mod = "Basis", datatyp = "bool", arg = NONE,
+ con = if b then "True" else "False"},
+ NONE),
+ loc)
+fun boolTyp loc = (TFfi ("Basis", "int"), loc)
+
+fun ffiAppExp (module, func, index, loc) =
+ (EFfiApp (module, func ^ Int.toString index, []), loc)
+
+fun sequence ((exp :: exps), loc) =
+ List.foldl (fn (exp, seq) => (ESeq (seq, exp), loc)) exp exps
+
+fun antiguardUnit (cond, exp, loc) =
+ (ECase (cond,
+ [(boolPat (false, loc), exp),
+ (boolPat (true, loc), (ERecord [], loc))],
+ {disc = boolTyp loc, result = (TRecord [], loc)}),
+ loc)
+
+fun underAbs f (exp as (exp', loc)) =
+ case exp' of
+ EAbs (x, y, z, body) => (EAbs (x, y, z, underAbs f body), loc)
+ | _ => f exp
+
+(* Program analysis and augmentation. *)
+
val rec tablesRead =
fn Query1 {From=tablePairs, ...} => SS.fromList (map #1 tablePairs)
| Union (q1,q2) => SS.union (tablesRead q1, tablesRead q2)
@@ -47,37 +78,6 @@ val tablesInExp =
{read = SS.empty, written = SS.empty}
end
-fun intExp (n, loc) = (EPrim (Prim.Int (Int64.fromInt n)), loc)
-fun intTyp loc = (TFfi ("Basis", "int"), loc)
-fun boolPat (b, loc) = (PCon (Enum,
- PConFfi {mod = "Basis", datatyp = "bool", arg = NONE,
- con = if b then "True" else "False"},
- NONE),
- loc)
-fun boolTyp loc = (TFfi ("Basis", "int"), loc)
-
-fun ffiAppExp (module, func, index, loc) =
- (EFfiApp (module, func ^ Int.toString index, []), loc)
-
-fun sequence (befores, center, afters, loc) =
- List.foldr (fn (exp, seq) => (ESeq (exp, seq), loc))
- (List.foldl (fn (exp, seq) => (ESeq (seq, exp), loc))
- center
- afters)
- befores
-
-fun antiguardUnit (cond, exp, loc) =
- (ECase (cond,
- [(boolPat (false, loc), exp),
- (boolPat (true, loc), (ERecord [], loc))],
- {disc = boolTyp loc, result = (TRecord [], loc)}),
- loc)
-
-fun underAbs f (exp as (exp', loc)) =
- case exp' of
- EAbs (x, y, z, body) => (EAbs (x, y, z, underAbs f body), loc)
- | _ => f exp
-
fun addCacheCheck (index, exp) =
let
fun f (body as (_, loc)) =
@@ -85,7 +85,7 @@ fun addCacheCheck (index, exp) =
val check = ffiAppExp ("Cache", "check", index, loc)
val store = ffiAppExp ("Cache", "store", index, loc)
in
- antiguardUnit (check, sequence ([], body, [store], loc), loc)
+ antiguardUnit (check, sequence ([body, store], loc), loc)
end
in
underAbs f exp
@@ -99,9 +99,8 @@ fun addCacheFlush (exp, tablesToIndices) =
fun mapFfi func = List.map (fn i => ffiAppExp ("Cache", func, i, loc))
val flushes =
IS.listItems (SS.foldr addIndices IS.empty (#written (tablesInExp body)))
-
in
- sequence (mapFfi "flush" flushes, body, mapFfi "ready" flushes, loc)
+ sequence (mapFfi "flush" flushes @ [body] @ mapFfi "ready" flushes, loc)
end
in
underAbs f exp