Mercurial > urweb
comparison src/sqlcache.sml @ 2227:adb49db02af4
Fix type in flush FFI call to option string (rather than string).
author | Ziv Scully <ziv@mit.edu> |
---|---|
date | Tue, 31 Mar 2015 04:10:46 -0400 |
parents | 9410959d296f |
children | a749acc51ae4 |
comparison
equal
deleted
inserted
replaced
2226:e10881cd92da | 2227:adb49db02af4 |
---|---|
9 structure SM = BinaryMapFn(SK) | 9 structure SM = BinaryMapFn(SK) |
10 structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS) | 10 structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS) |
11 | 11 |
12 (* Filled in by [cacheWrap] during [Sqlcache]. *) | 12 (* Filled in by [cacheWrap] during [Sqlcache]. *) |
13 val ffiInfo : {index : int, params : int} list ref = ref [] | 13 val ffiInfo : {index : int, params : int} list ref = ref [] |
14 | |
15 fun resetFfiInfo () = ffiInfo := [] | |
14 | 16 |
15 fun getFfiInfo () = !ffiInfo | 17 fun getFfiInfo () = !ffiInfo |
16 | 18 |
17 (* Some FFIs have writing as their only effect, which the caching records. *) | 19 (* Some FFIs have writing as their only effect, which the caching records. *) |
18 val ffiEffectful = | 20 val ffiEffectful = |
374 in | 376 in |
375 List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps | 377 List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps |
376 end | 378 end |
377 | _ => raise Match | 379 | _ => raise Match |
378 | 380 |
381 (* TODO: factor out. *) | |
379 fun ffiAppCache' (func, index, args) : Mono.exp' = | 382 fun ffiAppCache' (func, index, args) : Mono.exp' = |
380 EFfiApp ("Sqlcache", func ^ Int.toString index, args) | 383 EFfiApp ("Sqlcache", func ^ Int.toString index, args) |
381 | 384 |
382 fun ffiAppCache (func, index, args) : Mono.exp = | 385 fun ffiAppCache (func, index, args) : Mono.exp = |
383 (ffiAppCache' (func, index, args), ErrorMsg.dummySpan) | 386 (ffiAppCache' (func, index, args), ErrorMsg.dummySpan) |
404 fun cacheWrap (query, i, urlifiedRel0, resultTyp, args) = | 407 fun cacheWrap (query, i, urlifiedRel0, resultTyp, args) = |
405 let | 408 let |
406 val () = ffiInfo := {index = i, params = length args} :: !ffiInfo | 409 val () = ffiInfo := {index = i, params = length args} :: !ffiInfo |
407 val loc = ErrorMsg.dummySpan | 410 val loc = ErrorMsg.dummySpan |
408 (* We ensure before this step that all arguments aren't effectful. | 411 (* We ensure before this step that all arguments aren't effectful. |
409 by turning them into local variables as needed. *) | 412 by turning them into local variables as needed. *) |
410 val argTyps = map (fn e => (e, stringTyp)) args | 413 val argTyps = map (fn e => (e, stringTyp)) args |
411 val argTypsInc = map (fn (e, typ) => (incRels 1 e, typ)) argTyps | 414 val argTypsInc = map (fn (e, typ) => (incRels 1 e, typ)) argTyps |
412 val check = ffiAppCache ("check", i, argTyps) | 415 val check = ffiAppCache ("check", i, argTyps) |
413 val store = ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argTypsInc) | 416 val store = ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argTypsInc) |
414 val rel0 = (ERel 0, loc) | 417 val rel0 = (ERel 0, loc) |
455 | Sql.String s => (strcat (stringExp s, qText), newVars)) | 458 | Sql.String s => (strcat (stringExp s, qText), newVars)) |
456 (stringExp "", []) | 459 (stringExp "", []) |
457 chunks | 460 chunks |
458 fun wrapLets e' = | 461 fun wrapLets e' = |
459 (* Important that this is foldl (to oppose foldr above). *) | 462 (* Important that this is foldl (to oppose foldr above). *) |
460 List.foldl (fn (v, e') => ELet ("sqlArgz", stringTyp, v, (e', loc))) | 463 List.foldl (fn (v, e') => ELet ("sqlArg", stringTyp, v, (e', loc))) |
461 e' | 464 e' |
462 newVariables | 465 newVariables |
463 val numArgs = length newVariables | 466 val numArgs = length newVariables |
464 in | 467 in |
465 (newText, wrapLets, numArgs) | 468 (newText, wrapLets, numArgs) |
509 | e' => (e', queryInfo) | 512 | e' => (e', queryInfo) |
510 in | 513 in |
511 fileMapfold (fn exp => fn state => doExp state exp) file (SIMM.empty, IM.empty, 0) | 514 fileMapfold (fn exp => fn state => doExp state exp) file (SIMM.empty, IM.empty, 0) |
512 end | 515 end |
513 | 516 |
514 val gunk : (Sql.query * Sql.dml * Mono.exp list list) list ref = ref [] | |
515 | |
516 val gunk' : (((Sql.cmp * Sql.sqexp * Sql.sqexp) formula) | |
517 * ((Sql.cmp * Sql.sqexp * Sql.sqexp) formula)) list ref = ref [] | |
518 | |
519 fun invalidations ((query, numArgs), dml) = | 517 fun invalidations ((query, numArgs), dml) = |
520 let | 518 let |
521 val loc = ErrorMsg.dummySpan | 519 val loc = ErrorMsg.dummySpan |
522 val optionAtomExpToExp = | 520 val optionAtomExpToExp = |
523 fn NONE => (ENone stringTyp, loc) | 521 fn NONE => (ENone stringTyp, loc) |
551 then yss | 549 then yss |
552 else xs :: yss) | 550 else xs :: yss) |
553 fun removeRedundant xss = removeRedundant' (xss, []) | 551 fun removeRedundant xss = removeRedundant' (xss, []) |
554 val eqss = conflictMaps (queryToFormula query, dmlToFormula dml) | 552 val eqss = conflictMaps (queryToFormula query, dmlToFormula dml) |
555 in | 553 in |
556 gunk' := (queryToFormula query, dmlToFormula dml) :: !gunk'; | |
557 (map (map optionAtomExpToExp) o removeRedundant o map eqsToInvalidation) eqss | 554 (map (map optionAtomExpToExp) o removeRedundant o map eqsToInvalidation) eqss |
558 end | 555 end |
559 | 556 |
560 | |
561 (* gunk := (queryParsed, dmlParsed, invalidations (numArgs, queryParsed, dmlParsed)) :: !gunk); *) | |
562 | |
563 fun addFlushing (file, (tableToIndices, indexToQueryNumArgs, _)) = | 557 fun addFlushing (file, (tableToIndices, indexToQueryNumArgs, _)) = |
564 let | 558 let |
565 (* TODO: write this. *) | 559 (* ASK: does this type actually matter? It was wrong before, but things |
566 val allInvs = () (* SM.foldr (fn (x, acc) => IS.listItems x @ acc) [] tableToIndices *) | 560 still seemed to work. *) |
561 val optionStringTyp = (TOption stringTyp, ErrorMsg.dummySpan) | |
567 val flushes = List.concat o | 562 val flushes = List.concat o |
568 map (fn (i, argss) => | 563 map (fn (i, argss) => |
569 map (fn args => | 564 map (fn args => |
570 ffiAppCache' ("flush", i, | 565 ffiAppCache' ("flush", i, |
571 map (fn arg => (arg, stringTyp)) args)) argss) | 566 map (fn arg => (arg, optionStringTyp)) |
567 args)) | |
568 argss) | |
572 val doExp = | 569 val doExp = |
573 fn EDml (origDmlText, failureMode) => | 570 fn EDml (origDmlText, failureMode) => |
574 let | 571 let |
575 val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText | 572 val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText |
576 val dmlText = incRels numArgs newDmlText | 573 val dmlText = incRels numArgs newDmlText |
577 val dmlExp = EDml (dmlText, failureMode) | 574 val dmlExp = EDml (dmlText, failureMode) |
575 (* DEBUG: we can remove the following line at some point. *) | |
578 val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty dmlText)) | 576 val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty dmlText)) |
579 val invs = | 577 val invs = |
580 case Sql.parse Sql.dml dmlText of | 578 case Sql.parse Sql.dml dmlText of |
581 SOME dmlParsed => | 579 SOME dmlParsed => |
582 map (fn i => (case IM.find (indexToQueryNumArgs, i) of | 580 map (fn i => (case IM.find (indexToQueryNumArgs, i) of |
611 fileMap doExp | 609 fileMap doExp |
612 end | 610 end |
613 | 611 |
614 fun go file = | 612 fun go file = |
615 let | 613 let |
616 val () = Sql.sqlcacheMode := true | 614 (* TODO: do something nicer than having Sql be in one of two modes. *) |
615 val () = (resetFfiInfo (); Sql.sqlcacheMode := true) | |
617 val file' = addFlushing (addChecking (inlineSql file)) | 616 val file' = addFlushing (addChecking (inlineSql file)) |
618 val () = Sql.sqlcacheMode := false | 617 val () = Sql.sqlcacheMode := false |
619 in | 618 in |
620 file' | 619 file' |
621 end | 620 end |