From ed7b5e6f956c5b13735cc3e5c4de01fbfc437e12 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Sun, 15 Nov 2015 14:18:35 -0500 Subject: Fix bugs for lock calculation and SQL parsing and add support for tasks. --- caching-tests/test.urp | 2 +- src/lru_cache.sml | 12 ++--- src/sqlcache.sml | 126 +++++++++++++++++++++++++++++++------------------ 3 files changed, 87 insertions(+), 53 deletions(-) diff --git a/caching-tests/test.urp b/caching-tests/test.urp index cea8821e..dd8cf774 100644 --- a/caching-tests/test.urp +++ b/caching-tests/test.urp @@ -1,4 +1,4 @@ -database test.db +database host=localhost dbname=ziv sql test.sql safeGet Test/flush safeGet Test/flash diff --git a/src/lru_cache.sml b/src/lru_cache.sml index 0276de91..e9ed5f73 100644 --- a/src/lru_cache.sml +++ b/src/lru_cache.sml @@ -111,16 +111,16 @@ fun setupQuery {index, params} = (* If the output is null, it means we had too much recursion, so it's a miss. *) string " if (v && v->output != NULL) {", newline, - string (" puts(\"SQLCACHE: hit " ^ i ^ ".\");"), - newline, + (* string (" puts(\"SQLCACHE: hit " ^ i ^ ".\");"), *) + (* newline, *) string " uw_write(ctx, v->output);", newline, string " return v->result;", newline, string " } else {", newline, - string (" puts(\"SQLCACHE: miss " ^ i ^ ".\");"), - newline, + (* string (" puts(\"SQLCACHE: miss " ^ i ^ ".\");"), *) + (* newline, *) string " uw_recordingStart(ctx);", newline, string " return NULL;", @@ -142,8 +142,8 @@ fun setupQuery {index, params} = newline, string " v->output = uw_recordingRead(ctx);", newline, - string (" puts(\"SQLCACHE: stored " ^ i ^ ".\");"), - newline, + (* string (" puts(\"SQLCACHE: stored " ^ i ^ ".\");"), *) + (* newline, *) string (" uw_Sqlcache_store(ctx, cache" ^ i ^ ", ks, v);"), newline, string " return uw_unit_v;", diff --git a/src/sqlcache.sml b/src/sqlcache.sml index 6583dc91..481acbeb 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -1,4 +1,4 @@ -structure Sqlcache :> SQLCACHE = struct +structure Sqlcache (* DEBUG :> SQLCACHE *) = struct (*********************) @@ -312,7 +312,9 @@ fun removeRedundant madeRedundantBy zs = end datatype atomExp = - QueryArg of int + True + | False + | QueryArg of int | DmlRel of int | Prim of Prim.t | Field of string * string @@ -322,7 +324,13 @@ structure AtomExpKey : ORD_KEY = struct type ord_key = atomExp val compare = - fn (QueryArg n1, QueryArg n2) => Int.compare (n1, n2) + fn (True, True) => EQUAL + | (True, _) => LESS + | (_, True) => GREATER + | (False, False) => EQUAL + | (False, _) => LESS + | (_, False) => GREATER + | (QueryArg n1, QueryArg n2) => Int.compare (n1, n2) | (QueryArg _, _) => LESS | (_, QueryArg _) => GREATER | (DmlRel n1, DmlRel n2) => Int.compare (n1, n2) @@ -531,7 +539,7 @@ end = struct project from a sqlified value (which is a string). *) | (_, sq as SOME _, [], NONE) => wrap sq - | _ => raise Match + | _ => raise Fail "Sqlcache: traverseSubst" end) (f n) in @@ -620,7 +628,7 @@ end = struct AM.find (argsMap, arg) <\obind\> (fn n' => SOME (ERel n'))) - | _ => raise Match + | _ => raise Fail "Sqlcache: query (a)" in case (map #1 qs) of (q :: qs) => @@ -629,16 +637,16 @@ end = struct val ns = IS.listItems (varsOfQuery q) val rename = fn ERel n => omap ERel (indexOf (fn n' => n' = n) ns) - | _ => raise Match + | _ => raise Fail "Sqlcache: query (b)" in case omapQuery rename q of SOME q => q (* We should never get NONE because indexOf should never fail. *) - | NONE => raise Match + | NONE => raise Fail "Sqlcache: query (c)" end (* We should never reach this case because [updateState] won't put anything in the state if there are no queries. *) - | [] => raise Match + | [] => raise Fail "Sqlcache: query (d)" end val argOfExp = @@ -700,8 +708,23 @@ val rec sqexpToFormula = | Sql.Binop (Sql.RCmp c, e1, e2) => Atom (c, e1, e2) | Sql.Binop (Sql.RLop l, p1, p2) => Combo (case l of Sql.And => Conj | Sql.Or => Disj, [sqexpToFormula p1, sqexpToFormula p2]) + | e as Sql.Field f => Atom (Sql.Eq, e, Sql.SqTrue) (* ASK: any other sqexps that can be props? *) - | _ => raise Match + | Sql.SqConst prim => + (case prim of + (Prim.String (Prim.Normal, s)) => + if s = #trueString (Settings.currentDbms ()) + then Combo (Conj, []) + else if s = #falseString (Settings.currentDbms ()) + then Combo (Disj, []) + else raise Fail "Sqlcache: sqexpToFormula (SqConst a)" + | _ => raise Fail "Sqlcache: sqexpToFormula (SqConst b)") + | Sql.Computed _ => raise Fail "Sqlcache: sqexpToFormula (Computed)" + | Sql.SqKnown _ => raise Fail "Sqlcache: sqexpToFormula (SqKnown)" + | Sql.Inj _ => raise Fail "Sqlcache: sqexpToFormula (Inj)" + | Sql.SqFunc _ => raise Fail "Sqlcache: sqexpToFormula (SqFunc)" + | Sql.Unmodeled => raise Fail "Sqlcache: sqexpToFormula (Unmodeled)" + | Sql.Null => raise Fail "Sqlcache: sqexpToFormula (Null)" fun mapSqexpFields f = fn Sql.Field (t, v) => f (t, v) @@ -799,9 +822,6 @@ structure ConflictMaps = struct fun equivClasses atoms : atomExp list list option = let val uf = List.foldl UF.union' UF.empty (List.mapPartial toKnownEquality atoms) - val ineqs = List.filter (fn (cmp, _, _) => - cmp = Sql.Ne orelse cmp = Sql.Lt orelse cmp = Sql.Gt) - atoms val contradiction = fn (cmp, SOME ae1, SOME ae2) => (cmp = Sql.Ne orelse cmp = Sql.Lt orelse cmp = Sql.Gt) andalso UF.together (uf, ae1, ae2) @@ -928,7 +948,7 @@ val sequence = in List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps end - | _ => raise Match + | _ => raise Fail "Sqlcache: sequence" (* Always increments negative indices as a hack we use later. *) fun incRels inc = @@ -983,7 +1003,7 @@ fun fileAllMapfoldB doExp file start = bind = doBind} MonoEnv.empty file start of Search.Continue x => x - | Search.Return _ => raise Match + | Search.Return _ => raise Fail "Sqlcache: fileAllMapfoldB" fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ()) @@ -1029,7 +1049,7 @@ val simplifySql = val text = case exp' of EQuery {query = text, ...} => text | EDml (text, _) => text - | _ => raise Match + | _ => raise Fail "Sqlcache: simplifySql (a)" val (newText, wrapLets, numArgs) = factorOutNontrivial text val newExp' = case exp' of EQuery q => EQuery {query = newText, @@ -1039,7 +1059,7 @@ val simplifySql = body = #body q, initial = #initial q} | EDml (_, failureMode) => EDml (newText, failureMode) - | _ => raise Match + | _ => raise Fail "Sqlcache: simplifySql (b)" in (* Increment once for each new variable just made. This is where we use the negative De Bruijn indices hack. *) @@ -1128,7 +1148,7 @@ val runSubexp : subexp * state -> exp * state = val invalInfoOfSubexp = fn Cachable (invalInfo, _) => invalInfo - | Impure _ => raise Match + | Impure _ => raise Fail "Sqlcache: invalInfoOfSubexp" fun cacheWrap (env, exp, typ, args, index) = let @@ -1275,9 +1295,11 @@ fun cacheTree (effs : IS.set) ((env, exp as (exp', loc)), state) = | NONE => mapFst Impure (mkExp state) end fun wrapBind1 f arg = - wrapBindN (fn [arg] => f arg | _ => raise Match) [arg] + wrapBindN (fn [arg] => f arg + | _ => raise Fail "Sqlcache: cacheTree (a)") [arg] fun wrapBind2 f (arg1, arg2) = - wrapBindN (fn [arg1, arg2] => f (arg1, arg2) | _ => raise Match) [arg1, arg2] + wrapBindN (fn [arg1, arg2] => f (arg1, arg2) + | _ => raise Fail "Sqlcache: cacheTree (b)") [arg1, arg2] fun wrapN f es = wrapBindN f (map (fn e => ((env, e), Unknowns 0)) es) fun wrap1 f e = wrapBind1 f ((env, e), Unknowns 0) fun wrap2 f (e1, e2) = wrapBind2 f (((env, e1), Unknowns 0), ((env, e2), Unknowns 0)) @@ -1306,7 +1328,7 @@ fun cacheTree (effs : IS.set) ((env, exp as (exp', loc)), state) = ECase (e, (ListPair.map (fn (e, (p, _)) => (p, e)) (es, cases)), {disc = disc, result = result}) - | _ => raise Match) + | _ => raise Fail "Sqlcache: cacheTree (c)") (((env, e), Unknowns 0) :: map (fn (p, e) => ((MonoEnv.patBinds env p, e), Unknowns (MonoEnv.patBindsN p))) @@ -1362,7 +1384,7 @@ structure Invalidations = struct DmlRel n => ERel n | Prim p => EPrim p (* TODO: make new type containing only these two. *) - | _ => raise Match, + | _ => raise Fail "Sqlcache: optionAtomExpToExp", loc)), loc) @@ -1409,13 +1431,13 @@ fun addFlushing ((file, {tableToIndices, indexToInvalInfo, ffiInfo, ...} : state (i, invalidations (invalInfo, dmlParsed)) (* TODO: fail more gracefully. *) (* This probably means invalidating everything.... *) - | NONE => raise Match)) + | NONE => raise Fail "Sqlcache: addFlushing (a)")) (SIMM.findList (tableToIndices, tableOfDml dmlParsed))) | NONE => NONE in case inval of (* TODO: fail more gracefully. *) - NONE => raise Match + NONE => raise Fail "Sqlcache: addFlushing (b)" | SOME invs => sequence (flushes invs @ [dmlExp]) end | e' => e' @@ -1432,29 +1454,38 @@ fun addFlushing ((file, {tableToIndices, indexToInvalInfo, ffiInfo, ...} : state (***********) (* TODO: do this less evilly by not relying on specific FFI names, please? *) -fun locksNeeded file = +fun locksNeeded (lockMap : {store : IIMM.multimap, flush : IIMM.multimap}) = + MonoUtil.Exp.fold + {typ = #2, + exp = fn (EFfiApp ("Sqlcache", x, _), state as {store, flush}) => + (case Int.fromString (String.extract (x, 5, NONE)) of + NONE => state + | SOME index => + if String.isPrefix "flush" x + then {store = store, flush = IS.add (flush, index)} + else if String.isPrefix "store" x + then {store = IS.add (store, index), flush = flush} + else state) + | (ENamed n, {store, flush}) => + {store = IS.union (store, IIMM.findSet (#store lockMap, n)), + flush = IS.union (flush, IIMM.findSet (#flush lockMap, n))} + | (_, state) => state} + {store = IS.empty, flush = IS.empty} + +fun lockMapOfFile file = transitiveAnalysis (fn ((_, name, _, e, _), state) => - MonoUtil.Exp.fold - {typ = #2, - exp = fn (EFfiApp ("Sqlcache", x, _), state as {store, flush}) => - (case Int.fromString (String.extract (x, 5, NONE)) of - NONE => state - | SOME index => - if String.isPrefix "flush" x - then {store = store, flush = IIMM.insert (flush, name, index)} - else if String.isPrefix "store" x - then {store = IIMM.insert (store, name, index), flush = flush} - else state) - | (_, state) => state} - state - e) + let + val locks = locksNeeded state e + in + {store = IIMM.insertSet (#store state, name, #store locks), + flush = IIMM.insertSet (#flush state, name, #flush locks)} + end) {store = IIMM.empty, flush = IIMM.empty} file fun exports (decls, _) = List.foldl (fn ((DExport (_, _, n, _, _, _), _), ns) => IS.add (ns, n) - | ((DTask _, _), _) => raise Fail "Sqlcache doesn't yet support tasks." | (_, ns) => ns) IS.empty decls @@ -1466,24 +1497,27 @@ fun wrapLocks (locks, (exp', loc)) = fun addLocking file = let - val {store, flush} = locksNeeded file - fun locks n = + val lockMap = lockMapOfFile file + fun lockList {store, flush} = let - val wlocks = IIMM.findSet (flush, n) - val rlocks = IIMM.findSet (store, n) - val ls = map (fn i => (i, true)) (IS.listItems wlocks) - @ map (fn i => (i, false)) (IS.listItems (IS.difference (rlocks, wlocks))) + val ls = map (fn i => (i, true)) (IS.listItems flush) + @ map (fn i => (i, false)) (IS.listItems (IS.difference (store, flush))) in ListMergeSort.sort (fn ((i, _), (j, _)) => i > j) ls end + fun locksOfName n = + lockList {store = IIMM.findSet (#flush lockMap, n), + flush =IIMM.findSet (#store lockMap, n)} + val locksOfExp = lockList o locksNeeded lockMap val expts = exports file fun doVal (v as (x, n, t, exp, s)) = if IS.member (expts, n) - then (x, n, t, wrapLocks ((locks n), exp), s) + then (x, n, t, wrapLocks ((locksOfName n), exp), s) else v val doDecl = fn (DVal v, loc) => (DVal (doVal v), loc) | (DValRec vs, loc) => (DValRec (map doVal vs), loc) + | (DTask (exp1, exp2), loc) => (DTask (exp1, wrapLocks (locksOfExp exp2, exp2)), loc) | decl => decl in mapFst (map doDecl) file -- cgit v1.2.3