Mercurial > urweb

comparison src/sqlcache.sml @ 2227:adb49db02af4

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