Mercurial > urweb
comparison src/sqlcache.sml @ 2278:b7615e0ac4b0
Fix bug in and clean up free path code.
author | Ziv Scully <ziv@mit.edu> |
---|---|
date | Tue, 10 Nov 2015 12:35:00 -0500 |
parents | c05f9a5e0f0f |
children | 0bdfec16a01d |
comparison
equal
deleted
inserted
replaced
2277:6bce459ca581 | 2278:b7615e0ac4b0 |
---|---|
1 structure Sqlcache (* DEBUG :> SQLCACHE *) = struct | 1 structure Sqlcache :> SQLCACHE = struct |
2 | 2 |
3 open Mono | 3 open Mono |
4 | 4 |
5 structure IK = struct type ord_key = int val compare = Int.compare end | 5 structure IK = struct type ord_key = int val compare = Int.compare end |
6 structure IS = IntBinarySet | 6 structure IS = IntBinarySet |
49 (* ASK: is it okay to hardcode Sqlcache functions as effectful? *) | 49 (* ASK: is it okay to hardcode Sqlcache functions as effectful? *) |
50 fn (m, f) => Settings.isEffectful (m, f) | 50 fn (m, f) => Settings.isEffectful (m, f) |
51 andalso not (m = "Basis" andalso SS.member (okayWrites, f)) | 51 andalso not (m = "Basis" andalso SS.member (okayWrites, f)) |
52 end | 52 end |
53 | 53 |
54 val cache = ref LruCache.cache | 54 val cacheRef = ref LruCache.cache |
55 fun setCache c = cache := c | 55 fun setCache c = cacheRef := c |
56 fun getCache () = !cache | 56 fun getCache () = !cacheRef |
57 | |
58 val alwaysConsolidateRef = ref true | |
59 fun setAlwaysConsolidate b = alwaysConsolidateRef := b | |
60 fun getAlwaysConsolidate () = !alwaysConsolidateRef | |
57 | 61 |
58 (* Used to have type context for local variables in MonoUtil functions. *) | 62 (* Used to have type context for local variables in MonoUtil functions. *) |
59 val doBind = | 63 val doBind = |
60 fn (env, MonoUtil.Exp.RelE (x, t)) => MonoEnv.pushERel env x t NONE | 64 fn (env, MonoUtil.Exp.RelE (x, t)) => MonoEnv.pushERel env x t NONE |
61 | (env, MonoUtil.Exp.NamedE (x, n, t, eo, s)) => MonoEnv.pushENamed env x n t eo s | 65 | (env, MonoUtil.Exp.NamedE (x, n, t, eo, s)) => MonoEnv.pushENamed env x n t eo s |
62 | (env, MonoUtil.Exp.Datatype (x, n, cs)) => MonoEnv.pushDatatype env x n cs | 66 | (env, MonoUtil.Exp.Datatype (x, n, cs)) => MonoEnv.pushDatatype env x n cs |
63 | 67 |
64 val dummyLoc = ErrorMsg.dummySpan | 68 val dummyLoc = ErrorMsg.dummySpan |
65 | 69 |
70 (* DEBUG *) | |
71 fun printExp msg exp = Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_exp MonoEnv.empty exp) | |
72 fun printExp' msg exp' = printExp msg (exp', dummyLoc) | |
73 fun printTyp msg typ = Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_typ MonoEnv.empty typ) | |
74 fun printTyp' msg typ' = printTyp msg (typ', dummyLoc) | |
75 fun obindDebug printer (x, f) = | |
76 case x of | |
77 NONE => NONE | |
78 | SOME x' => case f x' of | |
79 NONE => (printer (); NONE) | |
80 | y => y | |
66 | 81 |
67 (*********************) | 82 (*********************) |
68 (* General Utilities *) | 83 (* General Utilities *) |
69 (*********************) | 84 (*********************) |
70 | 85 |
330 | (bound, _) => bound} | 345 | (bound, _) => bound} |
331 0 | 346 0 |
332 IS.empty | 347 IS.empty |
333 | 348 |
334 (* A path is a number of field projections of a variable. *) | 349 (* A path is a number of field projections of a variable. *) |
350 type path = int * string list | |
335 structure PK = PairKeyFn(structure I = IK structure J = ListKeyFn(SK)) | 351 structure PK = PairKeyFn(structure I = IK structure J = ListKeyFn(SK)) |
336 structure PS = BinarySetFn(PK) | 352 structure PS = BinarySetFn(PK) |
337 | |
338 (* DEBUG *) | |
339 val gunk3 : (PS.set * PS.set) list ref = ref [] | |
340 val gunk4 : (PS.set * PS.set) list ref = ref [] | |
341 | 353 |
342 val pathOfExp = | 354 val pathOfExp = |
343 let | 355 let |
344 fun readFields acc exp = | 356 fun readFields acc exp = |
345 acc | 357 acc |
378 | EUnop (_, e) => freePaths' bound e | 390 | EUnop (_, e) => freePaths' bound e |
379 | EBinop (_, _, e1, e2) => freePaths' bound e1 o freePaths' bound e2 | 391 | EBinop (_, _, e1, e2) => freePaths' bound e1 o freePaths' bound e2 |
380 | ERecord fields => List.foldl (fn ((_, e, _), acc) => freePaths' bound e o acc) id fields | 392 | ERecord fields => List.foldl (fn ((_, e, _), acc) => freePaths' bound e o acc) id fields |
381 | e as EField _ => freePaths'' bound e | 393 | e as EField _ => freePaths'' bound e |
382 | ECase (e, cases, _) => | 394 | ECase (e, cases, _) => |
383 List.foldl (fn ((p, e), acc) => freePaths' (bound + MonoEnv.patBindsN p) e o acc) | 395 List.foldl (fn ((p, e), acc) => freePaths' (MonoEnv.patBindsN p + bound) e o acc) |
384 (freePaths' bound e) | 396 (freePaths' bound e) |
385 cases | 397 cases |
386 | EStrcat (e1, e2) => freePaths' bound e1 o freePaths' bound e2 | 398 | EStrcat (e1, e2) => freePaths' bound e1 o freePaths' bound e2 |
387 | EError (e, _) => freePaths' bound e | 399 | EError (e, _) => freePaths' bound e |
388 | EReturnBlob {blob, mimeType = e, ...} => | 400 | EReturnBlob {blob, mimeType = e, ...} => |
389 freePaths' bound e o (case blob of NONE => id | SOME e => freePaths' bound e) | 401 freePaths' bound e o (case blob of NONE => id | SOME e => freePaths' bound e) |
390 | ERedirect (e, _) => freePaths' bound e | 402 | ERedirect (e, _) => freePaths' bound e |
391 | EWrite e => freePaths' bound e | 403 | EWrite e => freePaths' bound e |
392 | ESeq (e1, e2) => freePaths' bound e1 o freePaths' bound e2 | 404 | ESeq (e1, e2) => freePaths' bound e1 o freePaths' bound e2 |
393 | ELet (_, _, e1, e2) => freePaths' (bound + 1) e1 o freePaths' bound e2 | 405 | ELet (_, _, e1, e2) => freePaths' bound e1 o freePaths' (bound + 1) e2 |
394 | EClosure (_, es) => List.foldl (fn (e, acc) => freePaths' bound e o acc) id es | 406 | EClosure (_, es) => List.foldl (fn (e, acc) => freePaths' bound e o acc) id es |
395 | EQuery {query = e1, body = e2, initial = e3, ...} => | 407 | EQuery {query = e1, body = e2, initial = e3, ...} => |
396 freePaths' bound e1 o freePaths' (bound + 2) e2 o freePaths' bound e3 | 408 freePaths' bound e1 o freePaths' (bound + 2) e2 o freePaths' bound e3 |
397 | EDml (e, _) => freePaths' bound e | 409 | EDml (e, _) => freePaths' bound e |
398 | ENextval e => freePaths' bound e | 410 | ENextval e => freePaths' bound e |
411 | 423 |
412 datatype unbind = Known of exp | Unknowns of int | 424 datatype unbind = Known of exp | Unknowns of int |
413 | 425 |
414 datatype cacheArg = AsIs of exp | Urlify of exp | 426 datatype cacheArg = AsIs of exp | Urlify of exp |
415 | 427 |
416 structure InvalInfo (* DEBUG :> sig | 428 structure InvalInfo :> sig |
417 type t | 429 type t |
418 type state = {tableToIndices : SIMM.multimap, | 430 type state = {tableToIndices : SIMM.multimap, |
419 indexToInvalInfo : (t * int) IntBinaryMap.map, | 431 indexToInvalInfo : (t * int) IntBinaryMap.map, |
420 ffiInfo : {index : int, params : int} list, | 432 ffiInfo : {index : int, params : int} list, |
421 index : int} | 433 index : int} |
422 val empty : t | 434 val empty : t |
423 val singleton : Sql.query -> t | 435 val singleton : Sql.query -> t |
424 val query : t -> Sql.query | 436 val query : t -> Sql.query |
425 val orderArgs : t * IS.set -> cacheArg list | 437 val orderArgs : t * Mono.exp -> cacheArg list |
426 val unbind : t * unbind -> t option | 438 val unbind : t * unbind -> t option |
427 val union : t * t -> t | 439 val union : t * t -> t |
428 val updateState : t * int * state -> state | 440 val updateState : t * int * state -> state |
429 end *) = struct | 441 end = struct |
430 | 442 |
431 (* Variable, field projections, possible wrapped sqlification FFI call. *) | 443 (* Variable, field projections, possible wrapped sqlification FFI call. *) |
432 type sqlArg = int * string list * (string * string * typ) option | 444 type sqlArg = path * (string * string * typ) option |
433 | 445 |
434 type subst = sqlArg IM.map | 446 type subst = sqlArg IM.map |
435 | 447 |
436 (* TODO: store free variables as well? *) | 448 (* TODO: store free variables as well? *) |
437 type t = (Sql.query * subst) list | 449 type t = (Sql.query * subst) list |
439 type state = {tableToIndices : SIMM.multimap, | 451 type state = {tableToIndices : SIMM.multimap, |
440 indexToInvalInfo : (t * int) IntBinaryMap.map, | 452 indexToInvalInfo : (t * int) IntBinaryMap.map, |
441 ffiInfo : {index : int, params : int} list, | 453 ffiInfo : {index : int, params : int} list, |
442 index : int} | 454 index : int} |
443 | 455 |
444 structure AK = TripleKeyFn( | 456 structure AK = PairKeyFn( |
445 structure I = IK | 457 structure I = PK |
446 structure J = ListKeyFn(SK) | 458 structure J = OptionKeyFn(TripleKeyFn( |
447 structure K = OptionKeyFn(TripleKeyFn( | |
448 structure I = SK | 459 structure I = SK |
449 structure J = SK | 460 structure J = SK |
450 structure K = struct type ord_key = Mono.typ val compare = MonoUtil.Typ.compare end))) | 461 structure K = struct type ord_key = Mono.typ val compare = MonoUtil.Typ.compare end))) |
451 structure AM = BinaryMapFn(AK) | 462 structure AM = BinaryMapFn(AK) |
452 | 463 |
491 IM.foldli (fn (k, v, acc) => lift2 (fn (acc, w) => IM.insert (acc, k, w)) (acc, f (k,v))) | 502 IM.foldli (fn (k, v, acc) => lift2 (fn (acc, w) => IM.insert (acc, k, w)) (acc, f (k,v))) |
492 (pure IM.empty) | 503 (pure IM.empty) |
493 | 504 |
494 fun traverseSubst (ops as (_, pure', lift, _, _, _, lift2')) f = | 505 fun traverseSubst (ops as (_, pure', lift, _, _, _, lift2')) f = |
495 let | 506 let |
496 fun mp (n, fields, sqlify) = | 507 fun mp ((n, fields), sqlify) = |
497 lift (fn (n', fields', sqlify') => | 508 lift (fn ((n', fields'), sqlify') => |
498 let | 509 let |
499 fun wrap sq = (n', fields' @ fields, sq) | 510 fun wrap sq = ((n', fields' @ fields), sq) |
500 in | 511 in |
501 case (fields', sqlify', fields, sqlify) of | 512 case (fields', sqlify', fields, sqlify) of |
502 (_, NONE, _, NONE) => wrap NONE | 513 (_, NONE, _, NONE) => wrap NONE |
503 | (_, NONE, _, sq as SOME _) => wrap sq | 514 | (_, NONE, _, sq as SOME _) => wrap sq |
504 (* Last case should suffice because we don't | 515 (* Last case should suffice because we don't |
537 | 548 |
538 (* Signature Implementation *) | 549 (* Signature Implementation *) |
539 | 550 |
540 val empty = [] | 551 val empty = [] |
541 | 552 |
542 fun singleton q = [(q, IS.foldl (fn (n, acc) => IM.insert (acc, n, (n, [], NONE))) | 553 fun singleton q = [(q, IS.foldl (fn (n, acc) => IM.insert (acc, n, ((n, []), NONE))) |
543 IM.empty | 554 IM.empty |
544 (varsOfQuery q))] | 555 (varsOfQuery q))] |
545 | 556 |
546 val union = op@ | 557 val union = op@ |
547 | 558 |
557 in | 568 in |
558 (* Maps each arg to a different consecutive integer, starting from 0. *) | 569 (* Maps each arg to a different consecutive integer, starting from 0. *) |
559 AM.map count args | 570 AM.map count args |
560 end | 571 end |
561 | 572 |
562 fun expOfArg (n, fields, sqlify) = | 573 fun expOfArg (path, sqlify) = |
563 let | 574 let |
564 val exp = List.foldl (fn (field, exp) => (EField (exp, field), dummyLoc)) | 575 val exp = expOfPath path |
565 (ERel n, dummyLoc) | |
566 fields | |
567 in | 576 in |
568 case sqlify of | 577 case sqlify of |
569 NONE => exp | 578 NONE => exp |
570 | SOME (m, x, typ) => (EFfiApp (m, x, [(exp, typ)]), dummyLoc) | 579 | SOME (m, x, typ) => (EFfiApp (m, x, [(exp, typ)]), dummyLoc) |
571 end | 580 end |
572 | 581 |
573 fun orderArgs (qs : t, paths) = | 582 fun orderArgs (qs : t, exp) = |
574 let | 583 let |
584 val paths = freePaths exp | |
575 fun erel n = (ERel n, dummyLoc) | 585 fun erel n = (ERel n, dummyLoc) |
576 val argsMap = sqlArgsMap qs | 586 val argsMap = sqlArgsMap qs |
577 val args = map (expOfArg o #1) (AM.listItemsi argsMap) | 587 val args = map (expOfArg o #1) (AM.listItemsi argsMap) |
578 val invalPaths = List.foldl PS.union PS.empty (map freePaths args) | 588 val invalPaths = List.foldl PS.union PS.empty (map freePaths args) |
579 (* DEBUG *) | |
580 val () = gunk3 := (paths, invalPaths) :: !gunk3 | |
581 in | 589 in |
582 (* Put arguments we might invalidate by first. *) | 590 (* Put arguments we might invalidate by first. *) |
583 map AsIs args | 591 map AsIs args |
584 (* TODO: make sure these variables are okay to remove from the argument list. *) | 592 (* TODO: make sure these variables are okay to remove from the argument list. *) |
585 @ map (Urlify o expOfPath) (PS.listItems (PS.difference (paths, invalPaths))) | 593 @ map (Urlify o expOfPath) (PS.listItems (PS.difference (paths, invalPaths))) |
629 | EField (exp, f) => doFields (SOME (f::fs, sqlify)) exp | 637 | EField (exp, f) => doFields (SOME (f::fs, sqlify)) exp |
630 | _ => NONE) | 638 | _ => NONE) |
631 in | 639 in |
632 fn (EFfiApp ("Basis", x, [(exp, typ)]), _) => | 640 fn (EFfiApp ("Basis", x, [(exp, typ)]), _) => |
633 if String.isPrefix "sqlify" x | 641 if String.isPrefix "sqlify" x |
634 then doFields (SOME ([], SOME ("Basis", x, typ))) exp | 642 then omap (fn path => (path, SOME ("Basis", x, typ))) (pathOfExp exp) |
635 else NONE | 643 else NONE |
636 | exp => doFields (SOME ([], NONE)) exp | 644 | exp => omap (fn path => (path, NONE)) (pathOfExp exp) |
637 end | 645 end |
638 | 646 |
639 val unbind1 = | 647 val unbind1 = |
640 fn Known e => | 648 fn Known e => |
641 let | 649 let |
642 val replacement = argOfExp e | 650 val replacement = argOfExp e |
643 in | 651 in |
644 omapSubst (fn 0 => replacement | 652 omapSubst (fn 0 => replacement |
645 | n => SOME (n-1, [], NONE)) | 653 | n => SOME ((n-1, []), NONE)) |
646 end | 654 end |
647 | Unknowns k => omapSubst (fn n => if n < k then NONE else SOME (n-k, [], NONE)) | 655 | Unknowns k => omapSubst (fn n => if n < k then NONE else SOME ((n-k, []), NONE)) |
648 | 656 |
649 fun unbind (qs, ub) = | 657 fun unbind (qs, ub) = |
650 case ub of | 658 case ub of |
651 (* Shortcut if nothing's changing. *) | 659 (* Shortcut if nothing's changing. *) |
652 Unknowns 0 => SOME qs | 660 Unknowns 0 => SOME qs |
665 indexToInvalInfo = IM.insert (#indexToInvalInfo state, index, (qs, numArgs)), | 673 indexToInvalInfo = IM.insert (#indexToInvalInfo state, index, (qs, numArgs)), |
666 ffiInfo = {index = index, params = numArgs} :: #ffiInfo state, | 674 ffiInfo = {index = index, params = numArgs} :: #ffiInfo state, |
667 index = index + 1} | 675 index = index + 1} |
668 | 676 |
669 end | 677 end |
670 | |
671 (* DEBUG *) | |
672 val gunk0 : ((Sql.cmp * Sql.sqexp * Sql.sqexp) formula | |
673 * (Sql.cmp * Sql.sqexp * Sql.sqexp) formula) list ref = ref [] | |
674 val gunk1 : (Sql.cmp * atomExp option * atomExp option) list list list ref = ref [] | |
675 val gunk2 : exp list ref = ref [] | |
676 | 678 |
677 structure UF = UnionFindFn(AtomExpKey) | 679 structure UF = UnionFindFn(AtomExpKey) |
678 | 680 |
679 val rec sqexpToFormula = | 681 val rec sqexpToFormula = |
680 fn Sql.SqTrue => Combo (Conj, []) | 682 fn Sql.SqTrue => Combo (Conj, []) |
883 normalize simplify normalizeAtom Disj (Combo (Conj, [markQuery fQuery, markDml fDml])) | 885 normalize simplify normalizeAtom Disj (Combo (Conj, [markQuery fQuery, markDml fDml])) |
884 | 886 |
885 val conflictMaps = | 887 val conflictMaps = |
886 List.mapPartial (mergeEqs o map eqsOfClass) | 888 List.mapPartial (mergeEqs o map eqsOfClass) |
887 o List.mapPartial equivClasses | 889 o List.mapPartial equivClasses |
888 o (fn x => (gunk1 := x :: !gunk1; x)) | |
889 o dnf | 890 o dnf |
890 o (fn x => (gunk0 := x :: !gunk0; x)) | |
891 | 891 |
892 end | 892 end |
893 | 893 |
894 val conflictMaps = ConflictMaps.conflictMaps | 894 val conflictMaps = ConflictMaps.conflictMaps |
895 | 895 |
1143 end | 1143 end |
1144 | 1144 |
1145 val expSize = MonoUtil.Exp.fold {typ = #2, exp = fn (_, n) => n+1} 0 | 1145 val expSize = MonoUtil.Exp.fold {typ = #2, exp = fn (_, n) => n+1} 0 |
1146 | 1146 |
1147 (* TODO: pick a number. *) | 1147 (* TODO: pick a number. *) |
1148 val sizeWorthCaching = ~1 | 1148 val sizeWorthCaching = 5 |
1149 | 1149 |
1150 val worthCaching = | 1150 val worthCaching = |
1151 fn EQuery _ => true | 1151 fn EQuery _ => true |
1152 | exp' => expSize (exp', dummyLoc) > sizeWorthCaching | 1152 | exp' => expSize (exp', dummyLoc) > sizeWorthCaching |
1153 | |
1154 fun shouldConsolidate args = | |
1155 let | |
1156 val isAsIs = fn AsIs _ => true | Urlify _ => false | |
1157 in | |
1158 getAlwaysConsolidate () | |
1159 orelse not (List.exists isAsIs args andalso List.exists (not o isAsIs) args) | |
1160 end | |
1153 | 1161 |
1154 fun cacheExp (env, exp', invalInfo, state : state) = | 1162 fun cacheExp (env, exp', invalInfo, state : state) = |
1155 case worthCaching exp' <\oguard\> typOfExp' env exp' of | 1163 case worthCaching exp' <\oguard\> typOfExp' env exp' of |
1156 NONE => NONE | 1164 NONE => NONE |
1157 | SOME (TFun _, _) => NONE | 1165 | SOME (TFun _, _) => NONE |
1158 | SOME typ => | 1166 | SOME typ => |
1159 let | 1167 let |
1160 val args = InvalInfo.orderArgs (invalInfo, freePaths (exp', dummyLoc)) | 1168 val args = InvalInfo.orderArgs (invalInfo, (exp', dummyLoc)) |
1161 val numArgs = length args | 1169 in |
1162 in (List.foldr (fn (arg, acc) => | 1170 shouldConsolidate args |
1163 acc | 1171 <\oguard\> |
1164 <\obind\> | 1172 List.foldr (fn (arg, acc) => |
1165 (fn args' => | 1173 acc |
1166 (case arg of | 1174 <\obind\> |
1167 AsIs exp => SOME exp | 1175 (fn args' => |
1168 | Urlify exp => | 1176 (case arg of |
1169 typOfExp env exp | 1177 AsIs exp => SOME exp |
1170 <\obind\> | 1178 | Urlify exp => |
1171 (fn typ => | 1179 typOfExp env exp |
1172 (MonoFooify.urlify env (exp, typ)))) | 1180 <\obind\> |
1173 <\obind\> | 1181 (fn typ => (MonoFooify.urlify env (exp, typ)))) |
1174 (fn arg' => SOME (arg' :: args')))) | 1182 <\obind\> |
1175 (SOME []) | 1183 (fn arg' => SOME (arg' :: args')))) |
1176 args) | 1184 (SOME []) |
1177 <\obind\> | 1185 args |
1178 (fn args' => | 1186 <\obind\> |
1179 cacheWrap (env, (exp', dummyLoc), typ, args', #index state) | 1187 (fn args' => |
1180 <\obind\> | 1188 cacheWrap (env, (exp', dummyLoc), typ, args', #index state) |
1181 (fn cachedExp => | 1189 <\obind\> |
1182 SOME (cachedExp, InvalInfo.updateState (invalInfo, numArgs, state)))) | 1190 (fn cachedExp => |
1191 SOME (cachedExp, InvalInfo.updateState (invalInfo, length args', state)))) | |
1183 end | 1192 end |
1184 | 1193 |
1185 fun cacheQuery (effs, env, q) : subexp = | 1194 fun cacheQuery (effs, env, q) : subexp = |
1186 let | 1195 let |
1187 (* We use dummyTyp here. I think this is okay because databases don't | 1196 (* We use dummyTyp here. I think this is okay because databases don't |
1192 o effectful effs | 1201 o effectful effs |
1193 (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE) | 1202 (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE) |
1194 bound | 1203 bound |
1195 env) | 1204 env) |
1196 val {query = queryText, initial, body, ...} = q | 1205 val {query = queryText, initial, body, ...} = q |
1197 (* DEBUG *) | |
1198 (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *) | |
1199 val attempt = | 1206 val attempt = |
1200 (* Ziv misses Haskell's do notation.... *) | 1207 (* Ziv misses Haskell's do notation.... *) |
1201 (safe 0 queryText andalso safe 0 initial andalso safe 2 body) | 1208 (safe 0 queryText andalso safe 0 initial andalso safe 2 body) |
1202 <\oguard\> | 1209 <\oguard\> |
1203 Sql.parse Sql.query queryText | 1210 Sql.parse Sql.query queryText |
1216 case attempt of | 1223 case attempt of |
1217 NONE => Impure (EQuery q, dummyLoc) | 1224 NONE => Impure (EQuery q, dummyLoc) |
1218 | SOME subexp => subexp | 1225 | SOME subexp => subexp |
1219 end | 1226 end |
1220 | 1227 |
1221 (* DEBUG *) | 1228 fun cacheTree (effs : IS.set) ((env, exp as (exp', loc)), state) = |
1222 (* fun cacheTree (effs : IS.set) ((env, exp as (exp', loc)), state) = *) | |
1223 (* (Print.preface ("cacheTree> ", MonoPrint.p_exp MonoEnv.empty exp); *) | |
1224 (* cacheTree' effs ((env, exp), state)) *) | |
1225 | |
1226 and cacheTree (effs : IS.set) ((env, exp as (exp', loc)), state) = | |
1227 let | 1229 let |
1228 fun wrapBindN (f : exp list -> exp') | 1230 fun wrapBindN (f : exp list -> exp') |
1229 (args : ((MonoEnv.env * exp) * unbind) list) = | 1231 (args : ((MonoEnv.env * exp) * unbind) list) = |
1230 let | 1232 let |
1231 val (subexps, state) = | 1233 val (subexps, state) = |
1384 val flushes = List.concat | 1386 val flushes = List.concat |
1385 o map (fn (i, argss) => map (fn args => flush (i, args)) argss) | 1387 o map (fn (i, argss) => map (fn args => flush (i, args)) argss) |
1386 val doExp = | 1388 val doExp = |
1387 fn dmlExp as EDml (dmlText, failureMode) => | 1389 fn dmlExp as EDml (dmlText, failureMode) => |
1388 let | 1390 let |
1389 (* DEBUG *) | |
1390 (* val () = gunk2 := dmlText :: !gunk2 *) | |
1391 (* val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty origDmlText)) *) | |
1392 val inval = | 1391 val inval = |
1393 case Sql.parse Sql.dml dmlText of | 1392 case Sql.parse Sql.dml dmlText of |
1394 SOME dmlParsed => | 1393 SOME dmlParsed => |
1395 SOME (map (fn i => (case IM.find (indexToInvalInfo, i) of | 1394 SOME (map (fn i => (case IM.find (indexToInvalInfo, i) of |
1396 SOME invalInfo => | 1395 SOME invalInfo => |