Mercurial > urweb
comparison src/sqlcache.sml @ 2230:a749acc51ae4
Factor out cache implementation from Sqlcache.
author | Ziv Scully <ziv@mit.edu> |
---|---|
date | Wed, 06 May 2015 14:50:29 -0400 |
parents | adb49db02af4 |
children | af1585e7d645 |
comparison
equal
deleted
inserted
replaced
2229:54884b28b6c6 | 2230:a749acc51ae4 |
---|---|
41 | 41 |
42 | 42 |
43 (* Effect analysis. *) | 43 (* Effect analysis. *) |
44 | 44 |
45 (* Makes an exception for [EWrite] (which is recorded when caching). *) | 45 (* Makes an exception for [EWrite] (which is recorded when caching). *) |
46 fun effectful doPrint (effs : IS.set) (inFunction : bool) (bound : int) : Mono.exp -> bool = | 46 fun effectful doPrint (effs : IS.set) (inFunction : bool) (bound : int) : exp -> bool = |
47 (* If result is true, expression is definitely effectful. If result is | 47 (* If result is true, expression is definitely effectful. If result is |
48 false, then expression is definitely not effectful if effs is fully | 48 false, then expression is definitely not effectful if effs is fully |
49 populated. The intended pattern is to use this a number of times equal | 49 populated. The intended pattern is to use this a number of times equal |
50 to the number of declarations in a file, Bellman-Ford style. *) | 50 to the number of declarations in a file, Bellman-Ford style. *) |
51 (* TODO: make incrementing of bound less janky, probably by using [MonoUtil] | 51 (* TODO: make incrementing of bound less janky, probably by using [MonoUtil] |
180 | 180 |
181 fun mapFormula mf = | 181 fun mapFormula mf = |
182 fn Atom x => Atom (mf x) | 182 fn Atom x => Atom (mf x) |
183 | Negate f => Negate (mapFormula mf f) | 183 | Negate f => Negate (mapFormula mf f) |
184 | Combo (n, fs) => Combo (n, map (mapFormula mf) fs) | 184 | Combo (n, fs) => Combo (n, map (mapFormula mf) fs) |
185 | |
185 | 186 |
186 (* SQL analysis. *) | 187 (* SQL analysis. *) |
187 | 188 |
188 val rec chooseTwos : 'a list -> ('a * 'a) list = | 189 val rec chooseTwos : 'a list -> ('a * 'a) list = |
189 fn [] => [] | 190 fn [] => [] |
363 | Sql.Update (tab, _, _) => tab | 364 | Sql.Update (tab, _, _) => tab |
364 | 365 |
365 | 366 |
366 (* Program instrumentation. *) | 367 (* Program instrumentation. *) |
367 | 368 |
368 fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), ErrorMsg.dummySpan) | 369 val dummyLoc = ErrorMsg.dummySpan |
369 | 370 |
370 val stringTyp = (TFfi ("Basis", "string"), ErrorMsg.dummySpan) | 371 fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), dummyLoc) |
372 | |
373 val stringTyp = (TFfi ("Basis", "string"), dummyLoc) | |
371 | 374 |
372 val sequence = | 375 val sequence = |
373 fn (exp :: exps) => | 376 fn (exp :: exps) => |
374 let | 377 let |
375 val loc = ErrorMsg.dummySpan | 378 val loc = dummyLoc |
376 in | 379 in |
377 List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps | 380 List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps |
378 end | 381 end |
379 | _ => raise Match | 382 | _ => raise Match |
380 | |
381 (* TODO: factor out. *) | |
382 fun ffiAppCache' (func, index, args) : Mono.exp' = | |
383 EFfiApp ("Sqlcache", func ^ Int.toString index, args) | |
384 | |
385 fun ffiAppCache (func, index, args) : Mono.exp = | |
386 (ffiAppCache' (func, index, args), ErrorMsg.dummySpan) | |
387 | |
388 val varPrefix = "queryResult" | |
389 | |
390 fun indexOfName varName = | |
391 if String.isPrefix varPrefix varName | |
392 then Int.fromString (String.extract (varName, String.size varPrefix, NONE)) | |
393 else NONE | |
394 | 383 |
395 (* Always increments negative indices because that's what we need later. *) | 384 (* Always increments negative indices because that's what we need later. *) |
396 fun incRelsBound bound inc = | 385 fun incRelsBound bound inc = |
397 MonoUtil.Exp.mapB | 386 MonoUtil.Exp.mapB |
398 {typ = fn x => x, | 387 {typ = fn x => x, |
405 val incRels = incRelsBound 0 | 394 val incRels = incRelsBound 0 |
406 | 395 |
407 fun cacheWrap (query, i, urlifiedRel0, resultTyp, args) = | 396 fun cacheWrap (query, i, urlifiedRel0, resultTyp, args) = |
408 let | 397 let |
409 val () = ffiInfo := {index = i, params = length args} :: !ffiInfo | 398 val () = ffiInfo := {index = i, params = length args} :: !ffiInfo |
410 val loc = ErrorMsg.dummySpan | 399 val loc = dummyLoc |
411 (* We ensure before this step that all arguments aren't effectful. | 400 (* We ensure before this step that all arguments aren't effectful. |
412 by turning them into local variables as needed. *) | 401 by turning them into local variables as needed. *) |
413 val argTyps = map (fn e => (e, stringTyp)) args | 402 val argsInc = map (incRels 1) args |
414 val argTypsInc = map (fn (e, typ) => (incRels 1 e, typ)) argTyps | 403 val check = (ToyCache.check (i, args), dummyLoc) |
415 val check = ffiAppCache ("check", i, argTyps) | 404 val store = (ToyCache.store (i, argsInc, urlifiedRel0), dummyLoc) |
416 val store = ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argTypsInc) | |
417 val rel0 = (ERel 0, loc) | 405 val rel0 = (ERel 0, loc) |
418 in | 406 in |
419 ECase (check, | 407 ECase (check, |
420 [((PNone stringTyp, loc), | 408 [((PNone stringTyp, loc), |
421 (ELet ("q", resultTyp, query, (ESeq (store, rel0), loc)), loc)), | 409 (ELet ("q", resultTyp, query, (ESeq (store, rel0), loc)), loc)), |
434 | 422 |
435 fun fileMap doExp file = #1 (fileMapfold (fn x => fn _ => (doExp x, ())) file ()) | 423 fun fileMap doExp file = #1 (fileMapfold (fn x => fn _ => (doExp x, ())) file ()) |
436 | 424 |
437 fun factorOutNontrivial text = | 425 fun factorOutNontrivial text = |
438 let | 426 let |
439 val loc = ErrorMsg.dummySpan | 427 val loc = dummyLoc |
440 fun strcat (e1, e2) = (EStrcat (e1, e2), loc) | 428 fun strcat (e1, e2) = (EStrcat (e1, e2), loc) |
441 val chunks = Sql.chunkify text | 429 val chunks = Sql.chunkify text |
442 val (newText, newVariables) = | 430 val (newText, newVariables) = |
443 (* Important that this is foldr (to oppose foldl below). *) | 431 (* Important that this is foldr (to oppose foldl below). *) |
444 List.foldr | 432 List.foldr |
484 state = resultTyp, | 472 state = resultTyp, |
485 initial = initial, | 473 initial = initial, |
486 body = body, | 474 body = body, |
487 tables = tables, | 475 tables = tables, |
488 exps = exps}, | 476 exps = exps}, |
489 ErrorMsg.dummySpan) | 477 dummyLoc) |
490 val (EQuery {query = queryText, ...}, _) = queryExp | 478 val (EQuery {query = queryText, ...}, _) = queryExp |
491 val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText)) | 479 val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText)) |
492 val args = List.tabulate (numArgs, fn n => (ERel n, ErrorMsg.dummySpan)) | 480 val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc)) |
493 fun bind x f = Option.mapPartial f x | 481 fun bind x f = Option.mapPartial f x |
494 fun guard b x = if b then x else NONE | 482 fun guard b x = if b then x else NONE |
495 (* DEBUG: set first boolean argument to true to turn on printing. *) | 483 (* DEBUG: set first boolean argument to true to turn on printing. *) |
496 fun safe bound = not o effectful true (effectfulMap file) false bound | 484 fun safe bound = not o effectful true (effectfulMap file) false bound |
497 val attempt = | 485 val attempt = |
514 fileMapfold (fn exp => fn state => doExp state exp) file (SIMM.empty, IM.empty, 0) | 502 fileMapfold (fn exp => fn state => doExp state exp) file (SIMM.empty, IM.empty, 0) |
515 end | 503 end |
516 | 504 |
517 fun invalidations ((query, numArgs), dml) = | 505 fun invalidations ((query, numArgs), dml) = |
518 let | 506 let |
519 val loc = ErrorMsg.dummySpan | 507 val loc = dummyLoc |
520 val optionAtomExpToExp = | 508 val optionAtomExpToExp = |
521 fn NONE => (ENone stringTyp, loc) | 509 fn NONE => (ENone stringTyp, loc) |
522 | SOME e => (ESome (stringTyp, | 510 | SOME e => (ESome (stringTyp, |
523 (case e of | 511 (case e of |
524 DmlRel n => ERel n | 512 DmlRel n => ERel n |
554 (map (map optionAtomExpToExp) o removeRedundant o map eqsToInvalidation) eqss | 542 (map (map optionAtomExpToExp) o removeRedundant o map eqsToInvalidation) eqss |
555 end | 543 end |
556 | 544 |
557 fun addFlushing (file, (tableToIndices, indexToQueryNumArgs, _)) = | 545 fun addFlushing (file, (tableToIndices, indexToQueryNumArgs, _)) = |
558 let | 546 let |
559 (* ASK: does this type actually matter? It was wrong before, but things | |
560 still seemed to work. *) | |
561 val optionStringTyp = (TOption stringTyp, ErrorMsg.dummySpan) | |
562 val flushes = List.concat o | 547 val flushes = List.concat o |
563 map (fn (i, argss) => | 548 map (fn (i, argss) => map (fn args => ToyCache.flush (i, args)) argss) |
564 map (fn args => | |
565 ffiAppCache' ("flush", i, | |
566 map (fn arg => (arg, optionStringTyp)) | |
567 args)) | |
568 argss) | |
569 val doExp = | 549 val doExp = |
570 fn EDml (origDmlText, failureMode) => | 550 fn EDml (origDmlText, failureMode) => |
571 let | 551 let |
572 val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText | 552 val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText |
573 val dmlText = incRels numArgs newDmlText | 553 val dmlText = incRels numArgs newDmlText |