Ur/Web: src/sqlcache.sml comparison

comparison src/sqlcache.sml @ 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	50ad02829abd

comparison

equal deleted inserted replaced

-:98f96a976ede
+:78820fa8f5a7
-structure Sqlcache :> SQLCACHE = struct
+structure Sqlcache (* DEBUG :> SQLCACHE *) = struct
 (*********************)
 (* General Utilities *)
 (*********************)
 in
 removeRedundant' (zs, [])
 end
 datatype atomExp =
-QueryArg of int
+True
+| False
+| QueryArg of int
 | DmlRel of int
 | Prim of Prim.t
 | Field of string * string
 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)
 | (DmlRel _, _) => LESS
 | (_, DmlRel _) => GREATER
 | (_, NONE, _, sq as SOME _) => wrap sq
 (* Last case should suffice because we don't
 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
 traverseIM ops (fn (_, v) => mp v)
 end
 <\obind\>
 (fn arg =>
 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) =>
 let
 val q = List.foldl Sql.Union q qs
 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 =
 let
 fun doFields acc exp =
 | Sql.SqFalse => Combo (Disj, [])
 | Sql.SqNot e => Negate (sqexpToFormula e)
 | 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)
 | Sql.SqNot e => Sql.SqNot (mapSqexpFields f e)
 | Sql.Binop (r, e1, e2) => Sql.Binop (r, mapSqexpFields f e1, mapSqexpFields f e2)
 | _ => NONE
 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)
 (* If we don't know one side of the comparision, not a contradiction. *)
 | _ => false
 let
 val loc = dummyLoc
 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 =
 MonoUtil.Exp.mapB
 {typ = fn t' => t',
 exp = fn env => fn e' => fn s => Search.Continue (doExp env e' s),
 decl = fn _ => Search.return2,
 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 ())
 (* TODO: make this a bit prettier.... *)
 val simplifySql =
 fun doExp exp' =
 let
 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,
 exps = #exps q,
 tables = #tables q,
 state = #state q,
 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. *)
 (* TODO: please don't use that hack. As anyone could have
 predicted, it was incomprehensible a year later.... *)
 fn (Cachable (_, f), state) => f state
 | (Impure e, state) => (e, state)
 val invalInfoOfSubexp =
 fn Cachable (invalInfo, _) => invalInfo
-| Impure _ => raise Match
+| Impure _ => raise Fail "Sqlcache: invalInfoOfSubexp"
 fun cacheWrap (env, exp, typ, args, index) =
 let
 val loc = dummyLoc
 val rel0 = (ERel 0, loc)
 case attempt of
 SOME (subexp, state) => (subexp, 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))
 in
 case exp' of
 | ECase (e, cases, {disc, result}) =>
 wrapBindN (fn (e::es) =>
 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)))
 cases)
 | EStrcat (e1, e2) => wrap2 EStrcat (e1, e2)
 | SOME e => (ESome (stringTyp,
 (case e of
 DmlRel n => ERel n
 | Prim p => EPrim p
 (* TODO: make new type containing only these two. *)
-| _ => raise Match,
+| _ => raise Fail "Sqlcache: optionAtomExpToExp",
 loc)),
 loc)
 fun eqsToInvalidation numArgs eqs =
 List.tabulate (numArgs, (fn n => IM.find (eqs, n)))
 SOME (map (fn i => (case IM.find (indexToInvalInfo, i) of
 SOME invalInfo =>
 (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'
 val file = fileMap doExp file
 (***********)
 (* Locking *)
 (***********)
 (* 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
+let
-{typ = #2,
+val locks = locksNeeded state e
-exp = fn (EFfiApp ("Sqlcache", x, _), state as {store, flush}) =>
+in
-(case Int.fromString (String.extract (x, 5, NONE)) of
+{store = IIMM.insertSet (#store state, name, #store locks),
-NONE => state
+flush = IIMM.insertSet (#flush state, name, #flush locks)}
-| SOME index =>
+end)
-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)
 {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
 fun wrapLocks (locks, (exp', loc)) =
 EAbs (s, t1, t2, exp) => (EAbs (s, t1, t2, wrapLocks (locks, exp)), loc)
 | _ => (List.foldr (fn (l, e') => sequence [lock l, e']) exp' locks, loc)
 fun addLocking file =
 let
-val {store, flush} = locksNeeded file
+val lockMap = lockMapOfFile file
-fun locks n =
+fun lockList {store, flush} =
 let
-val wlocks = IIMM.findSet (flush, n)
+val ls = map (fn i => (i, true)) (IS.listItems flush)
-val rlocks = IIMM.findSet (store, n)
+@ map (fn i => (i, false)) (IS.listItems (IS.difference (store, flush)))
-val ls = map (fn i => (i, true)) (IS.listItems wlocks)
-@ map (fn i => (i, false)) (IS.listItems (IS.difference (rlocks, wlocks)))
 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
 end

Mercurial > urweb

comparison src/sqlcache.sml @ 2289:78820fa8f5a7