diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/cjr_print.sml | 14 | ||||
| -rw-r--r-- | src/sql.sig | 6 | ||||
| -rw-r--r-- | src/sqlcache.sml | 67 |
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 |