Ur/Web: src/sqlcache.sml comparison

comparison src/sqlcache.sml @ 2237:e79ef5792c8b

Fix bug in redundancy checking and use finer formula for UPDATE statements.

author	Ziv Scully <ziv@mit.edu>
date	Sun, 05 Jul 2015 23:57:28 -0700
parents	fab8c1f131a5
children	f70a91f7810d

comparison

equal deleted inserted replaced

-:fab8c1f131a5
+:e79ef5792c8b
 | _ => f :: acc)
 []
 (map flatten fs))
 | f => f
-fun normPlz (junc : junctionType) =
+fun normalize' (simplify : 'a list list -> 'a list list)
-fn Atom x => [[x]]
+(negate : 'a -> 'a)
-| Combo (j, fs) =>
-let
-val fss = map (normPlz junc) fs
-in
-if j = junc
-then List.concat fss
-else map List.concat (cartesianProduct fss)
-end
-(* Excluded by pushNegate. *)
-| Negate _ => raise Match
-fun normalize' ((simplifyLists, simplifyAtoms, negate)
-: ('a list list -> 'a list list)
-* ('a list -> 'a list)
-* ('a -> 'a))
 (junc : junctionType) =
 let
-fun simplify junc = simplifyLists o map simplifyAtoms
 fun norm junc =
-simplify junc
+simplify
 o (fn Atom x => [[x]]
 | Negate f => map (map negate) (norm (flipJt junc) f)
 | Combo (j, fs) =>
 let
 val fss = map (norm junc) fs
 end)
 in
 norm junc
 end
