Mercurial > urweb
comparison src/lru_cache.sml @ 2304:6fb9232ade99
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 |