Mercurial > urweb

annotate src/sqlcache.sml @ 2213:365727ff68f4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Complete overhaul: cache queries based on immediate query result, not eventual HTML output.
author Ziv Scully <ziv@mit.edu>
date Tue, 14 Oct 2014 18:05:09 -0400
parents 388ba4dc7c96
children 639e62ca2530
rev   line source
ziv@2213 1 structure Sqlcache (* :> SQLCACHE *) = struct
ziv@2209 2
ziv@2209 3 open Sql
ziv@2209 4 open Mono
ziv@2209 5
ziv@2209 6 structure IS = IntBinarySet
ziv@2209 7 structure IM = IntBinaryMap
ziv@2213 8 structure SK = struct type ord_key = string val compare = String.compare end
ziv@2213 9 structure SS = BinarySetFn(SK)
ziv@2213 10 structure SM = BinaryMapFn(SK)
ziv@2213 11 structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS)
ziv@2209 12
ziv@2213 13 (* Filled in by cacheWrap during Sqlcache. *)
ziv@2213 14 val ffiInfo : {index : int, params : int} list ref = ref []
ziv@2209 15
ziv@2213 16 fun getFfiInfo () = !ffiInfo
ziv@2213 17
ziv@2213 18 (* Program analysis. *)
ziv@2213 19
ziv@2213 20 val useInjIfPossible =
ziv@2213 21 fn SqConst prim => Inj (EPrim (Prim.String (Prim.Normal, Prim.toString prim)), ErrorMsg.dummySpan)
ziv@2213 22 | sqexp => sqexp
ziv@2213 23
ziv@2213 24 fun equalities (canonicalTable : string -> string) :
ziv@2213 25 sqexp -> ((string * string) * Mono.exp) list option =
ziv@2213 26 let
ziv@2213 27 val rec eqs =
ziv@2213 28 fn Binop (Exps f, e1, e2) =>
ziv@2213 29 (* TODO: use a custom datatype in Exps instead of a function. *)
ziv@2213 30 (case f (Var 1, Var 2) of
ziv@2213 31 Reln (Eq, [Var 1, Var 2]) =>
ziv@2213 32 let
ziv@2213 33 val (e1', e2') = (useInjIfPossible e1, useInjIfPossible e2)
ziv@2213 34 in
ziv@2213 35 case (e1', e2') of
ziv@2213 36 (Field (t, f), Inj i) => SOME [((canonicalTable t, f), i)]
ziv@2213 37 | (Inj i, Field (t, f)) => SOME [((canonicalTable t, f), i)]
ziv@2213 38 | _ => NONE
ziv@2213 39 end
ziv@2213 40 | _ => NONE)
ziv@2213 41 | Binop (Props f, e1, e2) =>
ziv@2213 42 (* TODO: use a custom datatype in Props instead of a function. *)
ziv@2213 43 (case f (True, False) of
ziv@2213 44 And (True, False) =>
ziv@2213 45 (case (eqs e1, eqs e2) of
ziv@2213 46 (SOME eqs1, SOME eqs2) => SOME (eqs1 @ eqs2)
ziv@2213 47 | _ => NONE)
ziv@2213 48 | _ => NONE)
ziv@2213 49 | _ => NONE
ziv@2213 50 in
ziv@2213 51 eqs
ziv@2213 52 end
ziv@2213 53
ziv@2213 54 val equalitiesQuery =
ziv@2213 55 fn Query1 {From = tablePairs, Where = SOME exp, ...} =>
ziv@2213 56 equalities
ziv@2213 57 (* If we have [SELECT ... FROM T AS T' ...], use T, not T'. *)
ziv@2213 58 (fn t =>
ziv@2213 59 case List.find (fn (_, tAs) => t = tAs) tablePairs of
ziv@2213 60 NONE => t
ziv@2213 61 | SOME (tOrig, _) => tOrig)
ziv@2213 62 exp
ziv@2213 63 | Query1 {Where = NONE, ...} => SOME []
ziv@2213 64 | _ => NONE
ziv@2213 65
ziv@2213 66 val equalitiesDml =
ziv@2213 67 fn Insert (tab, eqs) => SOME (List.mapPartial
ziv@2213 68 (fn (name, sqexp) =>
ziv@2213 69 case useInjIfPossible sqexp of
ziv@2213 70 Inj e => SOME ((tab, name), e)
ziv@2213 71 | _ => NONE)
ziv@2213 72 eqs)
ziv@2213 73 | Delete (tab, exp) => equalities (fn _ => tab) exp
ziv@2213 74 (* TODO: examine the updated values and not just the way they're filtered. *)
ziv@2213 75 (* For example, UPDATE foo SET Id = 9001 WHERE Id = 42 should update both the
ziv@2213 76 Id = 42 and Id = 9001 cache entries. Could also think of it as doing a
ziv@2213 77 Delete immediately followed by an Insert. *)
ziv@2213 78 | Update (tab, _, exp) => equalities (fn _ => tab) exp
ziv@2213 79
ziv@2213 80 val rec tablesQuery =
ziv@2213 81 fn Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs)
ziv@2213 82 | Union (q1, q2) => SS.union (tablesQuery q1, tablesQuery q2)
ziv@2213 83
ziv@2213 84 val tableDml =
ziv@2213 85 fn Insert (tab, _) => tab
ziv@2213 86 | Delete (tab, _) => tab
ziv@2213 87 | Update (tab, _, _) => tab
ziv@2213 88
ziv@2213 89
ziv@2213 90 (* Program instrumentation. *)
ziv@2213 91
ziv@2213 92 val stringTyp = (TFfi ("Basis", "string"), ErrorMsg.dummySpan)
ziv@2213 93
ziv@2213 94 val sequence =
ziv@2213 95 fn (exp :: exps) =>
ziv@2213 96 let
ziv@2213 97 val loc = ErrorMsg.dummySpan
ziv@2213 98 in
ziv@2213 99 List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps
ziv@2213 100 end
ziv@2213 101 | _ => raise Match
ziv@2213 102
ziv@2213 103 fun ffiAppCache' (func, index, args) : Mono.exp' =
ziv@2213 104 EFfiApp ("Sqlcache", func ^ Int.toString index, args)
ziv@2213 105
ziv@2213 106 fun ffiAppCache (func, index, args) : Mono. exp =
ziv@2213 107 (ffiAppCache' (func, index, args), ErrorMsg.dummySpan)
ziv@2213 108
ziv@2213 109 val varPrefix = "queryResult"
ziv@2213 110
ziv@2213 111 fun indexOfName varName =
ziv@2213 112 if String.isPrefix varPrefix varName
ziv@2213 113 then Int.fromString (String.extract (varName, String.size varPrefix, NONE))
ziv@2213 114 else NONE
ziv@2213 115
ziv@2213 116 val incRels = MonoUtil.Exp.map {typ = fn x => x, exp = fn ERel n => ERel (n + 1) | x => x}
ziv@2213 117
ziv@2213 118 (* Filled in by instrumentQuery during Monoize, used during Sqlcache. *)
ziv@2213 119 val urlifiedRel0s : Mono.exp IM.map ref = ref IM.empty
ziv@2213 120
ziv@2213 121 (* Used by Monoize. *)
ziv@2213 122 val instrumentQuery =
ziv@2213 123 let
ziv@2213 124 val nextQuery = ref 0
ziv@2213 125 fun iq (query, urlifiedRel0) =
ziv@2213 126 case query of
ziv@2213 127 (EQuery {state = typ, ...}, loc) =>
ziv@2213 128 let
ziv@2213 129 val i = !nextQuery before nextQuery := !nextQuery + 1
ziv@2213 130 in
ziv@2213 131 urlifiedRel0s := IM.insert (!urlifiedRel0s, i, urlifiedRel0);
ziv@2213 132 (* ASK: name variables properly? *)
ziv@2213 133 (ELet (varPrefix ^ Int.toString i, typ, query,
ziv@2213 134 (* Uses a dummy FFI call to keep the urlified expression around, which
ziv@2213 135 in turn keeps the declarations required for urlification safe from
ziv@2213 136 MonoShake. The dummy call is removed during Sqlcache. *)
ziv@2213 137 (* ASK: is there a better way? *)
ziv@2213 138 (ESeq ((EFfiApp ("Sqlcache", "dummy", [(urlifiedRel0, stringTyp)]), loc),
ziv@2213 139 (ERel 0, loc)),
ziv@2213 140 loc)),
ziv@2213 141 loc)
ziv@2213 142 end
ziv@2213 143 | _ => raise Match
ziv@2213 144 in
ziv@2213 145 iq
ziv@2213 146 end
ziv@2213 147
ziv@2213 148 val gunk : ((string * string) * Mono.exp) list list ref = ref [[]]
ziv@2213 149
ziv@2213 150 fun cacheWrap (query, i, urlifiedRel0, eqs) =
ziv@2213 151 case query of
ziv@2213 152 (EQuery {state = typ, ...}, _) =>
ziv@2213 153 let
ziv@2213 154 val loc = ErrorMsg.dummySpan
ziv@2213 155 (* TODO: deal with effectful injected expressions. *)
ziv@2213 156 val args = (ffiInfo := {index = i, params = length eqs} :: !ffiInfo;
ziv@2213 157 map (fn (_, e) => (e, stringTyp)) eqs) before gunk := eqs :: !gunk
ziv@2213 158 val argsInc = map (fn (e, t) => (incRels e, t)) args
ziv@2213 159 in
ziv@2213 160 (ECase (ffiAppCache ("check", i, args),
ziv@2213 161 [((PNone stringTyp, loc),
ziv@2213 162 (ELet ("q", typ, query,
ziv@2213 163 (ESeq (ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argsInc),
ziv@2213 164 (ERel 0, loc)),
ziv@2213 165 loc)),
ziv@2213 166 loc)),
ziv@2213 167 ((PSome (stringTyp, (PVar ("hit", stringTyp), loc)), loc),
ziv@2213 168 (* ASK: what does this bool do? *)
ziv@2213 169 (EUnurlify ((ERel 0, loc), typ, false), loc))],
ziv@2213 170 {disc = stringTyp, result = typ}),
ziv@2213 171 loc)
ziv@2213 172 end
ziv@2213 173 | _ => raise Match
ziv@2213 174
ziv@2213 175 fun fileMapfold doExp file start =
ziv@2213 176 case MonoUtil.File.mapfold {typ = Search.return2,
ziv@2213 177 exp = fn x => (fn s => Search.Continue (doExp x s)),
ziv@2213 178 decl = Search.return2} file start of
ziv@2213 179 Search.Continue x => x
ziv@2213 180 | Search.Return _ => raise Match
ziv@2213 181
ziv@2213 182 fun fileMap doExp file = #1 (fileMapfold (fn x => fn _ => (doExp x, ())) file ())
ziv@2213 183
ziv@2213 184 val addChecking =
ziv@2213 185 let
ziv@2213 186 fun doExp queryInfo =
ziv@2213 187 fn e' as ELet (v, t, queryExp as (EQuery {query = queryText, ...}, _), body) =>
ziv@2213 188 let
ziv@2213 189 fun bind x f = Option.mapPartial f x
ziv@2213 190 val attempt =
ziv@2213 191 (* Ziv misses Haskell's do notation.... *)
ziv@2213 192 bind (parse query queryText) (fn queryParsed =>
ziv@2213 193 (Print.preface ("gunk> ", (MonoPrint.p_exp MonoEnv.empty queryExp));
ziv@2213 194 bind (indexOfName v) (fn i =>
ziv@2213 195 bind (equalitiesQuery queryParsed) (fn eqs =>
ziv@2213 196 bind (IM.find (!urlifiedRel0s, i)) (fn urlifiedRel0 =>
ziv@2213 197 SOME (ELet (v, t, cacheWrap (queryExp, i, urlifiedRel0, eqs), body),
ziv@2213 198 SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, i))
ziv@2213 199 queryInfo
ziv@2213 200 (tablesQuery queryParsed)))))))
ziv@2213 201 in
ziv@2213 202 case attempt of
ziv@2213 203 SOME pair => pair
ziv@2213 204 | NONE => (e', queryInfo)
ziv@2213 205 end
ziv@2213 206 | ESeq ((EFfiApp ("Sqlcache", "dummy", _), _), (e', _)) => (e', queryInfo)
ziv@2213 207 | e' => (e', queryInfo)
ziv@2213 208 in
ziv@2213 209 fn file => fileMapfold (fn exp => fn state => doExp state exp) file SIMM.empty
ziv@2213 210 end
ziv@2213 211
ziv@2213 212 fun addFlushing (file, queryInfo) =
ziv@2213 213 let
ziv@2213 214 val allIndices : int list = SM.foldr (fn (x, acc) => IS.listItems x @ acc) [] queryInfo
ziv@2213 215 fun flushes indices = map (fn i => ffiAppCache' ("flush", i, [])) indices
ziv@2213 216 val doExp =
ziv@2213 217 fn dmlExp as EDml (dmlText, _) =>
ziv@2213 218 let
ziv@2213 219 val indices =
ziv@2213 220 case parse dml dmlText of
ziv@2213 221 SOME dmlParsed => SIMM.findList (queryInfo, tableDml dmlParsed)
ziv@2213 222 | NONE => allIndices
ziv@2213 223 in
ziv@2213 224 sequence (flushes indices @ [dmlExp])
ziv@2213 225 end
ziv@2213 226 | e' => e'
ziv@2213 227 in
ziv@2213 228 fileMap doExp file
ziv@2213 229 end
ziv@2213 230
ziv@2213 231 fun go file =
ziv@2213 232 let
ziv@2213 233 val () = Sql.sqlcacheMode := true
ziv@2213 234 in
ziv@2213 235 addFlushing (addChecking file) before Sql.sqlcacheMode := false
ziv@2213 236 end
ziv@2213 237
ziv@2213 238
ziv@2213 239 (* BEGIN OLD
ziv@2212 240
ziv@2212 241 fun intExp (n, loc) = (EPrim (Prim.Int (Int64.fromInt n)), loc)
ziv@2212 242 fun intTyp loc = (TFfi ("Basis", "int"), loc)
ziv@2213 243 fun stringExp (s, loc) = (EPrim (Prim.String (Prim.Normal, s)), loc)
ziv@2213 244
ziv@2212 245 fun boolPat (b, loc) = (PCon (Enum,
ziv@2212 246 PConFfi {mod = "Basis", datatyp = "bool", arg = NONE,
ziv@2212 247 con = if b then "True" else "False"},
ziv@2212 248 NONE),
ziv@2212 249 loc)
ziv@2212 250 fun boolTyp loc = (TFfi ("Basis", "int"), loc)
ziv@2212 251
ziv@2213 252 fun ffiAppExp (module, func, index, args, loc) =
ziv@2213 253 (EFfiApp (module, func ^ Int.toString index, args), loc)
ziv@2212 254
ziv@2213 255 val sequence =
ziv@2213 256 fn ((exp :: exps), loc) =>
ziv@2212 257 List.foldl (fn (exp, seq) => (ESeq (seq, exp), loc)) exp exps
ziv@2213 258 | _ => raise Match
ziv@2212 259
ziv@2212 260 fun antiguardUnit (cond, exp, loc) =
ziv@2212 261 (ECase (cond,
ziv@2212 262 [(boolPat (false, loc), exp),
ziv@2212 263 (boolPat (true, loc), (ERecord [], loc))],
ziv@2212 264 {disc = boolTyp loc, result = (TRecord [], loc)}),
ziv@2212 265 loc)
ziv@2212 266
ziv@2212 267 fun underAbs f (exp as (exp', loc)) =
ziv@2212 268 case exp' of
ziv@2212 269 EAbs (x, y, z, body) => (EAbs (x, y, z, underAbs f body), loc)
ziv@2212 270 | _ => f exp
ziv@2212 271
ziv@2212 272
ziv@2209 273 val rec tablesRead =
ziv@2213 274 fn Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs)
ziv@2213 275 | Union (q1, q2) => SS.union (tablesRead q1, tablesRead q2)
ziv@2209 276
ziv@2209 277 val tableWritten =
ziv@2209 278 fn Insert (tab, _) => tab
ziv@2209 279 | Delete (tab, _) => tab
ziv@2209 280 | Update (tab, _, _) => tab
ziv@2209 281
ziv@2209 282 fun tablesInExp' exp' =
ziv@2209 283 let
ziv@2209 284 val nothing = {read = SS.empty, written = SS.empty}
ziv@2209 285 in
ziv@2209 286 case exp' of
ziv@2213 287 EQuery {query = e, ...} =>
ziv@2209 288 (case parse query e of
ziv@2209 289 SOME q => {read = tablesRead q, written = SS.empty}
ziv@2209 290 | NONE => nothing)
ziv@2209 291 | EDml (e, _) =>
ziv@2209 292 (case parse dml e of
ziv@2209 293 SOME q => {read = SS.empty, written = SS.singleton (tableWritten q)}
ziv@2209 294 | NONE => nothing)
ziv@2209 295 | _ => nothing
ziv@2209 296 end
ziv@2209 297
ziv@2209 298 val tablesInExp =
ziv@2209 299 let
ziv@2209 300 fun addTables (exp', {read, written}) =
ziv@2213 301 let
ziv@2213 302 val {read = r, written = w} = tablesInExp' exp'
ziv@2213 303 in
ziv@2213 304 {read = SS.union (r, read), written = SS.union (w, written)}
ziv@2213 305 end
ziv@2209 306 in
ziv@2209 307 MonoUtil.Exp.fold {typ = #2, exp = addTables}
ziv@2209 308 {read = SS.empty, written = SS.empty}
ziv@2209 309 end
ziv@2209 310
ziv@2209 311 fun addCacheCheck (index, exp) =
ziv@2209 312 let
ziv@2209 313 fun f (body as (_, loc)) =
ziv@2209 314 let
ziv@2209 315 val check = ffiAppExp ("Cache", "check", index, loc)
ziv@2209 316 val store = ffiAppExp ("Cache", "store", index, loc)
ziv@2209 317 in
ziv@2212 318 antiguardUnit (check, sequence ([body, store], loc), loc)
ziv@2209 319 end
ziv@2209 320 in
ziv@2209 321 underAbs f exp
ziv@2209 322 end
ziv@2209 323
ziv@2209 324 fun addCacheFlush (exp, tablesToIndices) =
ziv@2209 325 let
ziv@2209 326 fun addIndices (table, indices) = IS.union (indices, SIMM.find (tablesToIndices, table))
ziv@2209 327 fun f (body as (_, loc)) =
ziv@2209 328 let
ziv@2209 329 fun mapFfi func = List.map (fn i => ffiAppExp ("Cache", func, i, loc))
ziv@2209 330 val flushes =
ziv@2209 331 IS.listItems (SS.foldr addIndices IS.empty (#written (tablesInExp body)))
ziv@2209 332 in
ziv@2212 333 sequence (mapFfi "flush" flushes @ [body] @ mapFfi "ready" flushes, loc)
ziv@2209 334 end
ziv@2209 335 in
ziv@2209 336 underAbs f exp
ziv@2209 337 end
ziv@2209 338
ziv@2209 339 val handlerIndices =
ziv@2209 340 let
ziv@2209 341 val isUnit =
ziv@2209 342 fn (TRecord [], _) => true
ziv@2209 343 | _ => false
ziv@2209 344 fun maybeAdd (d, soFar as {readers, writers}) =
ziv@2209 345 case d of
ziv@2209 346 DExport (Link ReadOnly, _, name, typs, typ, _) =>
ziv@2209 347 if List.all isUnit (typ::typs)
ziv@2209 348 then {readers = IS.add (readers, name), writers = writers}
ziv@2209 349 else soFar
ziv@2209 350 | DExport (_, _, name, _, _, _) => (* Not read only. *)
ziv@2209 351 {readers = readers, writers = IS.add (writers, name)}
ziv@2209 352 | _ => soFar
ziv@2209 353 in
ziv@2209 354 MonoUtil.File.fold {typ = #2, exp = #2, decl = maybeAdd}
ziv@2209 355 {readers = IS.empty, writers = IS.empty}
ziv@2209 356 end
ziv@2209 357
ziv@2209 358 fun fileFoldMapiSelected f init (file, indices) =
ziv@2209 359 let
ziv@2209 360 fun doExp (original as ((a, index, b, exp, c), state)) =
ziv@2209 361 if IS.member (indices, index)
ziv@2209 362 then let val (newExp, newState) = f (index, exp, state)
ziv@2209 363 in ((a, index, b, newExp, c), newState) end
ziv@2209 364 else original
ziv@2209 365 fun doDecl decl state =
ziv@2209 366 let
ziv@2209 367 val result =
ziv@2209 368 case decl of
ziv@2209 369 DVal x =>
ziv@2209 370 let val (y, newState) = doExp (x, state)
ziv@2209 371 in (DVal y, newState) end
ziv@2209 372 | DValRec xs =>
ziv@2209 373 let val (ys, newState) = ListUtil.foldlMap doExp state xs
ziv@2209 374 in (DValRec ys, newState) end
ziv@2209 375 | _ => (decl, state)
ziv@2209 376 in
ziv@2209 377 Search.Continue result
ziv@2209 378 end
ziv@2209 379 fun nada x y = Search.Continue (x, y)
ziv@2209 380 in
ziv@2209 381 case MonoUtil.File.mapfold {typ = nada, exp = nada, decl = doDecl} file init of
ziv@2209 382 Search.Continue x => x
ziv@2213 383 | _ => raise Match (* Should never happen. *)
ziv@2209 384 end
ziv@2209 385
ziv@2209 386 fun fileMapSelected f = #1 o fileFoldMapiSelected (fn (_, x, _) => (f x, ())) ()
ziv@2209 387
ziv@2209 388 val addCacheChecking =
ziv@2209 389 let
ziv@2209 390 fun f (index, exp, tablesToIndices) =
ziv@2209 391 (addCacheCheck (index, exp),
ziv@2209 392 SS.foldr (fn (table, tsToIs) => SIMM.insert (tsToIs, table, index))
ziv@2209 393 tablesToIndices
ziv@2209 394 (#read (tablesInExp exp)))
ziv@2209 395 in
ziv@2209 396 fileFoldMapiSelected f (SM.empty)
ziv@2209 397 end
ziv@2209 398
ziv@2209 399 fun addCacheFlushing (file, tablesToIndices, writers) =
ziv@2209 400 fileMapSelected (fn exp => addCacheFlush (exp, tablesToIndices)) (file, writers)
ziv@2209 401
ziv@2209 402 fun go file =
ziv@2209 403 let
ziv@2209 404 val {readers, writers} = handlerIndices file
ziv@2209 405 val (fileWithChecks, tablesToIndices) = addCacheChecking (file, readers)
ziv@2209 406 in
ziv@2209 407 ffiIndices := IS.listItems readers;
ziv@2209 408 addCacheFlushing (fileWithChecks, tablesToIndices, writers)
ziv@2209 409 end
ziv@2209 410
ziv@2213 411 END OLD *)
ziv@2213 412
ziv@2209 413 end