Mercurial > urweb
comparison src/sqlcache.sml @ 2299:47d5c94aeeb8
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 |