Mercurial > urweb

annotate src/sqlcache.sml @ 2234:2f7ed04332a0

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Progress on LRU cache but still more known bugs to fix.
author Ziv Scully <ziv@mit.edu>
date Sun, 28 Jun 2015 12:46:51 -0700
parents af1585e7d645
children 0aae15c2a05a
rev   line source
ziv@2233 1 structure Sqlcache :> SQLCACHE = struct
ziv@2209 2
ziv@2209 3 open Mono
ziv@2209 4
ziv@2209 5 structure IS = IntBinarySet
ziv@2209 6 structure IM = IntBinaryMap
ziv@2213 7 structure SK = struct type ord_key = string val compare = String.compare end
ziv@2213 8 structure SS = BinarySetFn(SK)
ziv@2213 9 structure SM = BinaryMapFn(SK)
ziv@2213 10 structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS)
ziv@2209 11
ziv@2216 12 (* Filled in by [cacheWrap] during [Sqlcache]. *)
ziv@2213 13 val ffiInfo : {index : int, params : int} list ref = ref []
ziv@2209 14
ziv@2227 15 fun resetFfiInfo () = ffiInfo := []
ziv@2227 16
ziv@2213 17 fun getFfiInfo () = !ffiInfo
ziv@2213 18
ziv@2215 19 (* Some FFIs have writing as their only effect, which the caching records. *)
ziv@2215 20 val ffiEffectful =
ziv@2223 21 (* ASK: how can this be less hard-coded? *)
ziv@2215 22 let
ziv@2215 23 val fs = SS.fromList ["htmlifyInt_w",
ziv@2215 24 "htmlifyFloat_w",
ziv@2215 25 "htmlifyString_w",
ziv@2215 26 "htmlifyBool_w",
ziv@2215 27 "htmlifyTime_w",
ziv@2215 28 "attrifyInt_w",
ziv@2215 29 "attrifyFloat_w",
ziv@2215 30 "attrifyString_w",
ziv@2215 31 "attrifyChar_w",
ziv@2215 32 "urlifyInt_w",
ziv@2215 33 "urlifyFloat_w",
ziv@2215 34 "urlifyString_w",
ziv@2215 35 "urlifyBool_w",
ziv@2215 36 "urlifyChannel_w"]
ziv@2215 37 in
ziv@2215 38 fn (m, f) => Settings.isEffectful (m, f)
ziv@2215 39 andalso not (m = "Basis" andalso SS.member (fs, f))
ziv@2215 40 end
ziv@2215 41
ziv@2234 42 val cache = ref LruCache.cache
ziv@2233 43 fun setCache c = cache := c
ziv@2233 44 fun getCache () = !cache
ziv@2233 45
ziv@2215 46
ziv@2215 47 (* Effect analysis. *)
ziv@2215 48
ziv@2216 49 (* Makes an exception for [EWrite] (which is recorded when caching). *)
ziv@2230 50 fun effectful doPrint (effs : IS.set) (inFunction : bool) (bound : int) : exp -> bool =
ziv@2215 51 (* If result is true, expression is definitely effectful. If result is
ziv@2215 52 false, then expression is definitely not effectful if effs is fully
ziv@2215 53 populated. The intended pattern is to use this a number of times equal
ziv@2215 54 to the number of declarations in a file, Bellman-Ford style. *)
ziv@2234 55 (* TODO: make incrementing of the number of bound variables cleaner,
ziv@2234 56 probably by using [MonoUtil] instead of all this. *)
ziv@2215 57 let
ziv@2215 58 (* DEBUG: remove printing when done. *)
ziv@2215 59 fun tru msg = if doPrint then (print (msg ^ "\n"); true) else true
ziv@2215 60 val rec eff' =
ziv@2215 61 (* ASK: is there a better way? *)
ziv@2215 62 fn EPrim _ => false
ziv@2215 63 (* We don't know if local functions have effects when applied. *)
ziv@2215 64 | ERel idx => if inFunction andalso idx >= bound
ziv@2215 65 then tru ("rel" ^ Int.toString idx) else false
ziv@2215 66 | ENamed name => if IS.member (effs, name) then tru "named" else false
ziv@2215 67 | ECon (_, _, NONE) => false
ziv@2215 68 | ECon (_, _, SOME e) => eff e
ziv@2215 69 | ENone _ => false
ziv@2215 70 | ESome (_, e) => eff e
ziv@2215 71 | EFfi (m, f) => if ffiEffectful (m, f) then tru "ffi" else false
ziv@2215 72 | EFfiApp (m, f, _) => if ffiEffectful (m, f) then tru "ffiapp" else false
ziv@2215 73 (* ASK: we're calling functions effectful if they have effects when
ziv@2215 74 applied or if the function expressions themselves have effects.
ziv@2215 75 Is that okay? *)
ziv@2215 76 (* This is okay because the values we ultimately care about aren't
ziv@2215 77 functions, and this is a conservative approximation, anyway. *)
ziv@2215 78 | EApp (eFun, eArg) => effectful doPrint effs true bound eFun orelse eff eArg
ziv@2215 79 | EAbs (_, _, _, e) => effectful doPrint effs inFunction (bound+1) e
ziv@2215 80 | EUnop (_, e) => eff e
ziv@2215 81 | EBinop (_, _, e1, e2) => eff e1 orelse eff e2
ziv@2215 82 | ERecord xs => List.exists (fn (_, e, _) => eff e) xs
ziv@2215 83 | EField (e, _) => eff e
ziv@2215 84 (* If any case could be effectful, consider it effectful. *)
ziv@2215 85 | ECase (e, xs, _) => eff e orelse List.exists (fn (_, e) => eff e) xs
ziv@2215 86 | EStrcat (e1, e2) => eff e1 orelse eff e2
ziv@2215 87 (* ASK: how should we treat these three? *)
ziv@2215 88 | EError _ => tru "error"
ziv@2215 89 | EReturnBlob _ => tru "blob"
ziv@2215 90 | ERedirect _ => tru "redirect"
ziv@2215 91 (* EWrite is a special exception because we record writes when caching. *)
ziv@2215 92 | EWrite _ => false
ziv@2215 93 | ESeq (e1, e2) => eff e1 orelse eff e2
ziv@2215 94 (* TODO: keep context of which local variables aren't effectful? Only
ziv@2215 95 makes a difference for function expressions, though. *)
ziv@2215 96 | ELet (_, _, eBind, eBody) => eff eBind orelse
ziv@2215 97 effectful doPrint effs inFunction (bound+1) eBody
ziv@2215 98 | EClosure (_, es) => List.exists eff es
ziv@2215 99 (* TODO: deal with EQuery. *)
ziv@2215 100 | EQuery _ => tru "query"
ziv@2215 101 | EDml _ => tru "dml"
ziv@2215 102 | ENextval _ => tru "nextval"
ziv@2215 103 | ESetval _ => tru "setval"
ziv@2215 104 | EUnurlify (e, _, _) => eff e
ziv@2215 105 (* ASK: how should we treat this? *)
ziv@2215 106 | EJavaScript _ => tru "javascript"
ziv@2215 107 (* ASK: these are all effectful, right? *)
ziv@2215 108 | ESignalReturn _ => tru "signalreturn"
ziv@2215 109 | ESignalBind _ => tru "signalbind"
ziv@2215 110 | ESignalSource _ => tru "signalsource"
ziv@2215 111 | EServerCall _ => tru "servercall"
ziv@2215 112 | ERecv _ => tru "recv"
ziv@2215 113 | ESleep _ => tru "sleep"
ziv@2215 114 | ESpawn _ => tru "spawn"
ziv@2215 115 and eff = fn (e', _) => eff' e'
ziv@2215 116 in
ziv@2215 117 eff
ziv@2215 118 end
ziv@2215 119
ziv@2215 120 (* TODO: test this. *)
ziv@2215 121 val effectfulMap =
ziv@2215 122 let
ziv@2215 123 fun doVal ((_, name, _, e, _), effMap) =
ziv@2215 124 if effectful false effMap false 0 e
ziv@2215 125 then IS.add (effMap, name)
ziv@2215 126 else effMap
ziv@2215 127 val doDecl =
ziv@2215 128 fn (DVal v, effMap) => doVal (v, effMap)
ziv@2215 129 (* Repeat the list of declarations a number of times equal to its size. *)
ziv@2215 130 | (DValRec vs, effMap) =>
ziv@2215 131 List.foldl doVal effMap (List.concat (List.map (fn _ => vs) vs))
ziv@2215 132 (* ASK: any other cases? *)
ziv@2215 133 | (_, effMap) => effMap
ziv@2215 134 in
ziv@2215 135 MonoUtil.File.fold {typ = #2, exp = #2, decl = doDecl} IS.empty
ziv@2215 136 end
ziv@2215 137
ziv@2215 138
ziv@2216 139 (* Boolean formula normalization. *)
ziv@2216 140
ziv@2234 141 datatype junctionType = Conj | Disj
ziv@2216 142
ziv@2216 143 datatype 'atom formula =
ziv@2216 144 Atom of 'atom
ziv@2216 145 | Negate of 'atom formula
ziv@2234 146 | Combo of junctionType * 'atom formula list
ziv@2216 147
ziv@2234 148 val flipJt = fn Conj => Disj | Disj => Conj
ziv@2216 149
ziv@2216 150 fun bind xs f = List.concat (map f xs)
ziv@2216 151
ziv@2216 152 val rec cartesianProduct : 'a list list -> 'a list list =
ziv@2216 153 fn [] => [[]]
ziv@2216 154 | (xs :: xss) => bind (cartesianProduct xss)
ziv@2216 155 (fn ys => bind xs (fn x => [x :: ys]))
ziv@2216 156
ziv@2218 157 (* Pushes all negation to the atoms.*)
ziv@2218 158 fun pushNegate (negate : 'atom -> 'atom) (negating : bool) =
ziv@2218 159 fn Atom x => Atom (if negating then negate x else x)
ziv@2218 160 | Negate f => pushNegate negate (not negating) f
ziv@2234 161 | Combo (n, fs) => Combo (if negating then flipJt n else n, map (pushNegate negate negating) fs)
ziv@2218 162
ziv@2218 163 val rec flatten =
ziv@2218 164 fn Combo (n, fs) =>
ziv@2218 165 Combo (n, List.foldr (fn (f, acc) =>
ziv@2218 166 case f of
ziv@2218 167 Combo (n', fs') => if n = n' then fs' @ acc else f :: acc
ziv@2218 168 | _ => f :: acc)
ziv@2218 169 []
ziv@2218 170 (map flatten fs))
ziv@2218 171 | f => f
ziv@2218 172
ziv@2234 173 fun normalize' (negate : 'atom -> 'atom) (junc : junctionType) =
ziv@2216 174 fn Atom x => [[x]]
ziv@2234 175 | Negate f => map (map negate) (normalize' negate (flipJt junc) f)
ziv@2234 176 | Combo (j, fs) =>
ziv@2216 177 let
ziv@2234 178 val fss = bind fs (normalize' negate j)
ziv@2216 179 in
ziv@2234 180 if j = junc then fss else cartesianProduct fss
ziv@2216 181 end
ziv@2216 182
ziv@2234 183 fun normalize negate junc = normalize' negate junc o flatten o pushNegate negate false
ziv@2216 184
ziv@2221 185 fun mapFormula mf =
ziv@2221 186 fn Atom x => Atom (mf x)
ziv@2221 187 | Negate f => Negate (mapFormula mf f)
ziv@2221 188 | Combo (n, fs) => Combo (n, map (mapFormula mf) fs)
ziv@2216 189
ziv@2230 190
ziv@2215 191 (* SQL analysis. *)
ziv@2213 192
ziv@2216 193 val rec chooseTwos : 'a list -> ('a * 'a) list =
ziv@2216 194 fn [] => []
ziv@2216 195 | x :: ys => map (fn y => (x, y)) ys @ chooseTwos ys
ziv@2213 196
ziv@2216 197 datatype atomExp =
ziv@2216 198 QueryArg of int
ziv@2216 199 | DmlRel of int
ziv@2216 200 | Prim of Prim.t
ziv@2216 201 | Field of string * string
ziv@2216 202
ziv@2216 203 structure AtomExpKey : ORD_KEY = struct
ziv@2216 204
ziv@2234 205 type ord_key = atomExp
ziv@2216 206
ziv@2234 207 val compare =
ziv@2234 208 fn (QueryArg n1, QueryArg n2) => Int.compare (n1, n2)
ziv@2234 209 | (QueryArg _, _) => LESS
ziv@2234 210 | (_, QueryArg _) => GREATER
ziv@2234 211 | (DmlRel n1, DmlRel n2) => Int.compare (n1, n2)
ziv@2234 212 | (DmlRel _, _) => LESS
ziv@2234 213 | (_, DmlRel _) => GREATER
ziv@2234 214 | (Prim p1, Prim p2) => Prim.compare (p1, p2)
ziv@2234 215 | (Prim _, _) => LESS
ziv@2234 216 | (_, Prim _) => GREATER
ziv@2234 217 | (Field (t1, f1), Field (t2, f2)) =>
ziv@2234 218 case String.compare (t1, t2) of
ziv@2234 219 EQUAL => String.compare (f1, f2)
ziv@2234 220 | ord => ord
ziv@2216 221
ziv@2216 222 end
ziv@2216 223
ziv@2216 224 structure UF = UnionFindFn(AtomExpKey)
ziv@2234 225
ziv@2221 226 val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula
ziv@2221 227 * (Sql.cmp * Sql.sqexp * Sql.sqexp) formula
ziv@2221 228 -> atomExp IM.map list =
ziv@2221 229 let
ziv@2216 230 val toKnownEquality =
ziv@2216 231 (* [NONE] here means unkown. Anything that isn't a comparison between
ziv@2216 232 two knowns shouldn't be used, and simply dropping unused terms is
ziv@2216 233 okay in disjunctive normal form. *)
ziv@2216 234 fn (Sql.Eq, SOME e1, SOME e2) => SOME (e1, e2)
ziv@2216 235 | _ => NONE
ziv@2216 236 val equivClasses : (Sql.cmp * atomExp option * atomExp option) list -> atomExp list list =
ziv@2216 237 UF.classes
ziv@2216 238 o List.foldl UF.union' UF.empty
ziv@2216 239 o List.mapPartial toKnownEquality
ziv@2216 240 fun addToEqs (eqs, n, e) =
ziv@2216 241 case IM.find (eqs, n) of
ziv@2234 242 (* Comparing to a constant is probably better than comparing to
ziv@2234 243 a variable? Checking that an existing constant matches a new
ziv@2234 244 one is handled by [accumulateEqs]. *)
ziv@2218 245 SOME (Prim _) => eqs
ziv@2216 246 | _ => IM.insert (eqs, n, e)
ziv@2216 247 val accumulateEqs =
ziv@2216 248 (* [NONE] means we have a contradiction. *)
ziv@2216 249 fn (_, NONE) => NONE
ziv@2216 250 | ((Prim p1, Prim p2), eqso) =>
ziv@2216 251 (case Prim.compare (p1, p2) of
ziv@2216 252 EQUAL => eqso
ziv@2213 253 | _ => NONE)
ziv@2218 254 | ((QueryArg n, Prim p), SOME eqs) => SOME (addToEqs (eqs, n, Prim p))
ziv@2218 255 | ((QueryArg n, DmlRel r), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r))
ziv@2218 256 | ((Prim p, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, Prim p))
ziv@2218 257 | ((DmlRel r, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r))
ziv@2223 258 (* TODO: deal with equalities involving just [DmlRel]s and [Prim]s.
ziv@2223 259 This would involve guarding the invalidation with a check for the
ziv@2223 260 relevant comparisons. *)
ziv@2234 261 (* DEBUG: remove these print statements. *)
ziv@2234 262 (* | ((DmlRel r, Prim p), eqso) => (print ("sadness " ^ Int.toString r ^ " = " ^ Prim.toString p ^ "\n"); eqso) *)
ziv@2234 263 (* | ((Prim p, DmlRel r), eqso) => (print ("sadness " ^ Int.toString r ^ " = " ^ Prim.toString p ^ "\n"); eqso) *)
ziv@2216 264 | (_, eqso) => eqso
ziv@2218 265 val eqsOfClass : atomExp list -> atomExp IM.map option =
ziv@2216 266 List.foldl accumulateEqs (SOME IM.empty)
ziv@2216 267 o chooseTwos
ziv@2216 268 fun toAtomExps rel (cmp, e1, e2) =
ziv@2216 269 let
ziv@2216 270 val qa =
ziv@2216 271 (* Here [NONE] means unkown. *)
ziv@2216 272 fn Sql.SqConst p => SOME (Prim p)
ziv@2216 273 | Sql.Field tf => SOME (Field tf)
ziv@2216 274 | Sql.Inj (EPrim p, _) => SOME (Prim p)
ziv@2216 275 | Sql.Inj (ERel n, _) => SOME (rel n)
ziv@2234 276 (* We can't deal with anything else, e.g., CURRENT_TIMESTAMP
ziv@2234 277 becomes Sql.Unmodeled, which becomes NONE here. *)
ziv@2216 278 | _ => NONE
ziv@2216 279 in
ziv@2216 280 (cmp, qa e1, qa e2)
ziv@2216 281 end
ziv@2216 282 fun negateCmp (cmp, e1, e2) =
ziv@2216 283 (case cmp of
ziv@2216 284 Sql.Eq => Sql.Ne
ziv@2216 285 | Sql.Ne => Sql.Eq
ziv@2216 286 | Sql.Lt => Sql.Ge
ziv@2216 287 | Sql.Le => Sql.Gt
ziv@2216 288 | Sql.Gt => Sql.Le
ziv@2216 289 | Sql.Ge => Sql.Lt,
ziv@2216 290 e1, e2)
ziv@2218 291 val markQuery : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula ->
ziv@2218 292 (Sql.cmp * atomExp option * atomExp option) formula =
ziv@2218 293 mapFormula (toAtomExps QueryArg)
ziv@2218 294 val markDml : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula ->
ziv@2218 295 (Sql.cmp * atomExp option * atomExp option) formula =
ziv@2218 296 mapFormula (toAtomExps DmlRel)
ziv@2218 297 (* No eqs should have key conflicts because no variable is in two
ziv@2218 298 equivalence classes, so the [#1] can be anything. *)
ziv@2218 299 val mergeEqs : (atomExp IntBinaryMap.map option list
ziv@2218 300 -> atomExp IntBinaryMap.map option) =
ziv@2218 301 List.foldr (fn (SOME eqs, SOME acc) => SOME (IM.unionWith #1 (eqs, acc)) | _ => NONE)
ziv@2218 302 (SOME IM.empty)
ziv@2218 303 fun dnf (fQuery, fDml) =
ziv@2234 304 normalize negateCmp Disj (Combo (Conj, [markQuery fQuery, markDml fDml]))
ziv@2221 305 in
ziv@2221 306 List.mapPartial (mergeEqs o map eqsOfClass o equivClasses) o dnf
ziv@2221 307 end
ziv@2213 308
ziv@2216 309 val rec sqexpToFormula =
ziv@2234 310 fn Sql.SqTrue => Combo (Conj, [])
ziv@2234 311 | Sql.SqFalse => Combo (Disj, [])
ziv@2216 312 | Sql.SqNot e => Negate (sqexpToFormula e)
ziv@2216 313 | Sql.Binop (Sql.RCmp c, e1, e2) => Atom (c, e1, e2)
ziv@2234 314 | Sql.Binop (Sql.RLop l, p1, p2) => Combo (case l of Sql.And => Conj | Sql.Or => Disj,
ziv@2216 315 [sqexpToFormula p1, sqexpToFormula p2])
ziv@2216 316 (* ASK: any other sqexps that can be props? *)
ziv@2216 317 | _ => raise Match
ziv@2213 318
ziv@2218 319 fun renameTables tablePairs =
ziv@2216 320 let
ziv@2216 321 fun renameString table =
ziv@2216 322 case List.find (fn (_, t) => table = t) tablePairs of
ziv@2216 323 NONE => table
ziv@2216 324 | SOME (realTable, _) => realTable
ziv@2216 325 val renameSqexp =
ziv@2216 326 fn Sql.Field (table, field) => Sql.Field (renameString table, field)
ziv@2216 327 | e => e
ziv@2218 328 fun renameAtom (cmp, e1, e2) = (cmp, renameSqexp e1, renameSqexp e2)
ziv@2216 329 in
ziv@2218 330 mapFormula renameAtom
ziv@2216 331 end
ziv@2218 332
ziv@2218 333 val rec queryToFormula =
ziv@2234 334 fn Sql.Query1 {Where = NONE, ...} => Combo (Conj, [])
ziv@2218 335 | Sql.Query1 {From = tablePairs, Where = SOME e, ...} =>
ziv@2218 336 renameTables tablePairs (sqexpToFormula e)
ziv@2234 337 | Sql.Union (q1, q2) => Combo (Disj, [queryToFormula q1, queryToFormula q2])
ziv@2216 338
ziv@2218 339 fun valsToFormula (table, vals) =
ziv@2234 340 Combo (Conj, map (fn (field, v) => Atom (Sql.Eq, Sql.Field (table, field), v)) vals)
ziv@2218 341
ziv@2216 342 val rec dmlToFormula =
ziv@2221 343 fn Sql.Insert (table, vals) => valsToFormula (table, vals)
ziv@2218 344 | Sql.Delete (table, wher) => renameTables [(table, "T")] (sqexpToFormula wher)
ziv@2218 345 | Sql.Update (table, vals, wher) =>
ziv@2218 346 let
ziv@2221 347 val fWhere = sqexpToFormula wher
ziv@2221 348 val fVals = valsToFormula (table, vals)
ziv@2221 349 (* TODO: don't use field name hack. *)
ziv@2221 350 val markField =
ziv@2221 351 fn Sql.Field (t, v) => Sql.Field (t, v ^ "*")
ziv@2221 352 | e => e
ziv@2221 353 val mark = mapFormula (fn (cmp, e1, e2) => (cmp, markField e1, markField e2))
ziv@2218 354 in
ziv@2218 355 renameTables [(table, "T")]
ziv@2234 356 (Combo (Disj, [Combo (Conj, [fVals, mark fWhere]),
ziv@2234 357 Combo (Conj, [mark fVals, fWhere])]))
ziv@2218 358 end
ziv@2213 359
ziv@2213 360 val rec tablesQuery =
ziv@2216 361 fn Sql.Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs)
ziv@2216 362 | Sql.Union (q1, q2) => SS.union (tablesQuery q1, tablesQuery q2)
ziv@2213 363
ziv@2213 364 val tableDml =
ziv@2216 365 fn Sql.Insert (tab, _) => tab
ziv@2216 366 | Sql.Delete (tab, _) => tab
ziv@2216 367 | Sql.Update (tab, _, _) => tab
ziv@2213 368
ziv@2213 369
ziv@2213 370 (* Program instrumentation. *)
ziv@2213 371
ziv@2234 372 val varName =
ziv@2234 373 let
ziv@2234 374 val varNumber = ref 0
ziv@2234 375 in
ziv@2234 376 fn s => (varNumber := !varNumber + 1; s ^ Int.toString (!varNumber))
ziv@2234 377 end
ziv@2234 378
ziv@2233 379 val {check, store, flush, ...} = getCache ()
ziv@2233 380
ziv@2230 381 val dummyLoc = ErrorMsg.dummySpan
ziv@2216 382
ziv@2230 383 fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), dummyLoc)
ziv@2230 384
ziv@2230 385 val stringTyp = (TFfi ("Basis", "string"), dummyLoc)
ziv@2213 386
ziv@2213 387 val sequence =
ziv@2213 388 fn (exp :: exps) =>
ziv@2213 389 let
ziv@2230 390 val loc = dummyLoc
ziv@2213 391 in
ziv@2213 392 List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps
ziv@2213 393 end
ziv@2213 394 | _ => raise Match
ziv@2213 395
ziv@2215 396 (* Always increments negative indices because that's what we need later. *)
ziv@2215 397 fun incRelsBound bound inc =
ziv@2215 398 MonoUtil.Exp.mapB
ziv@2215 399 {typ = fn x => x,
ziv@2215 400 exp = fn level =>
ziv@2215 401 (fn ERel n => ERel (if n >= level orelse n < 0 then n + inc else n)
ziv@2215 402 | x => x),
ziv@2215 403 bind = fn (level, MonoUtil.Exp.RelE _) => level + 1 | (level, _) => level}
ziv@2215 404 bound
ziv@2215 405
ziv@2215 406 val incRels = incRelsBound 0
ziv@2213 407
ziv@2223 408 fun cacheWrap (query, i, urlifiedRel0, resultTyp, args) =
ziv@2213 409 let
ziv@2223 410 val () = ffiInfo := {index = i, params = length args} :: !ffiInfo
ziv@2230 411 val loc = dummyLoc
ziv@2223 412 (* We ensure before this step that all arguments aren't effectful.
ziv@2227 413 by turning them into local variables as needed. *)
ziv@2230 414 val argsInc = map (incRels 1) args
ziv@2233 415 val check = (check (i, args), dummyLoc)
ziv@2233 416 val store = (store (i, argsInc, urlifiedRel0), dummyLoc)
ziv@2223 417 val rel0 = (ERel 0, loc)
ziv@2213 418 in
ziv@2223 419 ECase (check,
ziv@2223 420 [((PNone stringTyp, loc),
ziv@2234 421 (ELet (varName "q", resultTyp, query, (ESeq (store, rel0), loc)), loc)),
ziv@2234 422 ((PSome (stringTyp, (PVar (varName "hit", stringTyp), loc)), loc),
ziv@2223 423 (* Boolean is false because we're not unurlifying from a cookie. *)
ziv@2223 424 (EUnurlify (rel0, resultTyp, false), loc))],
ziv@2223 425 {disc = stringTyp, result = resultTyp})
ziv@2213 426 end
ziv@2213 427
ziv@2213 428 fun fileMapfold doExp file start =
ziv@2213 429 case MonoUtil.File.mapfold {typ = Search.return2,
ziv@2213 430 exp = fn x => (fn s => Search.Continue (doExp x s)),
ziv@2213 431 decl = Search.return2} file start of
ziv@2213 432 Search.Continue x => x
ziv@2213 433 | Search.Return _ => raise Match
ziv@2213 434
ziv@2213 435 fun fileMap doExp file = #1 (fileMapfold (fn x => fn _ => (doExp x, ())) file ())
ziv@2213 436
ziv@2221 437 fun factorOutNontrivial text =
ziv@2221 438 let
ziv@2230 439 val loc = dummyLoc
ziv@2221 440 fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
ziv@2221 441 val chunks = Sql.chunkify text
ziv@2221 442 val (newText, newVariables) =
ziv@2221 443 (* Important that this is foldr (to oppose foldl below). *)
ziv@2221 444 List.foldr
ziv@2221 445 (fn (chunk, (qText, newVars)) =>
ziv@2221 446 (* Variable bound to the head of newBs will have the lowest index. *)
ziv@2221 447 case chunk of
ziv@2221 448 Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars)
ziv@2221 449 | Sql.Exp e =>
ziv@2221 450 let
ziv@2221 451 val n = length newVars
ziv@2221 452 in
ziv@2221 453 (* This is the (n + 1)th new variable, so there are
ziv@2221 454 already n new variables bound, so we increment
ziv@2221 455 indices by n. *)
ziv@2221 456 (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars)
ziv@2221 457 end
ziv@2221 458 | Sql.String s => (strcat (stringExp s, qText), newVars))
ziv@2221 459 (stringExp "", [])
ziv@2221 460 chunks
ziv@2221 461 fun wrapLets e' =
ziv@2221 462 (* Important that this is foldl (to oppose foldr above). *)
ziv@2234 463 List.foldl (fn (v, e') => ELet (varName "sqlArg", stringTyp, v, (e', loc)))
ziv@2221 464 e'
ziv@2221 465 newVariables
ziv@2221 466 val numArgs = length newVariables
ziv@2221 467 in
ziv@2221 468 (newText, wrapLets, numArgs)
ziv@2221 469 end
ziv@2221 470
ziv@2215 471 fun addChecking file =
ziv@2213 472 let
ziv@2223 473 fun doExp (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) =
ziv@2223 474 fn e' as EQuery {query = origQueryText,
ziv@2223 475 sqlcacheInfo = urlifiedRel0,
ziv@2223 476 state = resultTyp,
ziv@2223 477 initial, body, tables, exps} =>
ziv@2213 478 let
ziv@2221 479 val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText
ziv@2215 480 (* Increment once for each new variable just made. *)
ziv@2221 481 val queryExp = incRels numArgs
ziv@2215 482 (EQuery {query = newQueryText,
ziv@2223 483 sqlcacheInfo = urlifiedRel0,
ziv@2223 484 state = resultTyp,
ziv@2215 485 initial = initial,
ziv@2215 486 body = body,
ziv@2215 487 tables = tables,
ziv@2223 488 exps = exps},
ziv@2230 489 dummyLoc)
ziv@2215 490 val (EQuery {query = queryText, ...}, _) = queryExp
ziv@2234 491 (* DEBUG: we can remove the following line at some point. *)
ziv@2221 492 val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText))
ziv@2230 493 val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc))
ziv@2213 494 fun bind x f = Option.mapPartial f x
ziv@2215 495 fun guard b x = if b then x else NONE
ziv@2215 496 (* DEBUG: set first boolean argument to true to turn on printing. *)
ziv@2215 497 fun safe bound = not o effectful true (effectfulMap file) false bound
ziv@2213 498 val attempt =
ziv@2213 499 (* Ziv misses Haskell's do notation.... *)
ziv@2215 500 guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) (
ziv@2216 501 bind (Sql.parse Sql.query queryText) (fn queryParsed =>
ziv@2223 502 SOME (wrapLets (cacheWrap (queryExp, index, urlifiedRel0, resultTyp, args)),
ziv@2218 503 (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index))
ziv@2218 504 tableToIndices
ziv@2218 505 (tablesQuery queryParsed),
ziv@2223 506 IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)),
ziv@2223 507 index + 1))))
ziv@2213 508 in
ziv@2213 509 case attempt of
ziv@2213 510 SOME pair => pair
ziv@2213 511 | NONE => (e', queryInfo)
ziv@2213 512 end
ziv@2213 513 | e' => (e', queryInfo)
ziv@2213 514 in
ziv@2223 515 fileMapfold (fn exp => fn state => doExp state exp) file (SIMM.empty, IM.empty, 0)
ziv@2213 516 end
ziv@2213 517
ziv@2221 518 fun invalidations ((query, numArgs), dml) =
ziv@2216 519 let
ziv@2230 520 val loc = dummyLoc
ziv@2218 521 val optionAtomExpToExp =
ziv@2216 522 fn NONE => (ENone stringTyp, loc)
ziv@2218 523 | SOME e => (ESome (stringTyp,
ziv@2218 524 (case e of
ziv@2218 525 DmlRel n => ERel n
ziv@2218 526 | Prim p => EPrim p
ziv@2218 527 (* TODO: make new type containing only these two. *)
ziv@2218 528 | _ => raise Match,
ziv@2218 529 loc)),
ziv@2218 530 loc)
ziv@2216 531 fun eqsToInvalidation eqs =
ziv@2216 532 let
ziv@2218 533 fun inv n = if n < 0 then [] else IM.find (eqs, n) :: inv (n - 1)
ziv@2216 534 in
ziv@2221 535 inv (numArgs - 1)
ziv@2216 536 end
ziv@2221 537 (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here
ziv@2221 538 represents unknown, which means a wider invalidation. *)
ziv@2218 539 val rec madeRedundantBy : atomExp option list * atomExp option list -> bool =
ziv@2234 540 fn ([], []) => (print "hey!\n"; true)
ziv@2218 541 | (NONE :: xs, _ :: ys) => madeRedundantBy (xs, ys)
ziv@2234 542 | (SOME x :: xs, SOME y :: ys) => (case AtomExpKey.compare (x, y) of
ziv@2234 543 EQUAL => madeRedundantBy (xs, ys)
ziv@2234 544 | _ => false)
ziv@2218 545 | _ => false
ziv@2218 546 fun removeRedundant' (xss, yss) =
ziv@2218 547 case xss of
ziv@2218 548 [] => yss
ziv@2218 549 | xs :: xss' =>
ziv@2218 550 removeRedundant' (xss',
ziv@2218 551 if List.exists (fn ys => madeRedundantBy (xs, ys)) (xss' @ yss)
ziv@2218 552 then yss
ziv@2218 553 else xs :: yss)
ziv@2218 554 fun removeRedundant xss = removeRedundant' (xss, [])
ziv@2218 555 val eqss = conflictMaps (queryToFormula query, dmlToFormula dml)
ziv@2216 556 in
ziv@2218 557 (map (map optionAtomExpToExp) o removeRedundant o map eqsToInvalidation) eqss
ziv@2216 558 end
ziv@2216 559
ziv@2223 560 fun addFlushing (file, (tableToIndices, indexToQueryNumArgs, _)) =
ziv@2213 561 let
ziv@2221 562 val flushes = List.concat o
ziv@2233 563 map (fn (i, argss) => map (fn args => flush (i, args)) argss)
ziv@2213 564 val doExp =
ziv@2221 565 fn EDml (origDmlText, failureMode) =>
ziv@2213 566 let
ziv@2221 567 val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText
ziv@2221 568 val dmlText = incRels numArgs newDmlText
ziv@2221 569 val dmlExp = EDml (dmlText, failureMode)
ziv@2227 570 (* DEBUG: we can remove the following line at some point. *)
ziv@2221 571 val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty dmlText))
ziv@2221 572 val invs =
ziv@2216 573 case Sql.parse Sql.dml dmlText of
ziv@2218 574 SOME dmlParsed =>
ziv@2221 575 map (fn i => (case IM.find (indexToQueryNumArgs, i) of
ziv@2221 576 SOME queryNumArgs =>
ziv@2221 577 (i, invalidations (queryNumArgs, dmlParsed))
ziv@2221 578 (* TODO: fail more gracefully. *)
ziv@2221 579 | NONE => raise Match))
ziv@2221 580 (SIMM.findList (tableToIndices, tableDml dmlParsed))
ziv@2221 581 (* TODO: fail more gracefully. *)
ziv@2221 582 | NONE => raise Match
ziv@2213 583 in
ziv@2221 584 wrapLets (sequence (flushes invs @ [dmlExp]))
ziv@2213 585 end
ziv@2213 586 | e' => e'
ziv@2213 587 in
ziv@2213 588 fileMap doExp file
ziv@2213 589 end
ziv@2213 590
ziv@2221 591 val inlineSql =
ziv@2221 592 let
ziv@2221 593 val doExp =
ziv@2221 594 (* TODO: EQuery, too? *)
ziv@2221 595 (* ASK: should this live in [MonoOpt]? *)
ziv@2221 596 fn EDml ((ECase (disc, cases, {disc = dTyp, ...}), loc), failureMode) =>
ziv@2221 597 let
ziv@2221 598 val newCases = map (fn (p, e) => (p, (EDml (e, failureMode), loc))) cases
ziv@2221 599 in
ziv@2221 600 ECase (disc, newCases, {disc = dTyp, result = (TRecord [], loc)})
ziv@2221 601 end
ziv@2221 602 | e => e
ziv@2221 603 in
ziv@2221 604 fileMap doExp
ziv@2221 605 end
ziv@2221 606
ziv@2213 607 fun go file =
ziv@2213 608 let
ziv@2227 609 (* TODO: do something nicer than having Sql be in one of two modes. *)
ziv@2227 610 val () = (resetFfiInfo (); Sql.sqlcacheMode := true)
ziv@2221 611 val file' = addFlushing (addChecking (inlineSql file))
ziv@2215 612 val () = Sql.sqlcacheMode := false
ziv@2213 613 in
ziv@2221 614 file'
ziv@2213 615 end
ziv@2213 616
ziv@2209 617 end