Mercurial > urweb

comparison src/sqlcache.sml @ 2299:47d5c94aeeb8

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add consolidation heuristic options.
author Ziv Scully <ziv@mit.edu>
date Thu, 19 Nov 2015 17:29:47 -0500
parents e6c5bb62fef8
children 57f6473b1469
comparison
equal deleted inserted replaced
2298:6e580e319077 2299:47d5c94aeeb8
91 91
92 val cacheRef = ref LruCache.cache 92 val cacheRef = ref LruCache.cache
93 fun setCache c = cacheRef := c 93 fun setCache c = cacheRef := c
94 fun getCache () = !cacheRef 94 fun getCache () = !cacheRef
95 95
96 val alwaysConsolidateRef = ref true 96 datatype heuristic = Always | Never | NoPureAll | NoPureOne | NoCombo
97 fun setAlwaysConsolidate b = alwaysConsolidateRef := b 97
98 fun getAlwaysConsolidate () = !alwaysConsolidateRef 98 val heuristicRef = ref Always
99 fun setHeuristic h = heuristicRef := (case h of
100 "always" => Always
101 | "never" => Never
102 | "nopureall" => NoPureAll
103 | "nopureone" => NoPureOne
104 | "nocombo" => NoCombo
105 | _ => raise Fail "Sqlcache: setHeuristic")
106 fun getHeuristic () = !heuristicRef
99 107
100 108
101 (************************) 109 (************************)
102 (* Really Useful Things *) 110 (* Really Useful Things *)
103 (************************) 111 (************************)
461 ffiInfo : {index : int, params : int} list, 469 ffiInfo : {index : int, params : int} list,
462 index : int} 470 index : int}
463 val empty : t 471 val empty : t
464 val singleton : Sql.query -> t 472 val singleton : Sql.query -> t
465 val query : t -> Sql.query 473 val query : t -> Sql.query
466 val orderArgs : t * Mono.exp -> cacheArg list 474 val orderArgs : t * Mono.exp -> cacheArg list option
467 val unbind : t * unbind -> t option 475 val unbind : t * unbind -> t option
468 val union : t * t -> t 476 val union : t * t -> t
469 val updateState : t * int * state -> state 477 val updateState : t * int * state -> state
470 end = struct 478 end = struct
471 479
633 val paths = freePaths exp 641 val paths = freePaths exp
634 fun erel n = (ERel n, dummyLoc) 642 fun erel n = (ERel n, dummyLoc)
635 val argsMap = sqlArgsMap qs 643 val argsMap = sqlArgsMap qs
636 val args = map (expOfArg o #1) (AM.listItemsi argsMap) 644 val args = map (expOfArg o #1) (AM.listItemsi argsMap)
637 val invalPaths = List.foldl PS.union PS.empty (map freePaths args) 645 val invalPaths = List.foldl PS.union PS.empty (map freePaths args)
646 (* TODO: make sure these variables are okay to remove from the argument list. *)
647 val pureArgs = PS.difference (paths, invalPaths)
648 val shouldCache =
649 case getHeuristic () of
650 Always => true
651 | Never => (case qs of [_] => true | _ => false)
652 | NoPureAll => (case qs of [] => false | _ => true)
653 | NoPureOne => (case qs of [] => false | _ => PS.numItems pureArgs = 0)
654 | NoCombo => PS.numItems pureArgs = 0 orelse AM.numItems argsMap = 0
638 in 655 in
639 (* Put arguments we might invalidate by first. *) 656 (* Put arguments we might invalidate by first. *)
640 map AsIs args 657 if shouldCache
641 (* TODO: make sure these variables are okay to remove from the argument list. *) 658 then SOME (map AsIs args @ map (Urlify o expOfPath) (PS.listItems pureArgs))
642 @ map (Urlify o expOfPath) (PS.listItems (PS.difference (paths, invalPaths))) 659 else NONE
643 end 660 end
644 661
645 (* As a kludge, we rename the variables in the query to correspond to the 662 (* As a kludge, we rename the variables in the query to correspond to the
646 argument of the cache they're part of. *) 663 argument of the cache they're part of. *)
647 fun query (qs : t) = 664 fun query (qs : t) =
1307 1324
1308 val worthCaching = 1325 val worthCaching =
1309 fn EQuery _ => true 1326 fn EQuery _ => true
1310 | exp' => expSize (exp', dummyLoc) > sizeWorthCaching 1327 | exp' => expSize (exp', dummyLoc) > sizeWorthCaching
1311 1328
1312 fun shouldConsolidate args =
1313 let
1314 val isAsIs = fn AsIs _ => true | Urlify _ => false
1315 in
1316 getAlwaysConsolidate ()
1317 orelse not (List.exists isAsIs args andalso List.exists (not o isAsIs) args)
1318 end
1319
1320 fun cacheExp (env, exp', invalInfo, state : state) = 1329 fun cacheExp (env, exp', invalInfo, state : state) =
1321 case worthCaching exp' <\oguard\> (fn _ => typOfExp' env exp') of 1330 case worthCaching exp' <\oguard\> (fn _ => typOfExp' env exp') of
1322 NONE => NONE 1331 NONE => NONE
1323 | SOME (TFun _, _) => NONE 1332 | SOME (TFun _, _) => NONE
1324 | SOME typ => 1333 | SOME typ =>
1325 let 1334 InvalInfo.orderArgs (invalInfo, (exp', dummyLoc))
1326 val args = InvalInfo.orderArgs (invalInfo, (exp', dummyLoc)) 1335 <\obind\>
1327 in 1336 (fn args =>
1328 shouldConsolidate args 1337 List.foldr (fn (arg, acc) =>
1329 <\oguard\> 1338 acc
1330 (fn _ => 1339 <\obind\>
1331 List.foldr (fn (arg, acc) => 1340 (fn args' =>
1332 acc 1341 (case arg of
1333 <\obind\> 1342 AsIs exp => SOME exp
1334 (fn args' => 1343 | Urlify exp =>
1335 (case arg of 1344 typOfExp env exp
1336 AsIs exp => SOME exp 1345 <\obind\>
1337 | Urlify exp => 1346 (fn typ => (MonoFooify.urlify env (exp, typ))))
1338 typOfExp env exp 1347 <\obind\>
1339 <\obind\> 1348 (fn arg' => SOME (arg' :: args'))))
1340 (fn typ => (MonoFooify.urlify env (exp, typ)))) 1349 (SOME [])
1341 <\obind\> 1350 args
1342 (fn arg' => SOME (arg' :: args')))) 1351 <\obind\>
1343 (SOME []) 1352 (fn args' =>
1344 args 1353 cacheWrap (env, (exp', dummyLoc), typ, args', #index state)
1345 <\obind\> 1354 <\obind\>
1346 (fn args' => 1355 (fn cachedExp =>
1347 cacheWrap (env, (exp', dummyLoc), typ, args', #index state) 1356 SOME (cachedExp,
1348 <\obind\> 1357 InvalInfo.updateState (invalInfo, length args', state)))))
1349 (fn cachedExp =>
1350 SOME (cachedExp,
1351 InvalInfo.updateState (invalInfo, length args', state)))))
1352 end
1353 1358
1354 fun cacheQuery (effs, env, q) : subexp = 1359 fun cacheQuery (effs, env, q) : subexp =
1355 let 1360 let
1356 (* We use dummyTyp here. I think this is okay because databases don't 1361 (* We use dummyTyp here. I think this is okay because databases don't
1357 store (effectful) functions, but perhaps there's some pathalogical 1362 store (effectful) functions, but perhaps there's some pathalogical
1682 val go' = addLocking o addFlushing o addCaching o simplifySql o inlineSql 1687 val go' = addLocking o addFlushing o addCaching o simplifySql o inlineSql
1683 1688
1684 fun go file = 1689 fun go file =
1685 let 1690 let
1686 (* TODO: do something nicer than [Sql] being in one of two modes. *) 1691 (* TODO: do something nicer than [Sql] being in one of two modes. *)
1687 val () = (resetFfiInfo (); Sql.sqlcacheMode := true) 1692 val () = (resetFfiInfo ();
1693 Sql.sqlcacheMode := true;
1694 setHeuristic (Settings.getSqlcacheHeuristic ()))
1688 val file = go' file 1695 val file = go' file
1689 (* Important that this happens after [MonoFooify.urlify] calls! *) 1696 (* Important that this happens after [MonoFooify.urlify] calls! *)
1690 val fmDecls = MonoFooify.getNewFmDecls () 1697 val fmDecls = MonoFooify.getNewFmDecls ()
1691 val () = Sql.sqlcacheMode := false 1698 val () = Sql.sqlcacheMode := false
1692 in 1699 in