Mercurial > urweb

comparison src/lru_cache.sml @ 2304:6fb9232ade99

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge Sqlcache
author Adam Chlipala <adam@chlipala.net>
date Sun, 20 Dec 2015 14:18:52 -0500
parents 6e580e319077
children
comparison
equal deleted inserted replaced
2201:1091227f535a 2304:6fb9232ade99
1 structure LruCache : sig
2 val cache : Cache.cache
3 end = struct
4
5
6 (* Mono *)
7
8 open Mono
9
10 val dummyLoc = ErrorMsg.dummySpan
11 val stringTyp = (TFfi ("Basis", "string"), dummyLoc)
12 val optionStringTyp = (TOption stringTyp, dummyLoc)
13 fun withTyp typ = map (fn exp => (exp, typ))
14
15 fun ffiAppCache' (func, index, argTyps) =
16 EFfiApp ("Sqlcache", func ^ Int.toString index, argTyps)
17
18 fun check (index, keys) =
19 ffiAppCache' ("check", index, withTyp stringTyp keys)
20
21 fun store (index, keys, value) =
22 ffiAppCache' ("store", index, (value, stringTyp) :: withTyp stringTyp keys)
23
24 fun flush (index, keys) =
25 ffiAppCache' ("flush", index, withTyp optionStringTyp keys)
26
27 fun lock (index, write) =
28 ffiAppCache' ((if write then "w" else "r") ^ "lock", index, [])
29
30
31 (* Cjr *)
32
33 open Print
34 open Print.PD
35
36 fun setupQuery {index, params} =
37 let
38
39 val i = Int.toString index
40
41 fun paramRepeat itemi sep =
42 let
43 fun f n =
44 if n < 0 then ""
45 else if n = 0 then itemi (Int.toString 0)
46 else f (n-1) ^ sep ^ itemi (Int.toString n)
47 in
48 f (params - 1)
49 end
50
51 fun paramRepeatRev itemi sep =
52 let
53 fun f n =
54 if n < 0 then ""
55 else if n = 0 then itemi (Int.toString 0)
56 else itemi (Int.toString n) ^ sep ^ f (n-1)
57 in
58 f (params - 1)
59 end
60
61 fun paramRepeatInit itemi sep =
62 if params = 0 then "" else sep ^ paramRepeat itemi sep
63
64 val typedArgs = paramRepeatInit (fn p => "uw_Basis_string p" ^ p) ", "
65
66 val revArgs = paramRepeatRev (fn p => "p" ^ p) ", "
67
68 val argNums = List.tabulate (params, fn i => "p" ^ Int.toString i)
69 in
70 Print.box
71 [string ("static uw_Sqlcache_Cache cacheStruct" ^ i ^ " = {"),
72 newline,
73 string " .lockIn = PTHREAD_RWLOCK_INITIALIZER,",
74 newline,
75 string " .lockOut = PTHREAD_RWLOCK_INITIALIZER,",
76 newline,
77 string " .table = NULL,",
78 newline,
79 string (" .numKeys = " ^ Int.toString params ^ ","),
80 newline,
81 string " .timeInvalid = 0,",
82 newline,
83 string " .timeNow = 0};",
84 newline,
85 string ("static uw_Sqlcache_Cache *cache" ^ i ^ " = &cacheStruct" ^ i ^ ";"),
86 newline,
87 newline,
88
89 string ("static void uw_Sqlcache_rlock" ^ i ^ "(uw_context ctx) {"),
90 newline,
91 string (" uw_Sqlcache_rlock(ctx, cache" ^ i ^ ");"),
92 newline,
93 string "}",
94 newline,
95 newline,
96
97 string ("static void uw_Sqlcache_wlock" ^ i ^ "(uw_context ctx) {"),
98 newline,
99 string (" uw_Sqlcache_wlock(ctx, cache" ^ i ^ ");"),
100 newline,
101 string "}",
102 newline,
103 newline,
104
105 string ("static uw_Basis_string uw_Sqlcache_check" ^ i),
106 string ("(uw_context ctx" ^ typedArgs ^ ") {"),
107 newline,
108 string (" char *ks[] = {" ^ revArgs ^ "};"),
109 newline,
110 string (" uw_Sqlcache_Value *v = uw_Sqlcache_check(ctx, cache" ^ i ^ ", ks);"),
111 newline,
112 (* If the output is null, it means we had too much recursion, so it's a miss. *)
113 string " if (v && v->output != NULL) {",
114 newline,
115 (*string (" puts(\"SQLCACHE: hit " ^ i ^ ".\");"),
116 newline,*)
117 string " uw_write(ctx, v->output);",
118 newline,
119 string " return v->result;",
120 newline,
121 string " } else {",
122 newline,
123 (*string (" printf(\"SQLCACHE: miss " ^ i ^ " " ^ String.concatWith ", " (List.tabulate (params, fn _ => "%s")) ^ ".\\n\""),
124 (case argNums of
125 [] => Print.box []
126 | _ => Print.box [string ", ",
127 p_list string argNums]),
128 string ");",
129 newline,*)
130 string " uw_recordingStart(ctx);",
131 newline,
132 string " return NULL;",
133 newline,
134 string " }",
135 newline,
136 string "}",
137 newline,
138 newline,
139
140 string ("static uw_unit uw_Sqlcache_store" ^ i),
141 string ("(uw_context ctx, uw_Basis_string s" ^ typedArgs ^ ") {"),
142 newline,
143 string (" char *ks[] = {" ^ revArgs ^ "};"),
144 newline,
145 string (" uw_Sqlcache_Value *v = malloc(sizeof(uw_Sqlcache_Value));"),
146 newline,
147 string " v->result = strdup(s);",
148 newline,
149 string " v->output = uw_recordingRead(ctx);",
150 newline,
151 (*string (" puts(\"SQLCACHE: stored " ^ i ^ ".\");"),
152 newline,*)
153 string (" uw_Sqlcache_store(ctx, cache" ^ i ^ ", ks, v);"),
154 newline,
155 string " return uw_unit_v;",
156 newline,
157 string "}",
158 newline,
159 newline,
160
161 string ("static uw_unit uw_Sqlcache_flush" ^ i),
162 string ("(uw_context ctx" ^ typedArgs ^ ") {"),
163 newline,
164 string (" char *ks[] = {" ^ revArgs ^ "};"),
165 newline,
166 string (" uw_Sqlcache_flush(ctx, cache" ^ i ^ ", ks);"),
167 newline,
168 (*string (" puts(\"SQLCACHE: flushed " ^ i ^ ".\");"),
169 newline,*)
170 string " return uw_unit_v;",
171 newline,
172 string "}",
173 newline,
174 newline]
175 end
176
177 val setupGlobal = string "/* No global setup for LRU cache. */"
178
179
180 (* Bundled up. *)
181
182 (* For now, use the toy implementation if there are no arguments. *)
183 fun toyIfNoKeys numKeys implLru implToy args =
184 if numKeys args = 0
185 then implToy args
186 else implLru args
187
188 val cache =
189 (* let *)
190 (* val {check = toyCheck, *)
191 (* store = toyStore, *)
192 (* flush = toyFlush, *)
193 (* setupQuery = toySetupQuery, *)
194 (* ...} = ToyCache.cache *)
195 (* in *)
196 (* {check = toyIfNoKeys (length o #2) check toyCheck, *)
197 (* store = toyIfNoKeys (length o #2) store toyStore, *)
198 (* flush = toyIfNoKeys (length o #2) flush toyFlush, *)
199 {check = check, store = store, flush = flush, lock = lock,
200 setupQuery = setupQuery, setupGlobal = setupGlobal}
201 (* end *)
202
203 end