aboutsummaryrefslogtreecommitdiffhomepage
path: root/src/filecache.sml
diff options
context:
space:
mode:
Diffstat (limited to 'src/filecache.sml')
-rw-r--r--src/filecache.sml230
1 files changed, 230 insertions, 0 deletions
diff --git a/src/filecache.sml b/src/filecache.sml
new file mode 100644
index 00000000..e2291c10
--- /dev/null
+++ b/src/filecache.sml
@@ -0,0 +1,230 @@
+(* Copyright (c) 2013, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ * derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+structure FileCache :> FILE_CACHE = struct
+
+open Mono
+
+structure SS = BinarySetFn(struct
+ type ord_key = string
+ val compare = String.compare
+ end)
+
+val hasBlob =
+ MonoUtil.Typ.exists (fn TFfi ("Basis", "blob") => true
+ | _ => false)
+
+val unBlob =
+ MonoUtil.Typ.map (fn TFfi ("Basis", "blob") => TFfi ("Basis", "string")
+ | t => t)
+
+fun nodups (exps : (string * typ) list, tables : (string * (string * typ) list) list) =
+ let
+ val cols = map #1 exps @ ListUtil.mapConcat (map #1 o #2) tables
+
+ val (_, good) =
+ foldl (fn (name, (names, good)) =>
+ if SS.member(names, name) then
+ (names, false)
+ else
+ (SS.add (names, name), good)) (SS.empty, true) cols
+ in
+ good
+ end
+
+fun instrument file =
+ let
+ fun exp e =
+ case e of
+ EQuery {exps, tables, state, query, body, initial} =>
+ if (List.exists (hasBlob o #2) exps
+ orelse List.exists (List.exists (hasBlob o #2) o #2) tables)
+ andalso nodups (exps, tables) then
+ let
+ val exps = ListMergeSort.sort
+ (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER)
+ exps
+ val tables = ListMergeSort.sort
+ (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER)
+ tables
+ val tables = map (fn (x, xts) =>
+ (x, ListMergeSort.sort
+ (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER)
+ xts)) tables
+
+ val loc = #2 query
+
+ fun wrapCol (name, t) =
+ case #1 t of
+ TFfi ("Basis", "blob") =>
+ "DIGEST(" ^ name ^ ", 'sha512')"
+ | TOption t' => wrapCol (name, t')
+ | _ => name
+
+ val mangle = Settings.mangleSql
+
+ val cols = map (fn (name, t) => (mangle name, t)) exps
+ @ ListUtil.mapConcat (fn (_, cols) =>
+ map (fn (name, t) =>
+ (mangle name,
+ t)) cols) tables
+
+ val prequery =
+ "SELECT "
+ ^ String.concatWith ", " (map wrapCol cols)
+ ^ " FROM ("
+
+ val postquery =
+ ") AS Wrap"
+
+ val wrapped_query =
+ (EStrcat ((EPrim (Prim.String (Prim.Normal, prequery)), loc),
+ (EStrcat (query,
+ (EPrim (Prim.String (Prim.Normal, postquery)), loc)), loc)), loc)
+ val wrapped_query = MonoOpt.optExp wrapped_query
+
+ val exps' = map (fn (name, t) => (name, unBlob t)) exps
+ val tables' = map (fn (name, cols) =>
+ (name,
+ map (fn (cname, t) => (cname, unBlob t)) cols)) tables
+
+ val blob = (TFfi ("Basis", "blob"), loc)
+ val string = (TFfi ("Basis", "string"), loc)
+
+ fun trycache (name, e, t : typ) =
+ (name,
+ case #1 t of
+ TFfi ("Basis", "blob") =>
+ (EFfiApp ("Basis",
+ "check_filecache",
+ [(e, string)]), loc)
+ | TOption (TFfi ("Basis", "blob"), _) =>
+ (ECase (e,
+ [((PNone string, loc),
+ (ENone blob, loc)),
+ ((PSome (string, (PVar ("hash", string), loc)), loc),
+ (ESome (blob,
+ (EFfiApp ("Basis",
+ "check_filecache",
+ [((ERel 0, loc), string)]), loc)), loc))],
+ {disc = (TOption string, loc),
+ result = (TOption blob, loc)}), loc)
+ | _ => e,
+ t)
+
+ val wrapped_body_trycache =
+ (ELet ("uncached",
+ (TRecord (exps @ map (fn (name, cols) =>
+ (name, (TRecord cols, loc))) tables),
+ loc),
+ (ERecord (map (fn (name, t) =>
+ trycache (name,
+ (EField ((ERel 1, loc),
+ name), loc),
+ t)) exps
+ @ map (fn (tname, cols) =>
+ (tname,
+ (ERecord (map (fn (name, t) =>
+ trycache (name,
+ (EField ((EField ((ERel 1, loc), tname), loc), name), loc),
+ t)) cols), loc),
+ (TRecord cols, loc))) tables), loc),
+ MonoEnv.subExpInExp (2, (ERel 0, loc))
+
+
+ (MonoEnv.liftExpInExp 0 body)), loc)
+
+ fun maybeadd (e, t, acc) =
+ case #1 t of
+ TFfi ("Basis", "blob") =>
+ (ESeq ((EFfiApp ("Basis",
+ "cache_file",
+ [(e, blob)]), loc),
+ acc), loc)
+ | TOption (TFfi ("Basis", "blob"), _) =>
+ (ESeq ((ECase (e,
+ [((PNone blob, loc),
+ (ERecord [], loc)),
+ ((PSome (blob, (PVar ("blob", blob), loc)), loc),
+ (EFfiApp ("Basis",
+ "cache_file",
+ [((ERel 0, loc), blob)]), loc))],
+ {disc = t,
+ result = (TRecord [], loc)}), loc),
+ acc), loc)
+ | _ => acc
+
+ val wrapped_body_addtocache =
+ foldl (fn ((name, t), e) =>
+ maybeadd ((EField ((ERel 1, loc), name), loc),
+ t, e))
+ (foldl (fn ((tname, cols), e) =>
+ foldl (fn ((name, t), e) =>
+ maybeadd ((EField ((EField ((ERel 1, loc), tname), loc), name), loc),
+ t, e)) e cols) body tables)
+ exps
+ in
+ ECase ((EFfiApp ("Basis", "filecache_missed", []), loc),
+ [((PCon (Enum,
+ PConFfi {mod = "Basis",
+ datatyp = "bool",
+ con = "False",
+ arg = NONE},
+ NONE), loc),
+ (EQuery {exps = exps',
+ tables = tables',
+ state = state,
+ query = wrapped_query,
+ body = wrapped_body_trycache,
+ initial = initial}, loc)),
+ ((PCon (Enum,
+ PConFfi {mod = "Basis",
+ datatyp = "bool",
+ con = "True",
+ arg = NONE},
+ NONE), loc),
+ (EQuery {exps = exps,
+ tables = tables,
+ state = state,
+ query = query,
+ body = wrapped_body_addtocache,
+ initial = initial}, loc))],
+ {disc = (TFfi ("Basis", "bool"), loc),
+ result = state})
+ end
+ else
+ e
+ | _ => e
+ in
+ case Settings.getFileCache () of
+ NONE => file
+ | SOME _ => MonoUtil.File.map {typ = fn t => t,
+ exp = exp,
+ decl = fn d => d} file
+ end
+
+end
generated by cgit v1.2.3 (git 2.39.1) at 2024-04-29 19:50:50 +0000