Mercurial > urweb
comparison src/sqlcache.sml @ 2273:a3cac6cea625
Consildation of caches understands sqlification.
author | Ziv Scully <ziv@mit.edu> |
---|---|
date | Wed, 04 Nov 2015 20:12:07 -0500 |
parents | 85f91c7452b0 |
children | 0730e217fc9c |
comparison
equal
deleted
inserted
replaced
2272:b49d22a4eda8 | 2273:a3cac6cea625 |
---|---|
62 (*********************) | 62 (*********************) |
63 (* General Utilities *) | 63 (* General Utilities *) |
64 (*********************) | 64 (*********************) |
65 | 65 |
66 (* From the MLton wiki. *) | 66 (* From the MLton wiki. *) |
67 infixr 3 /> fun f /> y = fn x => f (x, y) (* Right section *) | 67 infix 3 <\ fun x <\ f = fn y => f (x, y) (* Left section *) |
68 infixr 3 </ fun x </ f = f x (* Right application *) | 68 infix 3 \> fun f \> y = f y (* Left application *) |
69 | 69 |
70 fun mapFst f (x, y) = (f x, y) | 70 fun mapFst f (x, y) = (f x, y) |
71 | 71 |
72 (* Option monad. *) | 72 (* Option monad. *) |
73 fun obind (x, f) = Option.mapPartial f x | 73 fun obind (x, f) = Option.mapPartial f x |
317 {typ = #2, | 317 {typ = #2, |
318 exp = fn (bound, ERel n, vars) => if n < bound | 318 exp = fn (bound, ERel n, vars) => if n < bound |
319 then vars | 319 then vars |
320 else IS.add (vars, n - bound) | 320 else IS.add (vars, n - bound) |
321 | (_, _, vars) => vars, | 321 | (_, _, vars) => vars, |
322 bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound} | 322 bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 |
323 | (bound, _) => bound} | |
323 0 | 324 0 |
324 IS.empty | 325 IS.empty |
325 | 326 |
326 datatype unbind = Known of exp | Unknowns of int | 327 datatype unbind = Known of exp | Unknowns of int |
328 | |
329 datatype cacheArg = AsIs of exp | Urlify of exp | |
327 | 330 |
328 structure InvalInfo :> sig | 331 structure InvalInfo :> sig |
329 type t | 332 type t |
330 type state = {tableToIndices : SIMM.multimap, | 333 type state = {tableToIndices : SIMM.multimap, |
331 indexToInvalInfo : (t * int) IntBinaryMap.map, | 334 indexToInvalInfo : (t * int) IntBinaryMap.map, |
332 ffiInfo : {index : int, params : int} list, | 335 ffiInfo : {index : int, params : int} list, |
333 index : int} | 336 index : int} |
334 val empty : t | 337 val empty : t |
335 val singleton : Sql.query -> t | 338 val singleton : Sql.query -> t |
336 val query : t -> Sql.query | 339 val query : t -> Sql.query |
337 val orderArgs : t * IS.set -> int list | 340 val orderArgs : t * IS.set -> cacheArg list |
338 val unbind : t * unbind -> t option | 341 val unbind : t * unbind -> t option |
339 val union : t * t -> t | 342 val union : t * t -> t |
340 val updateState : t * int * state -> state | 343 val updateState : t * int * state -> state |
341 end = struct | 344 end = struct |
342 | 345 |
343 type t = Sql.query list | 346 datatype sqlArg = FreeVar of int | Sqlify of string * string * sqlArg * typ |
347 | |
348 type subst = sqlArg IM.map | |
349 | |
350 (* TODO: store free variables as well? *) | |
351 type t = (Sql.query * subst) list | |
344 | 352 |
345 type state = {tableToIndices : SIMM.multimap, | 353 type state = {tableToIndices : SIMM.multimap, |
346 indexToInvalInfo : (t * int) IntBinaryMap.map, | 354 indexToInvalInfo : (t * int) IntBinaryMap.map, |
347 ffiInfo : {index : int, params : int} list, | 355 ffiInfo : {index : int, params : int} list, |
348 index : int} | 356 index : int} |
349 | 357 |
350 val empty = [] | 358 structure AM = BinaryMapFn(struct |
351 | 359 type ord_key = sqlArg |
352 fun singleton q = [q] | 360 (* Saw this on MLton wiki. *) |
353 | 361 fun ifNotEq (cmp, thunk) = case cmp of |
354 val union = op@ | 362 EQUAL => thunk () |
363 | _ => cmp | |
364 fun try f x () = f x | |
365 val rec compare = | |
366 fn (FreeVar n1, FreeVar n2) => | |
367 Int.compare (n1, n2) | |
368 | (FreeVar _, _) => LESS | |
369 | (_, FreeVar _) => GREATER | |
370 | (Sqlify (m1, x1, arg1, t1), Sqlify (m2, x2, arg2, t2)) => | |
371 String.compare (m1, m2) | |
372 <\ifNotEq\> try String.compare (x1, x2) | |
373 <\ifNotEq\> try MonoUtil.Typ.compare (t1, t2) | |
374 <\ifNotEq\> try compare (arg1, arg2) | |
375 end) | |
376 | |
377 (* Traversal Utilities *) | |
378 (* TODO: get rid of unused ones. *) | |
355 | 379 |
356 (* Need lift', etc. because we don't have rank-2 polymorphism. This should | 380 (* Need lift', etc. because we don't have rank-2 polymorphism. This should |
357 probably use a functor, but this works for now. *) | 381 probably use a functor (an ML one, not Haskell) but works for now. *) |
358 fun traverseSqexp (pure, _, lift, _, lift'', lift2, _) f = | 382 fun traverseSqexp (pure, _, lift, _, lift'', lift2, _) f = |
359 let | 383 let |
360 val rec tr = | 384 val rec tr = |
361 fn Sql.SqNot se => lift Sql.SqNot (tr se) | 385 fn Sql.SqNot se => lift Sql.SqNot (tr se) |
362 | Sql.Binop (r, se1, se2) => | 386 | Sql.Binop (r, se1, se2) => |
383 | Sql.Union (q1, q2) => lift2' Sql.Union (mp q1, mp q2) | 407 | Sql.Union (q1, q2) => lift2' Sql.Union (mp q1, mp q2) |
384 in | 408 in |
385 mp | 409 mp |
386 end | 410 end |
387 | 411 |
388 fun foldMapQuery plus zero = traverseQuery (fn _ => zero, | 412 (* Include unused tuple elements in argument for convenience of using same |
389 fn _ => zero, | 413 argument as [traverseQuery]. *) |
390 fn _ => fn x => x, | 414 fun traverseIM (pure, _, _, _, _, lift2, _) f = |
391 fn _ => fn x => x, | 415 IM.foldli (fn (k, v, acc) => lift2 (fn (acc, w) => IM.insert (acc, k, w)) (acc, f (k,v))) |
392 fn _ => fn x => x, | 416 (pure IM.empty) |
393 fn _ => plus, | 417 |
394 fn _ => plus) | 418 fun traverseSubst (ops as (_, pure', lift, _, _, _, lift2')) f = |
395 | 419 let |
396 val omapQuery = traverseQuery (SOME, SOME, omap, omap, omap, omap2, omap2) | 420 val rec mp = |
421 fn FreeVar n => f n | |
422 | Sqlify (m, x, arg, t) => lift (fn mparg => Sqlify (m, x, mparg, t)) (mp arg) | |
423 in | |
424 traverseIM ops (fn (_, v) => mp v) | |
425 end | |
426 | |
427 fun monoidOps plus zero = (fn _ => zero, fn _ => zero, | |
428 fn _ => fn x => x, fn _ => fn x => x, fn _ => fn x => x, | |
429 fn _ => plus, fn _ => plus) | |
430 | |
431 val optionOps = (SOME, SOME, omap, omap, omap, omap2, omap2) | |
432 | |
433 fun foldMapQuery plus zero = traverseQuery (monoidOps plus zero) | |
434 val omapQuery = traverseQuery optionOps | |
435 fun foldMapIM plus zero = traverseIM (monoidOps plus zero) | |
436 fun omapIM f = traverseIM optionOps f | |
437 fun foldMapSubst plus zero = traverseSubst (monoidOps plus zero) | |
438 fun omapSubst f = traverseSubst optionOps f | |
397 | 439 |
398 val varsOfQuery = foldMapQuery IS.union | 440 val varsOfQuery = foldMapQuery IS.union |
399 IS.empty | 441 IS.empty |
400 (fn e' => freeVars (e', dummyLoc)) | 442 (fn e' => freeVars (e', dummyLoc)) |
401 | 443 |
444 val varsOfSubst = foldMapSubst IS.union IS.empty IS.singleton | |
445 | |
402 val varsOfList = | 446 val varsOfList = |
403 fn [] => IS.empty | 447 fn [] => IS.empty |
404 | (q::qs) => varsOfQuery (List.foldl Sql.Union q qs) | 448 | (q::qs) => varsOfQuery (List.foldl Sql.Union q qs) |
405 | 449 |
406 fun orderArgs (qs, vars) = | 450 (* Signature Implementation *) |
451 | |
452 val empty = [] | |
453 | |
454 fun singleton q = [(q, IS.foldl (fn (n, acc) => IM.insert (acc, n, FreeVar n)) | |
455 IM.empty | |
456 (varsOfQuery q))] | |
457 | |
458 val union = op@ | |
459 | |
460 fun sqlArgsMap (qs : t) = | |
407 let | 461 let |
408 val invalVars = varsOfList qs | 462 val args = |
463 List.foldl (fn ((q, subst), acc) => | |
464 IM.foldl (fn (arg, acc) => AM.insert (acc, arg, ())) acc subst) | |
465 AM.empty | |
466 qs | |
467 val countRef = ref (~1) | |
468 fun count () = (countRef := !countRef + 1; !countRef) | |
469 in | |
470 (* Maps each arg to a different consecutive integer, starting from 0. *) | |
471 AM.map count args | |
472 end | |
473 | |
474 val rec expOfArg = | |
475 fn FreeVar n => (ERel n, dummyLoc) | |
476 | Sqlify (m, x, arg, t) => (EFfiApp (m, x, [(expOfArg arg, t)]), dummyLoc) | |
477 | |
478 fun orderArgs (qs : t, vars) = | |
479 let | |
480 fun erel n = (ERel n, dummyLoc) | |
481 val argsMap = sqlArgsMap qs | |
482 val args = map (expOfArg o #1) (AM.listItemsi argsMap) | |
483 val invalVars = List.foldl IS.union IS.empty (map freeVars args) | |
409 in | 484 in |
410 (* Put arguments we might invalidate by first. *) | 485 (* Put arguments we might invalidate by first. *) |
411 IS.listItems invalVars @ IS.listItems (IS.difference (vars, invalVars)) | 486 map AsIs args |
487 (* TODO: make sure these variables are okay to remove from the argument list. *) | |
488 @ map (Urlify o erel) (IS.listItems (IS.difference (vars, invalVars))) | |
412 end | 489 end |
413 | 490 |
414 (* As a kludge, we rename the variables in the query to correspond to the | 491 (* As a kludge, we rename the variables in the query to correspond to the |
415 argument of the cache they're part of. *) | 492 argument of the cache they're part of. *) |
416 val query = | 493 fun query (qs : t) = |
417 fn (q::qs) => | |
418 let | 494 let |
419 val q = List.foldl Sql.Union q qs | 495 val argsMap = sqlArgsMap qs |
420 val ns = IS.listItems (varsOfQuery q) | 496 fun substitute subst = |
421 val rename = | 497 fn ERel n => IM.find (subst, n) |
422 fn ERel n => omap ERel (indexOf (fn n' => n' = n) ns) | 498 <\obind\> |
499 (fn arg => | |
500 AM.find (argsMap, arg) | |
501 <\obind\> | |
502 (fn n' => SOME (ERel n'))) | |
423 | _ => raise Match | 503 | _ => raise Match |
424 in | 504 in |
425 case omapQuery rename q of | 505 case (map #1 qs) of |
426 SOME q => q | 506 (q :: qs) => |
427 (* We should never get NONE because indexOf should never fail. *) | 507 let |
428 | NONE => raise Match | 508 val q = List.foldl Sql.Union q qs |
509 val ns = IS.listItems (varsOfQuery q) | |
510 val rename = | |
511 fn ERel n => omap ERel (indexOf (fn n' => n' = n) ns) | |
512 | _ => raise Match | |
513 in | |
514 case omapQuery rename q of | |
515 SOME q => q | |
516 (* We should never get NONE because indexOf should never fail. *) | |
517 | NONE => raise Match | |
518 end | |
519 (* We should never reach this case because [updateState] won't | |
520 put anything in the state if there are no queries. *) | |
521 | [] => raise Match | |
429 end | 522 end |
430 (* We should never reach this case because [updateState] won't put | 523 |
431 anything in the state if there are no queries. *) | 524 val rec argOfExp = |
432 | [] => raise Match | 525 fn (ERel n, _) => SOME (FreeVar n) |
433 | 526 | (EFfiApp ("Basis", x, [(exp, t)]), _) => |
434 fun unbind1 ub = | 527 if String.isPrefix "sqlify" x |
435 case ub of | 528 then omap (fn arg => Sqlify ("Basis", x, arg, t)) (argOfExp exp) |
436 Known (e', loc) => | 529 else NONE |
437 let | 530 | _ => NONE |
438 val replaceRel0 = case e' of | 531 |
439 ERel m => SOME (ERel m) | 532 val unbind1 = |
440 | _ => NONE | 533 fn Known e => |
441 in | 534 let |
442 omapQuery (fn ERel 0 => replaceRel0 | 535 val replacement = argOfExp e |
443 | ERel n => SOME (ERel (n-1)) | 536 in |
444 | _ => raise Match) | 537 omapSubst (fn 0 => replacement |
445 end | 538 | n => SOME (FreeVar (n-1))) |
446 | Unknowns k => | 539 end |
447 omapQuery (fn ERel n => if n >= k then NONE else SOME (ERel (n-k)) | 540 | Unknowns k => omapSubst (fn n => if n >= k then NONE else SOME (FreeVar (n-k))) |
448 | _ => raise Match) | |
449 | 541 |
450 fun unbind (qs, ub) = | 542 fun unbind (qs, ub) = |
451 case ub of | 543 case ub of |
452 (* Shortcut if nothing's changing. *) | 544 (* Shortcut if nothing's changing. *) |
453 Unknowns 0 => SOME qs | 545 Unknowns 0 => SOME qs |
454 | _ => osequence (map (unbind1 ub) qs) | 546 | _ => osequence (map (fn (q, subst) => unbind1 ub subst |
455 | 547 <\obind\> |
456 fun updateState ((qs, numArgs, state as {index, ...}) : t * int * state) = | 548 (fn subst' => SOME (q, subst'))) qs) |
457 {tableToIndices = List.foldr (fn (q, acc) => | 549 |
550 fun updateState (qs, numArgs, state as {index, ...} : state) = | |
551 {tableToIndices = List.foldr (fn ((q, _), acc) => | |
458 SS.foldl (fn (tab, acc) => | 552 SS.foldl (fn (tab, acc) => |
459 SIMM.insert (acc, tab, index)) | 553 SIMM.insert (acc, tab, index)) |
460 acc | 554 acc |
461 (tablesOfQuery q)) | 555 (tablesOfQuery q)) |
462 (#tableToIndices state) | 556 (#tableToIndices state) |
466 index = index + 1} | 560 index = index + 1} |
467 | 561 |
468 end | 562 end |
469 | 563 |
470 structure UF = UnionFindFn(AtomExpKey) | 564 structure UF = UnionFindFn(AtomExpKey) |
565 | |
566 val rec sqexpToFormula = | |
567 fn Sql.SqTrue => Combo (Conj, []) | |
568 | Sql.SqFalse => Combo (Disj, []) | |
569 | Sql.SqNot e => Negate (sqexpToFormula e) | |
570 | Sql.Binop (Sql.RCmp c, e1, e2) => Atom (c, e1, e2) | |
571 | Sql.Binop (Sql.RLop l, p1, p2) => Combo (case l of Sql.And => Conj | Sql.Or => Disj, | |
572 [sqexpToFormula p1, sqexpToFormula p2]) | |
573 (* ASK: any other sqexps that can be props? *) | |
574 | _ => raise Match | |
575 | |
576 fun renameTables tablePairs = | |
577 let | |
578 fun renameString table = | |
579 case List.find (fn (_, t) => table = t) tablePairs of | |
580 NONE => table | |
581 | SOME (realTable, _) => realTable | |
582 val renameSqexp = | |
583 fn Sql.Field (table, field) => Sql.Field (renameString table, field) | |
584 | e => e | |
585 fun renameAtom (cmp, e1, e2) = (cmp, renameSqexp e1, renameSqexp e2) | |
586 in | |
587 mapFormula renameAtom | |
588 end | |
589 | |
590 val rec queryToFormula = | |
591 fn Sql.Query1 {Where = NONE, ...} => Combo (Conj, []) | |
592 | Sql.Query1 {From = tablePairs, Where = SOME e, ...} => | |
593 renameTables tablePairs (sqexpToFormula e) | |
594 | Sql.Union (q1, q2) => Combo (Disj, [queryToFormula q1, queryToFormula q2]) | |
595 | |
596 fun valsToFormula (table, vals) = | |
597 Combo (Conj, map (fn (field, v) => Atom (Sql.Eq, Sql.Field (table, field), v)) vals) | |
598 | |
599 val rec dmlToFormula = | |
600 fn Sql.Insert (table, vals) => valsToFormula (table, vals) | |
601 | Sql.Delete (table, wher) => renameTables [(table, "T")] (sqexpToFormula wher) | |
602 | Sql.Update (table, vals, wher) => | |
603 let | |
604 val fWhere = sqexpToFormula wher | |
605 val fVals = valsToFormula (table, vals) | |
606 val modifiedFields = SS.addList (SS.empty, map #1 vals) | |
607 (* TODO: don't use field name hack. *) | |
608 val markField = | |
609 fn e as Sql.Field (t, v) => if SS.member (modifiedFields, v) | |
610 then Sql.Field (t, v ^ "'") | |
611 else e | |
612 | e => e | |
613 val mark = mapFormula (fn (cmp, e1, e2) => (cmp, markField e1, markField e2)) | |
614 in | |
615 renameTables [(table, "T")] | |
616 (Combo (Disj, [Combo (Conj, [fVals, mark fWhere]), | |
617 Combo (Conj, [mark fVals, fWhere])])) | |
618 end | |
619 | |
620 (* val rec toFormula = *) | |
621 (* fn (Sql.Union (q1, q2), d) => Combo (Disj, [toFormula (q1, d), toFormula (q2, d)]) *) | |
622 (* | (q as Sql.Query1 {Select = items, ...}, d) => *) | |
623 (* let *) | |
624 (* val selected = osequence (map (fn )) *) | |
625 (* in *) | |
626 (* case selected of *) | |
627 (* NONE => (Combo (Conj, [markQuery (), markDml fDml])) *) | |
628 (* end *) | |
471 | 629 |
472 structure ConflictMaps = struct | 630 structure ConflictMaps = struct |
473 | 631 |
474 structure TK = TripleKeyFn(structure I = CmpKey | 632 structure TK = TripleKeyFn(structure I = CmpKey |
475 structure J = AtomOptionKey | 633 structure J = AtomOptionKey |
580 | 738 |
581 end | 739 end |
582 | 740 |
583 val conflictMaps = ConflictMaps.conflictMaps | 741 val conflictMaps = ConflictMaps.conflictMaps |
584 | 742 |
585 val rec sqexpToFormula = | |
586 fn Sql.SqTrue => Combo (Conj, []) | |
587 | Sql.SqFalse => Combo (Disj, []) | |
588 | Sql.SqNot e => Negate (sqexpToFormula e) | |
589 | Sql.Binop (Sql.RCmp c, e1, e2) => Atom (c, e1, e2) | |
590 | Sql.Binop (Sql.RLop l, p1, p2) => Combo (case l of Sql.And => Conj | Sql.Or => Disj, | |
591 [sqexpToFormula p1, sqexpToFormula p2]) | |
592 (* ASK: any other sqexps that can be props? *) | |
593 | _ => raise Match | |
594 | |
595 fun renameTables tablePairs = | |
596 let | |
597 fun renameString table = | |
598 case List.find (fn (_, t) => table = t) tablePairs of | |
599 NONE => table | |
600 | SOME (realTable, _) => realTable | |
601 val renameSqexp = | |
602 fn Sql.Field (table, field) => Sql.Field (renameString table, field) | |
603 | e => e | |
604 fun renameAtom (cmp, e1, e2) = (cmp, renameSqexp e1, renameSqexp e2) | |
605 in | |
606 mapFormula renameAtom | |
607 end | |
608 | |
609 val rec queryToFormula = | |
610 fn Sql.Query1 {Where = NONE, ...} => Combo (Conj, []) | |
611 | Sql.Query1 {From = tablePairs, Where = SOME e, ...} => | |
612 renameTables tablePairs (sqexpToFormula e) | |
613 | Sql.Union (q1, q2) => Combo (Disj, [queryToFormula q1, queryToFormula q2]) | |
614 | |
615 fun valsToFormula (table, vals) = | |
616 Combo (Conj, map (fn (field, v) => Atom (Sql.Eq, Sql.Field (table, field), v)) vals) | |
617 | |
618 val rec dmlToFormula = | |
619 fn Sql.Insert (table, vals) => valsToFormula (table, vals) | |
620 | Sql.Delete (table, wher) => renameTables [(table, "T")] (sqexpToFormula wher) | |
621 | Sql.Update (table, vals, wher) => | |
622 let | |
623 val fWhere = sqexpToFormula wher | |
624 val fVals = valsToFormula (table, vals) | |
625 val modifiedFields = SS.addList (SS.empty, map #1 vals) | |
626 (* TODO: don't use field name hack. *) | |
627 val markField = | |
628 fn e as Sql.Field (t, v) => if SS.member (modifiedFields, v) | |
629 then Sql.Field (t, v ^ "'") | |
630 else e | |
631 | e => e | |
632 val mark = mapFormula (fn (cmp, e1, e2) => (cmp, markField e1, markField e2)) | |
633 in | |
634 renameTables [(table, "T")] | |
635 (Combo (Disj, [Combo (Conj, [fVals, mark fWhere]), | |
636 Combo (Conj, [mark fVals, fWhere])])) | |
637 end | |
638 | |
639 | 743 |
640 (*************************************) | 744 (*************************************) |
641 (* Program Instrumentation Utilities *) | 745 (* Program Instrumentation Utilities *) |
642 (*************************************) | 746 (*************************************) |
643 | |
644 val varName = | |
645 let | |
646 val varNumber = ref 0 | |
647 in | |
648 fn s => (varNumber := !varNumber + 1; s ^ Int.toString (!varNumber)) | |
649 end | |
650 | 747 |
651 val {check, store, flush, ...} = getCache () | 748 val {check, store, flush, ...} = getCache () |
652 | 749 |
653 val dummyTyp = (TRecord [], dummyLoc) | 750 val dummyTyp = (TRecord [], dummyLoc) |
654 | 751 |
750 | Sql.String s => (strcat (stringExp s, qText), newVars)) | 847 | Sql.String s => (strcat (stringExp s, qText), newVars)) |
751 (stringExp "", []) | 848 (stringExp "", []) |
752 chunks | 849 chunks |
753 fun wrapLets e' = | 850 fun wrapLets e' = |
754 (* Important that this is foldl (to oppose foldr above). *) | 851 (* Important that this is foldl (to oppose foldr above). *) |
755 List.foldl (fn (v, e') => ELet (varName "sqlArg", stringTyp, v, (e', loc))) | 852 List.foldl (fn (v, e') => ELet ("sqlArg", stringTyp, v, (e', loc))) |
756 e' | 853 e' |
757 newVariables | 854 newVariables |
758 val numArgs = length newVariables | 855 val numArgs = length newVariables |
759 in | 856 in |
760 (newText, wrapLets, numArgs) | 857 (newText, wrapLets, numArgs) |
898 val check = (check (index, args), loc) | 995 val check = (check (index, args), loc) |
899 val store = (store (index, argsInc, urlified), loc) | 996 val store = (store (index, argsInc, urlified), loc) |
900 in | 997 in |
901 SOME (ECase (check, | 998 SOME (ECase (check, |
902 [((PNone stringTyp, loc), | 999 [((PNone stringTyp, loc), |
903 (ELet (varName "q", typ, exp, (ESeq (store, rel0), loc)), loc)), | 1000 (ELet ("q", typ, exp, (ESeq (store, rel0), loc)), loc)), |
904 ((PSome (stringTyp, (PVar (varName "hit", stringTyp), loc)), loc), | 1001 ((PSome (stringTyp, (PVar ("hit", stringTyp), loc)), loc), |
905 (* Boolean is false because we're not unurlifying from a cookie. *) | 1002 (* Boolean is false because we're not unurlifying from a cookie. *) |
906 (EUnurlify (rel0, typ, false), loc))], | 1003 (EUnurlify (rel0, typ, false), loc))], |
907 {disc = (TOption stringTyp, loc), result = typ})) | 1004 {disc = (TOption stringTyp, loc), result = typ})) |
908 end | 1005 end |
909 end | 1006 end |
915 | 1012 |
916 val worthCaching = | 1013 val worthCaching = |
917 fn EQuery _ => true | 1014 fn EQuery _ => true |
918 | exp' => expSize (exp', dummyLoc) > sizeWorthCaching | 1015 | exp' => expSize (exp', dummyLoc) > sizeWorthCaching |
919 | 1016 |
920 fun cacheExp ((env, exp', invalInfo, state) : MonoEnv.env * exp' * InvalInfo.t * state) = | 1017 fun cacheExp (env, exp', invalInfo, state : state) = |
921 case (worthCaching exp') | 1018 case worthCaching exp' <\oguard\> typOfExp' env exp' of |
922 </oguard/> | |
923 typOfExp' env exp' of | |
924 NONE => NONE | 1019 NONE => NONE |
925 | SOME (TFun _, _) => NONE | 1020 | SOME (TFun _, _) => NONE |
926 | SOME typ => | 1021 | SOME typ => |
927 let | 1022 let |
928 val ns = InvalInfo.orderArgs (invalInfo, freeVars (exp', dummyLoc)) | 1023 val args = InvalInfo.orderArgs (invalInfo, freeVars (exp', dummyLoc)) |
929 val numArgs = length ns | 1024 val numArgs = length args |
930 in (List.foldr (fn (_, NONE) => NONE | 1025 in (List.foldr (fn (arg, acc) => |
931 | ((n, typ), SOME args) => | 1026 acc |
932 (MonoFooify.urlify env ((ERel n, dummyLoc), typ)) | 1027 <\obind\> |
933 </obind/> | 1028 (fn args' => |
934 (fn arg => SOME (arg :: args))) | 1029 (case arg of |
935 (SOME []) | 1030 AsIs exp => SOME exp |
936 (map (fn n => (n, #2 (MonoEnv.lookupERel env n))) ns)) | 1031 | Urlify exp => |
937 </obind/> | 1032 typOfExp env exp |
938 (fn args => | 1033 <\obind\> |
939 (cacheWrap (env, (exp', dummyLoc), typ, args, #index state)) | 1034 (fn typ => |
940 </obind/> | 1035 (MonoFooify.urlify env (exp, typ)))) |
941 (fn cachedExp => | 1036 <\obind\> |
942 SOME (cachedExp, InvalInfo.updateState (invalInfo, numArgs, state)))) | 1037 (fn arg' => SOME (arg' :: args')))) |
1038 (SOME []) | |
1039 args) | |
1040 <\obind\> | |
1041 (fn args' => | |
1042 cacheWrap (env, (exp', dummyLoc), typ, args', #index state) | |
1043 <\obind\> | |
1044 (fn cachedExp => | |
1045 SOME (cachedExp, InvalInfo.updateState (invalInfo, numArgs, state)))) | |
943 end | 1046 end |
944 | 1047 |
945 fun cacheQuery (effs, env, q) : subexp = | 1048 fun cacheQuery (effs, env, q) : subexp = |
946 let | 1049 let |
947 (* We use dummyTyp here. I think this is okay because databases don't | 1050 (* We use dummyTyp here. I think this is okay because databases don't |
957 (* DEBUG *) | 1060 (* DEBUG *) |
958 (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *) | 1061 (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *) |
959 val attempt = | 1062 val attempt = |
960 (* Ziv misses Haskell's do notation.... *) | 1063 (* Ziv misses Haskell's do notation.... *) |
961 (safe 0 queryText andalso safe 0 initial andalso safe 2 body) | 1064 (safe 0 queryText andalso safe 0 initial andalso safe 2 body) |
962 </oguard/> | 1065 <\oguard\> |
963 Sql.parse Sql.query queryText | 1066 Sql.parse Sql.query queryText |
964 </obind/> | 1067 <\obind\> |
965 (fn queryParsed => | 1068 (fn queryParsed => |
966 let | 1069 let |
967 val invalInfo = InvalInfo.singleton queryParsed | 1070 val invalInfo = InvalInfo.singleton queryParsed |
968 fun mkExp state = | 1071 fun mkExp state = |
969 case cacheExp (env, EQuery q, invalInfo, state) of | 1072 case cacheExp (env, EQuery q, invalInfo, state) of |
996 (SOME InvalInfo.empty) | 1099 (SOME InvalInfo.empty) |
997 (ListPair.map | 1100 (ListPair.map |
998 (fn (subexp, (_, unbinds)) => | 1101 (fn (subexp, (_, unbinds)) => |
999 InvalInfo.unbind (invalInfoOfSubexp subexp, unbinds)) | 1102 InvalInfo.unbind (invalInfoOfSubexp subexp, unbinds)) |
1000 (subexps, args))) | 1103 (subexps, args))) |
1001 </obind/> | 1104 <\obind\> |
1002 (fn invalInfo => | 1105 (fn invalInfo => |
1003 SOME (Cachable (invalInfo, | 1106 SOME (Cachable (invalInfo, |
1004 fn state => | 1107 fn state => |
1005 case cacheExp (env, | 1108 case cacheExp (env, |
1006 f (map (#2 o #1) args), | 1109 f (map (#2 o #1) args), |
1117 | (SOME x :: xs, SOME y :: ys) => (case AtomExpKey.compare (x, y) of | 1220 | (SOME x :: xs, SOME y :: ys) => (case AtomExpKey.compare (x, y) of |
1118 EQUAL => madeRedundantBy (xs, ys) | 1221 EQUAL => madeRedundantBy (xs, ys) |
1119 | _ => false) | 1222 | _ => false) |
1120 | _ => false | 1223 | _ => false |
1121 | 1224 |
1122 fun eqss (query, dml) = conflictMaps (queryToFormula query, dmlToFormula dml) | |
1123 | |
1124 fun invalidations ((invalInfo, numArgs), dml) = | 1225 fun invalidations ((invalInfo, numArgs), dml) = |
1125 let | 1226 let |
1126 val query = InvalInfo.query invalInfo | 1227 val query = InvalInfo.query invalInfo |
1127 in | 1228 in |
1128 (map (map optionAtomExpToExp) | 1229 (map (map optionAtomExpToExp) |
1129 o removeRedundant madeRedundantBy | 1230 o removeRedundant madeRedundantBy |
1130 o map (eqsToInvalidation numArgs) | 1231 o map (eqsToInvalidation numArgs) |
1131 o eqss) | 1232 o conflictMaps) |
1132 (query, dml) | 1233 (queryToFormula query, dmlToFormula dml) |
1133 end | 1234 end |
1134 | 1235 |
1135 end | 1236 end |
1136 | 1237 |
1137 val invalidations = Invalidations.invalidations | 1238 val invalidations = Invalidations.invalidations |
1138 | 1239 |
1139 (* DEBUG *) | 1240 (* DEBUG *) |
1140 (* val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] *) | 1241 (* val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] *) |
1141 (* val gunk' : exp list ref = ref [] *) | 1242 (* val gunk' : exp list ref = ref [] *) |
1142 | 1243 |
1143 fun addFlushing ((file, {tableToIndices, indexToInvalInfo, ffiInfo, index}), effs) = | 1244 fun addFlushing ((file, {tableToIndices, indexToInvalInfo, ffiInfo, ...} : state), effs) = |
1144 let | 1245 let |
1145 val flushes = List.concat | 1246 val flushes = List.concat |
1146 o map (fn (i, argss) => map (fn args => flush (i, args)) argss) | 1247 o map (fn (i, argss) => map (fn args => flush (i, args)) argss) |
1147 val doExp = | 1248 val doExp = |
1148 fn dmlExp as EDml (dmlText, failureMode) => | 1249 fn dmlExp as EDml (dmlText, failureMode) => |