Mercurial > urweb
changeset 2289:78820fa8f5a7
Fix bugs for lock calculation and SQL parsing and add support for tasks.
| author | Ziv Scully <ziv@mit.edu> |
|---|---|
| date | Sun, 15 Nov 2015 14:18:35 -0500 |
| parents | 98f96a976ede |
| children | ab6ca12debeb |
| files | caching-tests/test.urp src/lru_cache.sml src/sqlcache.sml |
| diffstat | 3 files changed, 87 insertions(+), 53 deletions(-) [+] |
line wrap: on
line diff
--- a/caching-tests/test.urp Fri Nov 13 11:03:09 2015 -0500 +++ b/caching-tests/test.urp Sun Nov 15 14:18:35 2015 -0500 @@ -1,4 +1,4 @@ -database test.db +database host=localhost dbname=ziv sql test.sql safeGet Test/flush safeGet Test/flash
--- a/src/lru_cache.sml Fri Nov 13 11:03:09 2015 -0500 +++ b/src/lru_cache.sml Sun Nov 15 14:18:35 2015 -0500 @@ -111,16 +111,16 @@ (* 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 @@ 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;",
--- a/src/sqlcache.sml Fri Nov 13 11:03:09 2015 -0500 +++ b/src/sqlcache.sml Sun Nov 15 14:18:35 2015 -0500 @@ -1,4 +1,4 @@ -structure Sqlcache :> SQLCACHE = struct +structure Sqlcache (* DEBUG :> SQLCACHE *) = struct (*********************) @@ -312,7 +312,9 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ | 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 @@ 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 @@ 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 @@ 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 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 @@ 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 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 @@ | 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 @@ 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 @@ 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 @@ (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 @@ (***********) (* 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 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