Mercurial > urweb

comparison src/sqlcache.sml @ 2286:0bdfec16a01d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix issue with one-element caches. Locking still WIP.
author Ziv Scully <ziv@mit.edu>
date Fri, 13 Nov 2015 01:04:32 -0500
parents b7615e0ac4b0
children 98f96a976ede
comparison
equal deleted inserted replaced
2285:ad3ce1528f71 2286:0bdfec16a01d
1 structure Sqlcache :> SQLCACHE = struct 1 structure Sqlcache :> SQLCACHE = struct
2 2
3 open Mono 3
4 (*********************)
5 (* General Utilities *)
6 (*********************)
4 7
5 structure IK = struct type ord_key = int val compare = Int.compare end 8 structure IK = struct type ord_key = int val compare = Int.compare end
6 structure IS = IntBinarySet 9 structure IS = IntBinarySet
7 structure IM = IntBinaryMap 10 structure IM = IntBinaryMap
8 structure SK = struct type ord_key = string val compare = String.compare end 11 structure SK = struct type ord_key = string val compare = String.compare end
9 structure SS = BinarySetFn(SK) 12 structure SS = BinarySetFn(SK)
10 structure SM = BinaryMapFn(SK) 13 structure SM = BinaryMapFn(SK)
14 structure IIMM = MultimapFn(structure KeyMap = IM structure ValSet = IS)
11 structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS) 15 structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS)
12
13 (* ASK: how do we deal with heap reallocation? *)
14 16
15 fun id x = x 17 fun id x = x
16 18
17 fun iterate f n x = if n < 0 19 fun iterate f n x = if n < 0
18 then raise Fail "Can't iterate function negative number of times." 20 then raise Fail "Can't iterate function negative number of times."
19 else if n = 0 21 else if n = 0
20 then x 22 then x
21 else iterate f (n-1) (f x) 23 else iterate f (n-1) (f x)
24
25 (* From the MLton wiki. *)
26 infix 3 <\ fun x <\ f = fn y => f (x, y) (* Left section *)
27 infix 3 \> fun f \> y = f y (* Left application *)
28
29 fun mapFst f (x, y) = (f x, y)
30
31 (* Option monad. *)
32 fun obind (x, f) = Option.mapPartial f x
33 fun oguard (b, x) = if b then x else NONE
34 fun omap f = fn SOME x => SOME (f x) | _ => NONE
35 fun omap2 f = fn (SOME x, SOME y) => SOME (f (x,y)) | _ => NONE
36 fun osequence ys = List.foldr (omap2 op::) (SOME []) ys
37
38 fun indexOf test =
39 let
40 fun f n =
41 fn [] => NONE
42 | (x::xs) => if test x then SOME n else f (n+1) xs
43 in
44 f 0
45 end
46
47
48 (************)
49 (* Settings *)
50 (************)
51
52 open Mono
22 53
23 (* Filled in by [addFlushing]. *) 54 (* Filled in by [addFlushing]. *)
24 val ffiInfoRef : {index : int, params : int} list ref = ref [] 55 val ffiInfoRef : {index : int, params : int} list ref = ref []
25 56
26 fun resetFfiInfo () = ffiInfoRef := [] 57 fun resetFfiInfo () = ffiInfoRef := []
57 88
58 val alwaysConsolidateRef = ref true 89 val alwaysConsolidateRef = ref true
59 fun setAlwaysConsolidate b = alwaysConsolidateRef := b 90 fun setAlwaysConsolidate b = alwaysConsolidateRef := b
60 fun getAlwaysConsolidate () = !alwaysConsolidateRef 91 fun getAlwaysConsolidate () = !alwaysConsolidateRef
61 92
93
94 (************************)
95 (* Really Useful Things *)
96 (************************)
97
62 (* Used to have type context for local variables in MonoUtil functions. *) 98 (* Used to have type context for local variables in MonoUtil functions. *)
63 val doBind = 99 val doBind =
64 fn (env, MonoUtil.Exp.RelE (x, t)) => MonoEnv.pushERel env x t NONE 100 fn (env, MonoUtil.Exp.RelE (x, t)) => MonoEnv.pushERel env x t NONE
65 | (env, MonoUtil.Exp.NamedE (x, n, t, eo, s)) => MonoEnv.pushENamed env x n t eo s 101 | (env, MonoUtil.Exp.NamedE (x, n, t, eo, s)) => MonoEnv.pushENamed env x n t eo s
66 | (env, MonoUtil.Exp.Datatype (x, n, cs)) => MonoEnv.pushDatatype env x n cs 102 | (env, MonoUtil.Exp.Datatype (x, n, cs)) => MonoEnv.pushDatatype env x n cs
77 NONE => NONE 113 NONE => NONE
78 | SOME x' => case f x' of 114 | SOME x' => case f x' of
79 NONE => (printer (); NONE) 115 NONE => (printer (); NONE)
80 | y => y 116 | y => y
81 117
82 (*********************)
83 (* General Utilities *)
84 (*********************)
85
86 (* From the MLton wiki. *)
87 infix 3 <\ fun x <\ f = fn y => f (x, y) (* Left section *)
88 infix 3 \> fun f \> y = f y (* Left application *)
89
90 fun mapFst f (x, y) = (f x, y)
91
92 (* Option monad. *)
93 fun obind (x, f) = Option.mapPartial f x
94 fun oguard (b, x) = if b then x else NONE
95 fun omap f = fn SOME x => SOME (f x) | _ => NONE
96 fun omap2 f = fn (SOME x, SOME y) => SOME (f (x,y)) | _ => NONE
97 fun osequence ys = List.foldr (omap2 op::) (SOME []) ys
98
99 fun indexOf test =
100 let
101 fun f n =
102 fn [] => NONE
103 | (x::xs) => if test x then SOME n else f (n+1) xs
104 in
105 f 0
106 end
107 118
108 (*******************) 119 (*******************)
109 (* Effect Analysis *) 120 (* Effect Analysis *)
110 (*******************) 121 (*******************)
122
123 (* TODO: test this. *)
124 fun transitiveAnalysis doVal state (decls, _) =
125 let
126 val doDecl =
127 fn ((DVal v, _), state) => doVal (v, state)
128 (* Pass over the list of values a number of times equal to its size,
129 making sure whatever property we're testing propagates everywhere
130 it should. This is analagous to the Bellman-Ford algorithm. *)
131 | ((DValRec vs, _), state) =>
132 iterate (fn state => List.foldl doVal state vs) (length vs) state
133 | (_, state) => state
134 in
135 List.foldl doDecl state decls
136 end
111 137
112 (* Makes an exception for [EWrite] (which is recorded when caching). *) 138 (* Makes an exception for [EWrite] (which is recorded when caching). *)
113 fun effectful (effs : IS.set) = 139 fun effectful (effs : IS.set) =
114 let 140 let
115 val isFunction = 141 val isFunction =
149 in 175 in
150 MonoUtil.Exp.existsB {typ = fn _ => false, exp = doExp, bind = doBind} 176 MonoUtil.Exp.existsB {typ = fn _ => false, exp = doExp, bind = doBind}
151 end 177 end
152 178
153 (* TODO: test this. *) 179 (* TODO: test this. *)
154 fun effectfulDecls (decls, _) = 180 fun effectfulDecls file =
155 let 181 transitiveAnalysis (fn ((_, name, _, e, _), effs) =>
156 fun doVal ((_, name, _, e, _), effs) = 182 if effectful effs MonoEnv.empty e
157 if effectful effs MonoEnv.empty e 183 then IS.add (effs, name)
158 then IS.add (effs, name) 184 else effs)
159 else effs 185 IS.empty
160 val doDecl = 186 file
161 fn ((DVal v, _), effs) => doVal (v, effs)
162 (* Repeat the list of declarations a number of times equal to its size,
163 making sure effectfulness propagates everywhere it should. This is
164 analagous to the Bellman-Ford algorithm. *)
165 | ((DValRec vs, _), effs) =>
166 List.foldl doVal effs (List.concat (List.map (fn _ => vs) vs))
167 (* ASK: any other cases? *)
168 | (_, effs) => effs
169 in
170 List.foldl doDecl IS.empty decls
171 end
172 187
173 188
174 (*********************************) 189 (*********************************)
175 (* Boolean Formula Normalization *) 190 (* Boolean Formula Normalization *)
176 (*********************************) 191 (*********************************)
1078 (* ASK: how should this (and other "=> NONE" cases) work? *) 1093 (* ASK: how should this (and other "=> NONE" cases) work? *)
1079 | EBinop _ => NONE 1094 | EBinop _ => NONE
1080 | ERecord fields => SOME (TRecord (map (fn (s, _, t) => (s, t)) fields), dummyLoc) 1095 | ERecord fields => SOME (TRecord (map (fn (s, _, t) => (s, t)) fields), dummyLoc)
1081 | EField (e, s) => (case typOfExp env e of 1096 | EField (e, s) => (case typOfExp env e of
1082 SOME (TRecord fields, _) => 1097 SOME (TRecord fields, _) =>
1083 (case List.find (fn (s', _) => s = s') fields of 1098 omap #2 (List.find (fn (s', _) => s = s') fields)
1084 SOME (_, t) => SOME t
1085 | _ => NONE)
1086 | _ => NONE) 1099 | _ => NONE)
1087 | ECase (_, _, {result, ...}) => SOME result 1100 | ECase (_, _, {result, ...}) => SOME result
1088 | EStrcat _ => SOME (TFfi ("Basis", "string"), dummyLoc) 1101 | EStrcat _ => SOME (TFfi ("Basis", "string"), dummyLoc)
1089 | EWrite _ => SOME (TRecord [], dummyLoc) 1102 | EWrite _ => SOME (TRecord [], dummyLoc)
1090 | ESeq (_, e) => typOfExp env e 1103 | ESeq (_, e) => typOfExp env e
1412 ffiInfoRef := ffiInfo; 1425 ffiInfoRef := ffiInfo;
1413 file 1426 file
1414 end 1427 end
1415 1428
1416 1429
1430 (***********)
1431 (* Locking *)
1432 (***********)
1433
1434 (* TODO: do this less evil-ly by not relying on specific FFI names, please? *)
1435 fun locksNeeded file =
1436 transitiveAnalysis
1437 (fn ((_, name, _, e, _), state) =>
1438 MonoUtil.Exp.fold
1439 {typ = #2,
1440 exp = fn (EFfiApp ("Sqlcache", x, _), state as {store, flush}) =>
1441 (case Int.fromString (String.extract (x, 5, NONE)) of
1442 NONE => raise Match
1443 | SOME index =>
1444 if String.isPrefix "store" x
1445 then {store = IIMM.insert (store, name, index), flush = flush}
1446 else if String.isPrefix "flush" x
1447 then {store = store, flush = IIMM.insert (flush, name, index)}
1448 else state)
1449 | _ => state}
1450 state
1451 e)
1452 {store = IIMM.empty, flush = IIMM.empty}
1453 file
1454
1455 fun exports (decls, _) =
1456 List.foldl (fn ((DExport (_, _, n, _, _, _), _), ns) => IS.add (ns, n)
1457 | ((DTask _, _), _) => raise Fail "Sqlcache doesn't yet support tasks."
1458 | (_, ns) => ns)
1459 IS.empty
1460 decls
1461
1462 (* fun addLocking file = *)
1463 (* let *)
1464 (* val whichLocks = locksNeeded file *)
1465 (* val needsLocks = exports file *)
1466 (* in *)
1467
1468 (* end *)
1469
1417 (************************) 1470 (************************)
1418 (* Compiler Entry Point *) 1471 (* Compiler Entry Point *)
1419 (************************) 1472 (************************)
1420 1473
1421 val inlineSql = 1474 val inlineSql =