Mercurial > urweb
comparison src/sqlcache.sml @ 2223:9410959d296f
Remove Sqlcache urlification hack.
author | Ziv Scully <ziv@mit.edu> |
---|---|
date | Sat, 29 Nov 2014 04:34:41 -0500 |
parents | 278e10629ba1 |
children | adb49db02af4 |
comparison
equal
deleted
inserted
replaced
2222:4d967a4ddb82 | 2223:9410959d296f |
---|---|
14 | 14 |
15 fun getFfiInfo () = !ffiInfo | 15 fun getFfiInfo () = !ffiInfo |
16 | 16 |
17 (* Some FFIs have writing as their only effect, which the caching records. *) | 17 (* Some FFIs have writing as their only effect, which the caching records. *) |
18 val ffiEffectful = | 18 val ffiEffectful = |
19 (* TODO: have this less hard-coded. *) | 19 (* ASK: how can this be less hard-coded? *) |
20 let | 20 let |
21 val fs = SS.fromList ["htmlifyInt_w", | 21 val fs = SS.fromList ["htmlifyInt_w", |
22 "htmlifyFloat_w", | 22 "htmlifyFloat_w", |
23 "htmlifyString_w", | 23 "htmlifyString_w", |
24 "htmlifyBool_w", | 24 "htmlifyBool_w", |
44 fun effectful doPrint (effs : IS.set) (inFunction : bool) (bound : int) : Mono.exp -> bool = | 44 fun effectful doPrint (effs : IS.set) (inFunction : bool) (bound : int) : Mono.exp -> bool = |
45 (* If result is true, expression is definitely effectful. If result is | 45 (* If result is true, expression is definitely effectful. If result is |
46 false, then expression is definitely not effectful if effs is fully | 46 false, then expression is definitely not effectful if effs is fully |
47 populated. The intended pattern is to use this a number of times equal | 47 populated. The intended pattern is to use this a number of times equal |
48 to the number of declarations in a file, Bellman-Ford style. *) | 48 to the number of declarations in a file, Bellman-Ford style. *) |
49 (* TODO: make incrementing of bound less janky, probably by using MonoUtil | 49 (* TODO: make incrementing of bound less janky, probably by using [MonoUtil] |
50 instead of all this. *) | 50 instead of all this. *) |
51 let | 51 let |
52 (* DEBUG: remove printing when done. *) | 52 (* DEBUG: remove printing when done. *) |
53 fun tru msg = if doPrint then (print (msg ^ "\n"); true) else true | 53 fun tru msg = if doPrint then (print (msg ^ "\n"); true) else true |
54 val rec eff' = | 54 val rec eff' = |
251 | _ => NONE) | 251 | _ => NONE) |
252 | ((QueryArg n, Prim p), SOME eqs) => SOME (addToEqs (eqs, n, Prim p)) | 252 | ((QueryArg n, Prim p), SOME eqs) => SOME (addToEqs (eqs, n, Prim p)) |
253 | ((QueryArg n, DmlRel r), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r)) | 253 | ((QueryArg n, DmlRel r), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r)) |
254 | ((Prim p, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, Prim p)) | 254 | ((Prim p, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, Prim p)) |
255 | ((DmlRel r, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r)) | 255 | ((DmlRel r, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r)) |
256 (* TODO: deal with equalities involving just [DmlRel]s and [Prim]s. *) | 256 (* TODO: deal with equalities involving just [DmlRel]s and [Prim]s. |
257 This would involve guarding the invalidation with a check for the | |
258 relevant comparisons. *) | |
257 | (_, eqso) => eqso | 259 | (_, eqso) => eqso |
258 val eqsOfClass : atomExp list -> atomExp IM.map option = | 260 val eqsOfClass : atomExp list -> atomExp IM.map option = |
259 List.foldl accumulateEqs (SOME IM.empty) | 261 List.foldl accumulateEqs (SOME IM.empty) |
260 o chooseTwos | 262 o chooseTwos |
261 fun toAtomExps rel (cmp, e1, e2) = | 263 fun toAtomExps rel (cmp, e1, e2) = |
293 List.foldr (fn (SOME eqs, SOME acc) => SOME (IM.unionWith #1 (eqs, acc)) | _ => NONE) | 295 List.foldr (fn (SOME eqs, SOME acc) => SOME (IM.unionWith #1 (eqs, acc)) | _ => NONE) |
294 (SOME IM.empty) | 296 (SOME IM.empty) |
295 fun dnf (fQuery, fDml) = | 297 fun dnf (fQuery, fDml) = |
296 normalize negateCmp Dnf (Combo (Cnf, [markQuery fQuery, markDml fDml])) | 298 normalize negateCmp Dnf (Combo (Cnf, [markQuery fQuery, markDml fDml])) |
297 in | 299 in |
298 (* val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula *) | |
299 (* * (Sql.cmp * Sql.sqexp * Sql.sqexp) formula *) | |
300 (* -> atomExp IM.map list = *) | |
301 List.mapPartial (mergeEqs o map eqsOfClass o equivClasses) o dnf | 300 List.mapPartial (mergeEqs o map eqsOfClass o equivClasses) o dnf |
302 end | 301 end |
303 | 302 |
304 val rec sqexpToFormula = | 303 val rec sqexpToFormula = |
305 fn Sql.SqTrue => Combo (Cnf, []) | 304 fn Sql.SqTrue => Combo (Cnf, []) |
400 bind = fn (level, MonoUtil.Exp.RelE _) => level + 1 | (level, _) => level} | 399 bind = fn (level, MonoUtil.Exp.RelE _) => level + 1 | (level, _) => level} |
401 bound | 400 bound |
402 | 401 |
403 val incRels = incRelsBound 0 | 402 val incRels = incRelsBound 0 |
404 | 403 |
405 (* Filled in by instrumentQuery during [Monoize], used during [Sqlcache]. *) | 404 fun cacheWrap (query, i, urlifiedRel0, resultTyp, args) = |
406 val urlifiedRel0s : Mono.exp IM.map ref = ref IM.empty | 405 let |
407 | 406 val () = ffiInfo := {index = i, params = length args} :: !ffiInfo |
408 (* Used by [Monoize]. *) | 407 val loc = ErrorMsg.dummySpan |
409 val instrumentQuery = | 408 (* We ensure before this step that all arguments aren't effectful. |
410 let | |
411 val nextQuery = ref 0 | |
412 fun iq (query, urlifiedRel0) = | |
413 case query of | |
414 (EQuery {state = typ, ...}, loc) => | |
415 let | |
416 val i = !nextQuery before nextQuery := !nextQuery + 1 | |
417 in | |
418 urlifiedRel0s := IM.insert (!urlifiedRel0s, i, urlifiedRel0); | |
419 (ELet (varPrefix ^ Int.toString i, typ, query, | |
420 (* Uses a dummy FFI call to keep the urlified expression around, which | |
421 in turn keeps the declarations required for urlification safe from | |
422 [MonoShake]. The dummy call is removed during [Sqlcache]. *) | |
423 (* TODO: thread a [Monoize.Fm.t] through this module. *) | |
424 (ESeq ((EFfiApp ("Sqlcache", | |
425 "dummy", | |
426 [(urlifiedRel0, stringTyp)]), | |
427 loc), | |
428 (ERel 0, loc)), | |
429 loc)), | |
430 loc) | |
431 end | |
432 | _ => raise Match | |
433 in | |
434 iq | |
435 end | |
436 | |
437 fun cacheWrap (query, i, urlifiedRel0, args) = | |
438 case query of | |
439 (EQuery {state = typ, ...}, _) => | |
440 let | |
441 val () = ffiInfo := {index = i, params = length args} :: !ffiInfo | |
442 val loc = ErrorMsg.dummySpan | |
443 (* We ensure before this step that all arguments aren't effectful. | |
444 by turning them into local variables as needed. *) | 409 by turning them into local variables as needed. *) |
445 val argTyps = map (fn e => (e, stringTyp)) args | 410 val argTyps = map (fn e => (e, stringTyp)) args |
446 val argTypsInc = map (fn (e, typ) => (incRels 1 e, typ)) argTyps | 411 val argTypsInc = map (fn (e, typ) => (incRels 1 e, typ)) argTyps |
447 val check = ffiAppCache ("check", i, argTyps) | 412 val check = ffiAppCache ("check", i, argTyps) |
448 val store = ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argTypsInc) | 413 val store = ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argTypsInc) |
449 val rel0 = (ERel 0, loc) | 414 val rel0 = (ERel 0, loc) |
450 in | 415 in |
451 (ECase (check, | 416 ECase (check, |
452 [((PNone stringTyp, loc), | 417 [((PNone stringTyp, loc), |
453 (ELet ("q", typ, query, (ESeq (store, rel0), loc)), loc)), | 418 (ELet ("q", resultTyp, query, (ESeq (store, rel0), loc)), loc)), |
454 ((PSome (stringTyp, (PVar ("hit", stringTyp), loc)), loc), | 419 ((PSome (stringTyp, (PVar ("hit", stringTyp), loc)), loc), |
455 (* Boolean is false because we're not unurlifying from a cookie. *) | 420 (* Boolean is false because we're not unurlifying from a cookie. *) |
456 (EUnurlify (rel0, typ, false), loc))], | 421 (EUnurlify (rel0, resultTyp, false), loc))], |
457 {disc = stringTyp, result = typ}), | 422 {disc = stringTyp, result = resultTyp}) |
458 loc) | 423 end |
459 end | |
460 | _ => raise Match | |
461 | 424 |
462 fun fileMapfold doExp file start = | 425 fun fileMapfold doExp file start = |
463 case MonoUtil.File.mapfold {typ = Search.return2, | 426 case MonoUtil.File.mapfold {typ = Search.return2, |
464 exp = fn x => (fn s => Search.Continue (doExp x s)), | 427 exp = fn x => (fn s => Search.Continue (doExp x s)), |
465 decl = Search.return2} file start of | 428 decl = Search.return2} file start of |
502 (newText, wrapLets, numArgs) | 465 (newText, wrapLets, numArgs) |
503 end | 466 end |
504 | 467 |
505 fun addChecking file = | 468 fun addChecking file = |
506 let | 469 let |
507 fun doExp (queryInfo as (tableToIndices, indexToQueryNumArgs)) = | 470 fun doExp (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) = |
508 fn e' as ELet (v, t, | 471 fn e' as EQuery {query = origQueryText, |
509 (EQuery {query = origQueryText, | 472 sqlcacheInfo = urlifiedRel0, |
510 initial, body, state, tables, exps, sqlcacheInfo}, queryLoc), | 473 state = resultTyp, |
511 letBody) => | 474 initial, body, tables, exps} => |
512 let | 475 let |
513 val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText | 476 val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText |
514 (* Increment once for each new variable just made. *) | 477 (* Increment once for each new variable just made. *) |
515 val queryExp = incRels numArgs | 478 val queryExp = incRels numArgs |
516 (EQuery {query = newQueryText, | 479 (EQuery {query = newQueryText, |
480 sqlcacheInfo = urlifiedRel0, | |
481 state = resultTyp, | |
517 initial = initial, | 482 initial = initial, |
518 body = body, | 483 body = body, |
519 state = state, | |
520 tables = tables, | 484 tables = tables, |
521 exps = exps, | 485 exps = exps}, |
522 sqlcacheInfo = sqlcacheInfo}, | 486 ErrorMsg.dummySpan) |
523 queryLoc) | |
524 val (EQuery {query = queryText, ...}, _) = queryExp | 487 val (EQuery {query = queryText, ...}, _) = queryExp |
525 val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText)) | 488 val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText)) |
526 val args = List.tabulate (numArgs, fn n => (ERel n, ErrorMsg.dummySpan)) | 489 val args = List.tabulate (numArgs, fn n => (ERel n, ErrorMsg.dummySpan)) |
527 fun bind x f = Option.mapPartial f x | 490 fun bind x f = Option.mapPartial f x |
528 fun guard b x = if b then x else NONE | 491 fun guard b x = if b then x else NONE |
530 fun safe bound = not o effectful true (effectfulMap file) false bound | 493 fun safe bound = not o effectful true (effectfulMap file) false bound |
531 val attempt = | 494 val attempt = |
532 (* Ziv misses Haskell's do notation.... *) | 495 (* Ziv misses Haskell's do notation.... *) |
533 guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) ( | 496 guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) ( |
534 bind (Sql.parse Sql.query queryText) (fn queryParsed => | 497 bind (Sql.parse Sql.query queryText) (fn queryParsed => |
535 bind (indexOfName v) (fn index => | 498 SOME (wrapLets (cacheWrap (queryExp, index, urlifiedRel0, resultTyp, args)), |
536 bind (IM.find (!urlifiedRel0s, index)) (fn urlifiedRel0 => | |
537 SOME (wrapLets (ELet (v, t, | |
538 cacheWrap (queryExp, index, urlifiedRel0, args), | |
539 incRelsBound 1 numArgs letBody)), | |
540 (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index)) | 499 (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index)) |
541 tableToIndices | 500 tableToIndices |
542 (tablesQuery queryParsed), | 501 (tablesQuery queryParsed), |
543 IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)))))))) | 502 IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)), |
503 index + 1)))) | |
544 in | 504 in |
545 case attempt of | 505 case attempt of |
546 SOME pair => pair | 506 SOME pair => pair |
547 | NONE => (e', queryInfo) | 507 | NONE => (e', queryInfo) |
548 end | 508 end |
549 | ESeq ((EFfiApp ("Sqlcache", "dummy", _), _), (e', _)) => (e', queryInfo) | |
550 | e' => (e', queryInfo) | 509 | e' => (e', queryInfo) |
551 in | 510 in |
552 fileMapfold (fn exp => fn state => doExp state exp) file (SIMM.empty, IM.empty) | 511 fileMapfold (fn exp => fn state => doExp state exp) file (SIMM.empty, IM.empty, 0) |
553 end | 512 end |
554 | 513 |
555 val gunk : (Sql.query * Sql.dml * Mono.exp list list) list ref = ref [] | 514 val gunk : (Sql.query * Sql.dml * Mono.exp list list) list ref = ref [] |
556 | 515 |
557 val gunk' : (((Sql.cmp * Sql.sqexp * Sql.sqexp) formula) | 516 val gunk' : (((Sql.cmp * Sql.sqexp * Sql.sqexp) formula) |
599 end | 558 end |
600 | 559 |
601 | 560 |
602 (* gunk := (queryParsed, dmlParsed, invalidations (numArgs, queryParsed, dmlParsed)) :: !gunk); *) | 561 (* gunk := (queryParsed, dmlParsed, invalidations (numArgs, queryParsed, dmlParsed)) :: !gunk); *) |
603 | 562 |
604 fun addFlushing (file, (tableToIndices, indexToQueryNumArgs)) = | 563 fun addFlushing (file, (tableToIndices, indexToQueryNumArgs, _)) = |
605 let | 564 let |
606 (* TODO: write this. *) | 565 (* TODO: write this. *) |
607 val allInvs = () (* SM.foldr (fn (x, acc) => IS.listItems x @ acc) [] tableToIndices *) | 566 val allInvs = () (* SM.foldr (fn (x, acc) => IS.listItems x @ acc) [] tableToIndices *) |
608 val flushes = List.concat o | 567 val flushes = List.concat o |
609 map (fn (i, argss) => | 568 map (fn (i, argss) => |