Mercurial > urweb

annotate src/sqlcache.sml @ 2227:adb49db02af4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix type in flush FFI call to option string (rather than string).
author Ziv Scully <ziv@mit.edu>
date Tue, 31 Mar 2015 04:10:46 -0400
parents 9410959d296f
children a749acc51ae4
rev   line source
ziv@2213 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@2215 42
ziv@2215 43 (* Effect analysis. *)
ziv@2215 44
ziv@2216 45 (* Makes an exception for [EWrite] (which is recorded when caching). *)
ziv@2215 46 fun effectful doPrint (effs : IS.set) (inFunction : bool) (bound : int) : Mono.exp -> bool =
ziv@2215 47 (* If result is true, expression is definitely effectful. If result is
ziv@2215 48 false, then expression is definitely not effectful if effs is fully
ziv@2215 49 populated. The intended pattern is to use this a number of times equal
ziv@2215 50 to the number of declarations in a file, Bellman-Ford style. *)
ziv@2223 51 (* TODO: make incrementing of bound less janky, probably by using [MonoUtil]
ziv@2215 52 instead of all this. *)
ziv@2215 53 let
ziv@2215 54 (* DEBUG: remove printing when done. *)
ziv@2215 55 fun tru msg = if doPrint then (print (msg ^ "\n"); true) else true
ziv@2215 56 val rec eff' =
ziv@2215 57 (* ASK: is there a better way? *)
ziv@2215 58 fn EPrim _ => false
ziv@2215 59 (* We don't know if local functions have effects when applied. *)
ziv@2215 60 | ERel idx => if inFunction andalso idx >= bound
ziv@2215 61 then tru ("rel" ^ Int.toString idx) else false
ziv@2215 62 | ENamed name => if IS.member (effs, name) then tru "named" else false
ziv@2215 63 | ECon (_, _, NONE) => false
ziv@2215 64 | ECon (_, _, SOME e) => eff e
ziv@2215 65 | ENone _ => false
ziv@2215 66 | ESome (_, e) => eff e
ziv@2215 67 | EFfi (m, f) => if ffiEffectful (m, f) then tru "ffi" else false
ziv@2215 68 | EFfiApp (m, f, _) => if ffiEffectful (m, f) then tru "ffiapp" else false
ziv@2215 69 (* ASK: we're calling functions effectful if they have effects when
ziv@2215 70 applied or if the function expressions themselves have effects.
ziv@2215 71 Is that okay? *)
ziv@2215 72 (* This is okay because the values we ultimately care about aren't
ziv@2215 73 functions, and this is a conservative approximation, anyway. *)
ziv@2215 74 | EApp (eFun, eArg) => effectful doPrint effs true bound eFun orelse eff eArg
ziv@2215 75 | EAbs (_, _, _, e) => effectful doPrint effs inFunction (bound+1) e
ziv@2215 76 | EUnop (_, e) => eff e
ziv@2215 77 | EBinop (_, _, e1, e2) => eff e1 orelse eff e2
ziv@2215 78 | ERecord xs => List.exists (fn (_, e, _) => eff e) xs
ziv@2215 79 | EField (e, _) => eff e
ziv@2215 80 (* If any case could be effectful, consider it effectful. *)
ziv@2215 81 | ECase (e, xs, _) => eff e orelse List.exists (fn (_, e) => eff e) xs
ziv@2215 82 | EStrcat (e1, e2) => eff e1 orelse eff e2
ziv@2215 83 (* ASK: how should we treat these three? *)
ziv@2215 84 | EError _ => tru "error"
ziv@2215 85 | EReturnBlob _ => tru "blob"
ziv@2215 86 | ERedirect _ => tru "redirect"
ziv@2215 87 (* EWrite is a special exception because we record writes when caching. *)
ziv@2215 88 | EWrite _ => false
ziv@2215 89 | ESeq (e1, e2) => eff e1 orelse eff e2
ziv@2215 90 (* TODO: keep context of which local variables aren't effectful? Only
ziv@2215 91 makes a difference for function expressions, though. *)
ziv@2215 92 | ELet (_, _, eBind, eBody) => eff eBind orelse
ziv@2215 93 effectful doPrint effs inFunction (bound+1) eBody
ziv@2215 94 | EClosure (_, es) => List.exists eff es
ziv@2215 95 (* TODO: deal with EQuery. *)
ziv@2215 96 | EQuery _ => tru "query"
ziv@2215 97 | EDml _ => tru "dml"
ziv@2215 98 | ENextval _ => tru "nextval"
ziv@2215 99 | ESetval _ => tru "setval"
ziv@2215 100 | EUnurlify (e, _, _) => eff e
ziv@2215 101 (* ASK: how should we treat this? *)
ziv@2215 102 | EJavaScript _ => tru "javascript"
ziv@2215 103 (* ASK: these are all effectful, right? *)
ziv@2215 104 | ESignalReturn _ => tru "signalreturn"
ziv@2215 105 | ESignalBind _ => tru "signalbind"
ziv@2215 106 | ESignalSource _ => tru "signalsource"
ziv@2215 107 | EServerCall _ => tru "servercall"
ziv@2215 108 | ERecv _ => tru "recv"
ziv@2215 109 | ESleep _ => tru "sleep"
ziv@2215 110 | ESpawn _ => tru "spawn"
ziv@2215 111 and eff = fn (e', _) => eff' e'
ziv@2215 112 in
ziv@2215 113 eff
ziv@2215 114 end
ziv@2215 115
ziv@2215 116 (* TODO: test this. *)
ziv@2215 117 val effectfulMap =
ziv@2215 118 let
ziv@2215 119 fun doVal ((_, name, _, e, _), effMap) =
ziv@2215 120 if effectful false effMap false 0 e
ziv@2215 121 then IS.add (effMap, name)
ziv@2215 122 else effMap
ziv@2215 123 val doDecl =
ziv@2215 124 fn (DVal v, effMap) => doVal (v, effMap)
ziv@2215 125 (* Repeat the list of declarations a number of times equal to its size. *)
ziv@2215 126 | (DValRec vs, effMap) =>
ziv@2215 127 List.foldl doVal effMap (List.concat (List.map (fn _ => vs) vs))
ziv@2215 128 (* ASK: any other cases? *)
ziv@2215 129 | (_, effMap) => effMap
ziv@2215 130 in
ziv@2215 131 MonoUtil.File.fold {typ = #2, exp = #2, decl = doDecl} IS.empty
ziv@2215 132 end
ziv@2215 133
ziv@2215 134
ziv@2216 135 (* Boolean formula normalization. *)
ziv@2216 136
ziv@2216 137 datatype normalForm = Cnf | Dnf
ziv@2216 138
ziv@2216 139 datatype 'atom formula =
ziv@2216 140 Atom of 'atom
ziv@2216 141 | Negate of 'atom formula
ziv@2216 142 | Combo of normalForm * 'atom formula list
ziv@2216 143
ziv@2216 144 val flipNf = fn Cnf => Dnf | Dnf => Cnf
ziv@2216 145
ziv@2216 146 fun bind xs f = List.concat (map f xs)
ziv@2216 147
ziv@2216 148 val rec cartesianProduct : 'a list list -> 'a list list =
ziv@2216 149 fn [] => [[]]
ziv@2216 150 | (xs :: xss) => bind (cartesianProduct xss)
ziv@2216 151 (fn ys => bind xs (fn x => [x :: ys]))
ziv@2216 152
ziv@2218 153 (* Pushes all negation to the atoms.*)
ziv@2218 154 fun pushNegate (negate : 'atom -> 'atom) (negating : bool) =
ziv@2218 155 fn Atom x => Atom (if negating then negate x else x)
ziv@2218 156 | Negate f => pushNegate negate (not negating) f
ziv@2218 157 | Combo (n, fs) => Combo (if negating then flipNf n else n, map (pushNegate negate negating) fs)
ziv@2218 158
ziv@2218 159 val rec flatten =
ziv@2218 160 fn Combo (n, fs) =>
ziv@2218 161 Combo (n, List.foldr (fn (f, acc) =>
ziv@2218 162 case f of
ziv@2218 163 Combo (n', fs') => if n = n' then fs' @ acc else f :: acc
ziv@2218 164 | _ => f :: acc)
ziv@2218 165 []
ziv@2218 166 (map flatten fs))
ziv@2218 167 | f => f
ziv@2218 168
ziv@2218 169 fun normalize' (negate : 'atom -> 'atom) (norm : normalForm) =
ziv@2216 170 fn Atom x => [[x]]
ziv@2218 171 | Negate f => map (map negate) (normalize' negate (flipNf norm) f)
ziv@2216 172 | Combo (n, fs) =>
ziv@2216 173 let
ziv@2218 174 val fss = bind fs (normalize' negate n)
ziv@2216 175 in
ziv@2216 176 if n = norm then fss else cartesianProduct fss
ziv@2216 177 end
ziv@2216 178
ziv@2218 179 fun normalize negate norm = normalize' negate norm o flatten o pushNegate negate false
ziv@2216 180
ziv@2221 181 fun mapFormula mf =
ziv@2221 182 fn Atom x => Atom (mf x)
ziv@2221 183 | Negate f => Negate (mapFormula mf f)
ziv@2221 184 | Combo (n, fs) => Combo (n, map (mapFormula mf) fs)
ziv@2216 185
ziv@2215 186 (* SQL analysis. *)
ziv@2213 187
ziv@2216 188 val rec chooseTwos : 'a list -> ('a * 'a) list =
ziv@2216 189 fn [] => []
ziv@2216 190 | x :: ys => map (fn y => (x, y)) ys @ chooseTwos ys
ziv@2213 191
ziv@2216 192 datatype atomExp =
ziv@2216 193 QueryArg of int
ziv@2216 194 | DmlRel of int
ziv@2216 195 | Prim of Prim.t
ziv@2216 196 | Field of string * string
ziv@2216 197
ziv@2218 198 val equalAtomExp =
ziv@2218 199 let
ziv@2218 200 val isEqual = fn EQUAL => true | _ => false
ziv@2218 201 in
ziv@2218 202 fn (QueryArg n1, QueryArg n2) => n1 = n2
ziv@2218 203 | (DmlRel n1, DmlRel n2) => n1 = n2
ziv@2218 204 | (Prim p1, Prim p2) => isEqual (Prim.compare (p1, p2))
ziv@2218 205 | (Field (t1, f1), Field (t2, f2)) => isEqual (String.compare (t1 ^ "." ^ f1, t2 ^ "." ^ f2))
ziv@2218 206 | _ => false
ziv@2218 207 end
ziv@2218 208
ziv@2216 209 structure AtomExpKey : ORD_KEY = struct
ziv@2216 210
ziv@2216 211 type ord_key = atomExp
ziv@2216 212
ziv@2216 213 val compare =
ziv@2216 214 fn (QueryArg n1, QueryArg n2) => Int.compare (n1, n2)
ziv@2216 215 | (QueryArg _, _) => LESS
ziv@2216 216 | (_, QueryArg _) => GREATER
ziv@2216 217 | (DmlRel n1, DmlRel n2) => Int.compare (n1, n2)
ziv@2216 218 | (DmlRel _, _) => LESS
ziv@2216 219 | (_, DmlRel _) => GREATER
ziv@2216 220 | (Prim p1, Prim p2) => Prim.compare (p1, p2)
ziv@2216 221 | (Prim _, _) => LESS
ziv@2216 222 | (_, Prim _) => GREATER
ziv@2216 223 | (Field (t1, f1), Field (t2, f2)) => String.compare (t1 ^ "." ^ f1, t2 ^ "." ^ f2)
ziv@2216 224
ziv@2216 225 end
ziv@2216 226
ziv@2216 227 structure UF = UnionFindFn(AtomExpKey)
ziv@2221 228 val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula
ziv@2221 229 * (Sql.cmp * Sql.sqexp * Sql.sqexp) formula
ziv@2221 230 -> atomExp IM.map list =
ziv@2221 231 let
ziv@2216 232 val toKnownEquality =
ziv@2216 233 (* [NONE] here means unkown. Anything that isn't a comparison between
ziv@2216 234 two knowns shouldn't be used, and simply dropping unused terms is
ziv@2216 235 okay in disjunctive normal form. *)
ziv@2216 236 fn (Sql.Eq, SOME e1, SOME e2) => SOME (e1, e2)
ziv@2216 237 | _ => NONE
ziv@2216 238 val equivClasses : (Sql.cmp * atomExp option * atomExp option) list -> atomExp list list =
ziv@2216 239 UF.classes
ziv@2216 240 o List.foldl UF.union' UF.empty
ziv@2216 241 o List.mapPartial toKnownEquality
ziv@2216 242 fun addToEqs (eqs, n, e) =
ziv@2216 243 case IM.find (eqs, n) of
ziv@2216 244 (* Comparing to a constant seems better? *)
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@2216 261 | (_, eqso) => eqso
ziv@2218 262 val eqsOfClass : atomExp list -> atomExp IM.map option =
ziv@2216 263 List.foldl accumulateEqs (SOME IM.empty)
ziv@2216 264 o chooseTwos
ziv@2216 265 fun toAtomExps rel (cmp, e1, e2) =
ziv@2216 266 let
ziv@2216 267 val qa =
ziv@2216 268 (* Here [NONE] means unkown. *)
ziv@2216 269 fn Sql.SqConst p => SOME (Prim p)
ziv@2216 270 | Sql.Field tf => SOME (Field tf)
ziv@2216 271 | Sql.Inj (EPrim p, _) => SOME (Prim p)
ziv@2216 272 | Sql.Inj (ERel n, _) => SOME (rel n)
ziv@2216 273 (* We can't deal with anything else. *)
ziv@2216 274 | _ => NONE
ziv@2216 275 in
ziv@2216 276 (cmp, qa e1, qa e2)
ziv@2216 277 end
ziv@2216 278 fun negateCmp (cmp, e1, e2) =
ziv@2216 279 (case cmp of
ziv@2216 280 Sql.Eq => Sql.Ne
ziv@2216 281 | Sql.Ne => Sql.Eq
ziv@2216 282 | Sql.Lt => Sql.Ge
ziv@2216 283 | Sql.Le => Sql.Gt
ziv@2216 284 | Sql.Gt => Sql.Le
ziv@2216 285 | Sql.Ge => Sql.Lt,
ziv@2216 286 e1, e2)
ziv@2218 287 val markQuery : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula ->
ziv@2218 288 (Sql.cmp * atomExp option * atomExp option) formula =
ziv@2218 289 mapFormula (toAtomExps QueryArg)
ziv@2218 290 val markDml : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula ->
ziv@2218 291 (Sql.cmp * atomExp option * atomExp option) formula =
ziv@2218 292 mapFormula (toAtomExps DmlRel)
ziv@2218 293 (* No eqs should have key conflicts because no variable is in two
ziv@2218 294 equivalence classes, so the [#1] can be anything. *)
ziv@2218 295 val mergeEqs : (atomExp IntBinaryMap.map option list
ziv@2218 296 -> atomExp IntBinaryMap.map option) =
ziv@2218 297 List.foldr (fn (SOME eqs, SOME acc) => SOME (IM.unionWith #1 (eqs, acc)) | _ => NONE)
ziv@2218 298 (SOME IM.empty)
ziv@2218 299 fun dnf (fQuery, fDml) =
ziv@2218 300 normalize negateCmp Dnf (Combo (Cnf, [markQuery fQuery, markDml fDml]))
ziv@2221 301 in
ziv@2221 302 List.mapPartial (mergeEqs o map eqsOfClass o equivClasses) o dnf
ziv@2221 303 end
ziv@2213 304
ziv@2216 305 val rec sqexpToFormula =
ziv@2216 306 fn Sql.SqTrue => Combo (Cnf, [])
ziv@2216 307 | Sql.SqFalse => Combo (Dnf, [])
ziv@2216 308 | Sql.SqNot e => Negate (sqexpToFormula e)
ziv@2216 309 | Sql.Binop (Sql.RCmp c, e1, e2) => Atom (c, e1, e2)
ziv@2216 310 | Sql.Binop (Sql.RLop l, p1, p2) => Combo (case l of Sql.And => Cnf | Sql.Or => Dnf,
ziv@2216 311 [sqexpToFormula p1, sqexpToFormula p2])
ziv@2216 312 (* ASK: any other sqexps that can be props? *)
ziv@2216 313 | _ => raise Match
ziv@2213 314
ziv@2218 315 fun renameTables tablePairs =
ziv@2216 316 let
ziv@2216 317 fun renameString table =
ziv@2216 318 case List.find (fn (_, t) => table = t) tablePairs of
ziv@2216 319 NONE => table
ziv@2216 320 | SOME (realTable, _) => realTable
ziv@2216 321 val renameSqexp =
ziv@2216 322 fn Sql.Field (table, field) => Sql.Field (renameString table, field)
ziv@2216 323 | e => e
ziv@2218 324 fun renameAtom (cmp, e1, e2) = (cmp, renameSqexp e1, renameSqexp e2)
ziv@2216 325 in
ziv@2218 326 mapFormula renameAtom
ziv@2216 327 end
ziv@2218 328
ziv@2218 329 val rec queryToFormula =
ziv@2218 330 fn Sql.Query1 {Where = NONE, ...} => Combo (Cnf, [])
ziv@2218 331 | Sql.Query1 {From = tablePairs, Where = SOME e, ...} =>
ziv@2218 332 renameTables tablePairs (sqexpToFormula e)
ziv@2216 333 | Sql.Union (q1, q2) => Combo (Dnf, [queryToFormula q1, queryToFormula q2])
ziv@2216 334
ziv@2218 335 fun valsToFormula (table, vals) =
ziv@2218 336 Combo (Cnf, map (fn (field, v) => Atom (Sql.Eq, Sql.Field (table, field), v)) vals)
ziv@2218 337
ziv@2216 338 val rec dmlToFormula =
ziv@2221 339 fn Sql.Insert (table, vals) => valsToFormula (table, vals)
ziv@2218 340 | Sql.Delete (table, wher) => renameTables [(table, "T")] (sqexpToFormula wher)
ziv@2218 341 | Sql.Update (table, vals, wher) =>
ziv@2218 342 let
ziv@2221 343 val fWhere = sqexpToFormula wher
ziv@2221 344 val fVals = valsToFormula (table, vals)
ziv@2221 345 (* TODO: don't use field name hack. *)
ziv@2221 346 val markField =
ziv@2221 347 fn Sql.Field (t, v) => Sql.Field (t, v ^ "*")
ziv@2221 348 | e => e
ziv@2221 349 val mark = mapFormula (fn (cmp, e1, e2) => (cmp, markField e1, markField e2))
ziv@2218 350 in
ziv@2218 351 renameTables [(table, "T")]
ziv@2221 352 (Combo (Dnf, [Combo (Cnf, [fVals, mark fWhere]),
ziv@2221 353 Combo (Cnf, [mark fVals, fWhere])]))
ziv@2218 354 end
ziv@2213 355
ziv@2213 356 val rec tablesQuery =
ziv@2216 357 fn Sql.Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs)
ziv@2216 358 | Sql.Union (q1, q2) => SS.union (tablesQuery q1, tablesQuery q2)
ziv@2213 359
ziv@2213 360 val tableDml =
ziv@2216 361 fn Sql.Insert (tab, _) => tab
ziv@2216 362 | Sql.Delete (tab, _) => tab
ziv@2216 363 | Sql.Update (tab, _, _) => tab
ziv@2213 364
ziv@2213 365
ziv@2213 366 (* Program instrumentation. *)
ziv@2213 367
ziv@2215 368 fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), ErrorMsg.dummySpan)
ziv@2216 369
ziv@2213 370 val stringTyp = (TFfi ("Basis", "string"), ErrorMsg.dummySpan)
ziv@2213 371
ziv@2213 372 val sequence =
ziv@2213 373 fn (exp :: exps) =>
ziv@2213 374 let
ziv@2213 375 val loc = ErrorMsg.dummySpan
ziv@2213 376 in
ziv@2213 377 List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps
ziv@2213 378 end
ziv@2213 379 | _ => raise Match
ziv@2213 380
ziv@2227 381 (* TODO: factor out. *)
ziv@2213 382 fun ffiAppCache' (func, index, args) : Mono.exp' =
ziv@2213 383 EFfiApp ("Sqlcache", func ^ Int.toString index, args)
ziv@2213 384
ziv@2215 385 fun ffiAppCache (func, index, args) : Mono.exp =
ziv@2213 386 (ffiAppCache' (func, index, args), ErrorMsg.dummySpan)
ziv@2213 387
ziv@2213 388 val varPrefix = "queryResult"
ziv@2213 389
ziv@2213 390 fun indexOfName varName =
ziv@2213 391 if String.isPrefix varPrefix varName
ziv@2213 392 then Int.fromString (String.extract (varName, String.size varPrefix, NONE))
ziv@2213 393 else NONE
ziv@2213 394
ziv@2215 395 (* Always increments negative indices because that's what we need later. *)
ziv@2215 396 fun incRelsBound bound inc =
ziv@2215 397 MonoUtil.Exp.mapB
ziv@2215 398 {typ = fn x => x,
ziv@2215 399 exp = fn level =>
ziv@2215 400 (fn ERel n => ERel (if n >= level orelse n < 0 then n + inc else n)
ziv@2215 401 | x => x),
ziv@2215 402 bind = fn (level, MonoUtil.Exp.RelE _) => level + 1 | (level, _) => level}
ziv@2215 403 bound
ziv@2215 404
ziv@2215 405 val incRels = incRelsBound 0
ziv@2213 406
ziv@2223 407 fun cacheWrap (query, i, urlifiedRel0, resultTyp, args) =
ziv@2213 408 let
ziv@2223 409 val () = ffiInfo := {index = i, params = length args} :: !ffiInfo
ziv@2223 410 val loc = ErrorMsg.dummySpan
ziv@2223 411 (* We ensure before this step that all arguments aren't effectful.
ziv@2227 412 by turning them into local variables as needed. *)
ziv@2223 413 val argTyps = map (fn e => (e, stringTyp)) args
ziv@2223 414 val argTypsInc = map (fn (e, typ) => (incRels 1 e, typ)) argTyps
ziv@2223 415 val check = ffiAppCache ("check", i, argTyps)
ziv@2223 416 val store = ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argTypsInc)
ziv@2223 417 val rel0 = (ERel 0, loc)
ziv@2213 418 in
ziv@2223 419 ECase (check,
ziv@2223 420 [((PNone stringTyp, loc),
ziv@2223 421 (ELet ("q", resultTyp, query, (ESeq (store, rel0), loc)), loc)),
ziv@2223 422 ((PSome (stringTyp, (PVar ("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@2221 439 val loc = ErrorMsg.dummySpan
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@2227 463 List.foldl (fn (v, e') => ELet ("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@2223 489 ErrorMsg.dummySpan)
ziv@2215 490 val (EQuery {query = queryText, ...}, _) = queryExp
ziv@2221 491 val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText))
ziv@2221 492 val args = List.tabulate (numArgs, fn n => (ERel n, ErrorMsg.dummySpan))
ziv@2213 493 fun bind x f = Option.mapPartial f x
ziv@2215 494 fun guard b x = if b then x else NONE
ziv@2215 495 (* DEBUG: set first boolean argument to true to turn on printing. *)
ziv@2215 496 fun safe bound = not o effectful true (effectfulMap file) false bound
ziv@2213 497 val attempt =
ziv@2213 498 (* Ziv misses Haskell's do notation.... *)
ziv@2215 499 guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) (
ziv@2216 500 bind (Sql.parse Sql.query queryText) (fn queryParsed =>
ziv@2223 501 SOME (wrapLets (cacheWrap (queryExp, index, urlifiedRel0, resultTyp, args)),
ziv@2218 502 (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index))
ziv@2218 503 tableToIndices
ziv@2218 504 (tablesQuery queryParsed),
ziv@2223 505 IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)),
ziv@2223 506 index + 1))))
ziv@2213 507 in
ziv@2213 508 case attempt of
ziv@2213 509 SOME pair => pair
ziv@2213 510 | NONE => (e', queryInfo)
ziv@2213 511 end
ziv@2213 512 | e' => (e', queryInfo)
ziv@2213 513 in
ziv@2223 514 fileMapfold (fn exp => fn state => doExp state exp) file (SIMM.empty, IM.empty, 0)
ziv@2213 515 end
ziv@2213 516
ziv@2221 517 fun invalidations ((query, numArgs), dml) =
ziv@2216 518 let
ziv@2216 519 val loc = ErrorMsg.dummySpan
ziv@2218 520 val optionAtomExpToExp =
ziv@2216 521 fn NONE => (ENone stringTyp, loc)
ziv@2218 522 | SOME e => (ESome (stringTyp,
ziv@2218 523 (case e of
ziv@2218 524 DmlRel n => ERel n
ziv@2218 525 | Prim p => EPrim p
ziv@2218 526 (* TODO: make new type containing only these two. *)
ziv@2218 527 | _ => raise Match,
ziv@2218 528 loc)),
ziv@2218 529 loc)
ziv@2216 530 fun eqsToInvalidation eqs =
ziv@2216 531 let
ziv@2218 532 fun inv n = if n < 0 then [] else IM.find (eqs, n) :: inv (n - 1)
ziv@2216 533 in
ziv@2221 534 inv (numArgs - 1)
ziv@2216 535 end
ziv@2221 536 (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here
ziv@2221 537 represents unknown, which means a wider invalidation. *)
ziv@2218 538 val rec madeRedundantBy : atomExp option list * atomExp option list -> bool =
ziv@2218 539 fn ([], []) => true
ziv@2218 540 | (NONE :: xs, _ :: ys) => madeRedundantBy (xs, ys)
ziv@2218 541 | (SOME x :: xs, SOME y :: ys) => equalAtomExp (x, y) andalso madeRedundantBy (xs, ys)
ziv@2218 542 | _ => false
ziv@2218 543 fun removeRedundant' (xss, yss) =
ziv@2218 544 case xss of
ziv@2218 545 [] => yss
ziv@2218 546 | xs :: xss' =>
ziv@2218 547 removeRedundant' (xss',
ziv@2218 548 if List.exists (fn ys => madeRedundantBy (xs, ys)) (xss' @ yss)
ziv@2218 549 then yss
ziv@2218 550 else xs :: yss)
ziv@2218 551 fun removeRedundant xss = removeRedundant' (xss, [])
ziv@2218 552 val eqss = conflictMaps (queryToFormula query, dmlToFormula dml)
ziv@2216 553 in
ziv@2218 554 (map (map optionAtomExpToExp) o removeRedundant o map eqsToInvalidation) eqss
ziv@2216 555 end
ziv@2216 556
ziv@2223 557 fun addFlushing (file, (tableToIndices, indexToQueryNumArgs, _)) =
ziv@2213 558 let
ziv@2227 559 (* ASK: does this type actually matter? It was wrong before, but things
ziv@2227 560 still seemed to work. *)
ziv@2227 561 val optionStringTyp = (TOption stringTyp, ErrorMsg.dummySpan)
ziv@2221 562 val flushes = List.concat o
ziv@2221 563 map (fn (i, argss) =>
ziv@2221 564 map (fn args =>
ziv@2221 565 ffiAppCache' ("flush", i,
ziv@2227 566 map (fn arg => (arg, optionStringTyp))
ziv@2227 567 args))
ziv@2227 568 argss)
ziv@2213 569 val doExp =
ziv@2221 570 fn EDml (origDmlText, failureMode) =>
ziv@2213 571 let
ziv@2221 572 val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText
ziv@2221 573 val dmlText = incRels numArgs newDmlText
ziv@2221 574 val dmlExp = EDml (dmlText, failureMode)
ziv@2227 575 (* DEBUG: we can remove the following line at some point. *)
ziv@2221 576 val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty dmlText))
ziv@2221 577 val invs =
ziv@2216 578 case Sql.parse Sql.dml dmlText of
ziv@2218 579 SOME dmlParsed =>
ziv@2221 580 map (fn i => (case IM.find (indexToQueryNumArgs, i) of
ziv@2221 581 SOME queryNumArgs =>
ziv@2221 582 (i, invalidations (queryNumArgs, dmlParsed))
ziv@2221 583 (* TODO: fail more gracefully. *)
ziv@2221 584 | NONE => raise Match))
ziv@2221 585 (SIMM.findList (tableToIndices, tableDml dmlParsed))
ziv@2221 586 (* TODO: fail more gracefully. *)
ziv@2221 587 | NONE => raise Match
ziv@2213 588 in
ziv@2221 589 wrapLets (sequence (flushes invs @ [dmlExp]))
ziv@2213 590 end
ziv@2213 591 | e' => e'
ziv@2213 592 in
ziv@2213 593 fileMap doExp file
ziv@2213 594 end
ziv@2213 595
ziv@2221 596 val inlineSql =
ziv@2221 597 let
ziv@2221 598 val doExp =
ziv@2221 599 (* TODO: EQuery, too? *)
ziv@2221 600 (* ASK: should this live in [MonoOpt]? *)
ziv@2221 601 fn EDml ((ECase (disc, cases, {disc = dTyp, ...}), loc), failureMode) =>
ziv@2221 602 let
ziv@2221 603 val newCases = map (fn (p, e) => (p, (EDml (e, failureMode), loc))) cases
ziv@2221 604 in
ziv@2221 605 ECase (disc, newCases, {disc = dTyp, result = (TRecord [], loc)})
ziv@2221 606 end
ziv@2221 607 | e => e
ziv@2221 608 in
ziv@2221 609 fileMap doExp
ziv@2221 610 end
ziv@2221 611
ziv@2213 612 fun go file =
ziv@2213 613 let
ziv@2227 614 (* TODO: do something nicer than having Sql be in one of two modes. *)
ziv@2227 615 val () = (resetFfiInfo (); Sql.sqlcacheMode := true)
ziv@2221 616 val file' = addFlushing (addChecking (inlineSql file))
ziv@2215 617 val () = Sql.sqlcacheMode := false
ziv@2213 618 in
ziv@2221 619 file'
ziv@2213 620 end
ziv@2213 621
ziv@2209 622 end