-fun normalize (simplifyLists, simplifyAtoms, negate, junc) =
+fun normalize simplify negate junc =
-(normalize' (simplifyLists, simplifyAtoms, negate) junc)
+normalize' simplify negate junc
 o flatten
 o pushNegate negate false
 fun mapFormula mf =
 fn Atom x => Atom (mf x)
 | (_, Sql.Gt) => GREATER
 | (Sql.Ge, Sql.Ge) => EQUAL
 end
+(*
 functor ListKeyFn (K : ORD_KEY) : ORD_KEY = struct
 type ord_key = K.ord_key list
 val rec compare =
 | (x :: xs, y :: ys) => (case K.compare (x, y) of
 EQUAL => compare (xs, ys)
 | ord => ord)
 end
+*)
 functor OptionKeyFn (K : ORD_KEY) : ORD_KEY = struct
 type ord_key = K.ord_key option
 end
 val rec chooseTwos : 'a list -> ('a * 'a) list =
 fn [] => []
 | x :: ys => map (fn y => (x, y)) ys @ chooseTwos ys
+fun removeRedundant madeRedundantBy zs =
+let
+fun removeRedundant' (xs, ys) =
+case xs of
+[] => ys
+| x :: xs' =>
+removeRedundant' (xs',
+if List.exists (fn y => madeRedundantBy (x, y)) (xs' @ ys)
+then ys
+else x :: ys)
+in
+removeRedundant' (zs, [])
+end
 datatype atomExp =
 QueryArg of int
 | DmlRel of int
 | Prim of Prim.t
 structure TK = TripleKeyFn(structure I = CmpKey
 structure J = OptionKeyFn(AtomExpKey)
 structure K = OptionKeyFn(AtomExpKey))
 structure TS = BinarySetFn(TK)
-structure TLS = BinarySetFn(ListKeyFn(TK))
+(* structure TLS = BinarySetFn(ListKeyFn(TK)) *)
 val toKnownEquality =
 (* [NONE] here means unkown. Anything that isn't a comparison between two
 knowns shouldn't be used, and simply dropping unused terms is okay in
 disjunctive normal form. *)
 | ((Prim p, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, Prim p))
 | ((DmlRel r, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r))
 (* TODO: deal with equalities between [DmlRel]s and [Prim]s.
 This would involve guarding the invalidation with a check for the
 relevant comparisons. *)
-(* DEBUG: remove these print statements. *)
-(* | ((DmlRel r, Prim p), eqso) => (print ("sadness " ^ Int.toString r ^ " = " ^ Prim.toString p ^ "\n"); eqso) *)
-(* | ((Prim p, DmlRel r), eqso) => (print ("sadness " ^ Int.toString r ^ " = " ^ Prim.toString p ^ "\n"); eqso) *)
 | (_, eqso) => eqso
 val eqsOfClass : atomExp list -> atomExp IM.map option =
 List.foldl accumulateEqs (SOME IM.empty)
 o chooseTwos
 List.foldr (fn (SOME eqs, SOME acc) => SOME (IM.unionWith #1 (eqs, acc)) | _ => NONE)
 (SOME IM.empty)
 fun dnf (fQuery, fDml) =
 let
-val isStar =
+val simplify =
-(* TODO: decide if this is okay and, if so, factor out magic
+map TS.listItems
-string "*" to a common location. *)
+o removeRedundant (fn (x, y) => TS.isSubset (y, x))
-(* First guess: definitely okay for conservative approximation,
+o map (fn xs => TS.addList (TS.empty, xs))
-though information lost might be useful even in current
-implementation for finding an extra equality. *)
-fn SOME (Field (_, field)) => String.isSuffix "*" field
-| _ => false
-fun canIgnore (_, a1, a2) = isStar a1 orelse isStar a2
-fun simplifyLists xs = TLS.listItems (TLS.addList (TLS.empty, xs))
-fun simplifyAtoms xs = TS.listItems (TS.addList (TS.empty, xs))
 in
-normalize (simplifyLists, simplifyAtoms, negateCmp, Disj)
+normalize simplify negateCmp Disj (Combo (Conj, [markQuery fQuery, markDml fDml]))
-(Combo (Conj, [markQuery fQuery, markDml fDml]))
 end
 val conflictMaps = List.mapPartial (mergeEqs o map eqsOfClass o equivClasses) o dnf
 end
 | Sql.Delete (table, wher) => renameTables [(table, "T")] (sqexpToFormula wher)
 | Sql.Update (table, vals, wher) =>
 let
 val fWhere = sqexpToFormula wher
 val fVals = valsToFormula (table, vals)
+val modifiedFields = SS.addList (SS.empty, map #1 vals)
 (* TODO: don't use field name hack. *)
 val markField =
-fn Sql.Field (t, v) => Sql.Field (t, v ^ "*")
+fn e as Sql.Field (t, v) => if SS.member (modifiedFields, v)
+then Sql.Field (t, v ^ "'")
+else e
 | e => e
 val mark = mapFormula (fn (cmp, e1, e2) => (cmp, markField e1, markField e2))
 in
 renameTables [(table, "T")]
 (Combo (Disj, [Combo (Conj, [fVals, mark fWhere]),
 (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here
 represents unknown, which means a wider invalidation. *)
 val rec madeRedundantBy : atomExp option list * atomExp option list -> bool =
 fn ([], []) => true
-| (NONE :: xs, _ :: ys) => madeRedundantBy (xs, ys)
+| (_ :: xs, NONE :: ys) => madeRedundantBy (xs, ys)
 | (SOME x :: xs, SOME y :: ys) => (case AtomExpKey.compare (x, y) of
 EQUAL => madeRedundantBy (xs, ys)
 | _ => false)
 | _ => false
-fun removeRedundant' (xss, yss) =
-case xss of
-[] => yss
-| xs :: xss' =>
-removeRedundant' (xss',
-if List.exists (fn ys => madeRedundantBy (xs, ys)) (xss' @ yss)
-then yss
-else xs :: yss)
-fun removeRedundant xss = removeRedundant' (xss, [])
 fun eqss (query, dml) = conflictMaps (queryToFormula query, dmlToFormula dml)
 fun invalidations ((query, numArgs), dml) =
 (map (map optionAtomExpToExp)
-o removeRedundant
+o removeRedundant madeRedundantBy
 o map (eqsToInvalidation numArgs)
 o eqss)
 (query, dml)
 end

Mercurial > urweb

comparison src/sqlcache.sml @ 2237:e79ef5792c8b