Mercurial > urweb

comparison src/lru_cache.sml @ 2234:2f7ed04332a0

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Progress on LRU cache but still more known bugs to fix.
author Ziv Scully <ziv@mit.edu>
date Sun, 28 Jun 2015 12:46:51 -0700
parents
children 88cc0f44c940
comparison
equal deleted inserted replaced
2233:af1585e7d645 2234:2f7ed04332a0
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
28 (* Cjr *)
29
30 open Print
31 open Print.PD
32
33 fun setupQuery {index, params} =
34 let
35
36 val i = Int.toString index
37
38 fun paramRepeat itemi sep =
39 let
40 fun f n =
41 if n < 0 then ""
42 else if n = 0 then itemi (Int.toString 0)
43 else f (n-1) ^ sep ^ itemi (Int.toString n)
44 in
45 f (params - 1)
46 end
47
48 fun paramRepeatRev itemi sep =
49 let
50 fun f n =
51 if n < 0 then ""
52 else if n = 0 then itemi (Int.toString 0)
53 else itemi (Int.toString n) ^ sep ^ f (n-1)
54 in
55 f (params - 1)
56 end
57
58 fun paramRepeatInit itemi sep =
59 if params = 0 then "" else sep ^ paramRepeat itemi sep
60
61 val typedArgs = paramRepeatInit (fn p => "uw_Basis_string p" ^ p) ", "
62
63 val revArgs = paramRepeatRev (fn p => "p" ^ p) ", "
64
65 in
66 Print.box
67 [string ("static Cache cacheStruct" ^ i ^ " = {"),
68 newline,
69 string " .table = NULL,",
70 newline,
71 string " .timeInvalid = 0,",
72 newline,
73 string " .lru = NULL,",
74 newline,
75 string (" .height = " ^ Int.toString (params - 1) ^ "};"),
76 newline,
77 string ("static Cache *cache" ^ i ^ " = &cacheStruct" ^ i ^ ";"),
78 newline,
79 newline,
80
81 string ("static uw_Basis_string uw_Sqlcache_check" ^ i),
82 string ("(uw_context ctx" ^ typedArgs ^ ") {"),
83 newline,
84 string (" char *ks[] = {" ^ revArgs ^ "};"),
85 newline,
86 string (" CacheValue *v = check(cache" ^ i ^ ", ks);"),
87 newline,
88 string " if (v) {",
89 newline,
90 string (" puts(\"SQLCACHE: hit " ^ i ^ ".\");"),
91 newline,
92 string " uw_write(ctx, v->output);",
93 newline,
94 string " return v->result;",
95 newline,
96 string " } else {",
97 newline,
98 string (" puts(\"SQLCACHE: miss " ^ i ^ ".\");"),
99 newline,
100 string " uw_recordingStart(ctx);",
101 newline,
102 string " return NULL;",
103 newline,
104 string " }",
105 newline,
106 string "}",
107 newline,
108 newline,
109
110 string ("static uw_unit uw_Sqlcache_store" ^ i),
111 string ("(uw_context ctx, uw_Basis_string s" ^ typedArgs ^ ") {"),
112 newline,
113 string (" char *ks[] = {" ^ revArgs ^ "};"),
114 newline,
115 string (" CacheValue *v = malloc(sizeof(CacheValue));"),
116 newline,
117 string " v->result = strdup(s);",
118 newline,
119 string " v->output = uw_recordingRead(ctx);",
120 newline,
121 string (" puts(\"SQLCACHE: stored " ^ i ^ ".\");"),
122 newline,
123 string (" store(cache" ^ i ^ ", ks, v);"),
124 newline,
125 string " return uw_unit_v;",
126 newline,
127 string "}",
128 newline,
129 newline,
130
131 string ("static uw_unit uw_Sqlcache_flush" ^ i),
132 string ("(uw_context ctx" ^ typedArgs ^ ") {"),
133 newline,
134 string (" char *ks[] = {" ^ revArgs ^ "};"),
135 newline,
136 string (" flush(cache" ^ i ^ ", ks);"),
137 newline,
138 string " return uw_unit_v;",
139 newline,
140 string "}",
141 newline,
142 newline]
143 end
144
145 val setupGlobal = string "/* No global setup for LRU cache. */"
146
147
148 (* Bundled up. *)
149
150 (* For now, use the toy implementation if there are no arguments. *)
151 fun toyIfNoKeys numKeys implLru implToy args =
152 if numKeys args = 0
153 then implToy args
154 else implLru args
155
156 val cache =
157 let
158 val {check = toyCheck,
159 store = toyStore,
160 flush = toyFlush,
161 setupQuery = toySetupQuery,
162 ...} = ToyCache.cache
163 in
164 {check = toyIfNoKeys (length o #2) check toyCheck,
165 store = toyIfNoKeys (length o #2) store toyStore,
166 flush = toyIfNoKeys (length o #2) flush toyFlush,
167 setupQuery = toyIfNoKeys #params setupQuery toySetupQuery,
168 setupGlobal = setupGlobal}
169 end
170
171 end