Mercurial > urweb

comparison src/sqlcache.sml @ 2273:a3cac6cea625

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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) =>