Mercurial > urweb

comparison src/sqlcache.sml @ 2215:639e62ca2530

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Mostly finish effectfulness analysis.
author Ziv Scully <ziv@mit.edu>
date Fri, 31 Oct 2014 09:25:03 -0400
parents 365727ff68f4
children 70ec9bb337be
comparison
equal deleted inserted replaced
2214:edd634b889d0 2215:639e62ca2530
13 (* Filled in by cacheWrap during Sqlcache. *) 13 (* Filled in by cacheWrap during Sqlcache. *)
14 val ffiInfo : {index : int, params : int} list ref = ref [] 14 val ffiInfo : {index : int, params : int} list ref = ref []
15 15
16 fun getFfiInfo () = !ffiInfo 16 fun getFfiInfo () = !ffiInfo
17 17
18 (* Program analysis. *) 18 (* Some FFIs have writing as their only effect, which the caching records. *)
19 val ffiEffectful =
20 let
21 val fs = SS.fromList ["htmlifyInt_w",
22 "htmlifyFloat_w",
23 "htmlifyString_w",
24 "htmlifyBool_w",
25 "htmlifyTime_w",
26 "attrifyInt_w",
27 "attrifyFloat_w",
28 "attrifyString_w",
29 "attrifyChar_w",
30 "urlifyInt_w",
31 "urlifyFloat_w",
32 "urlifyString_w",
33 "urlifyBool_w",
34 "urlifyChannel_w"]
35 in
36 fn (m, f) => Settings.isEffectful (m, f)
37 andalso not (m = "Basis" andalso SS.member (fs, f))
38 end
39
40
41 (* Effect analysis. *)
42
43 (* Makes an exception for EWrite (which is recorded when caching). *)
44 fun effectful doPrint (effs : IS.set) (inFunction : bool) (bound : int) : Mono.exp -> bool =
45 (* If result is true, expression is definitely effectful. If result is
46 false, then expression is definitely not effectful if effs is fully
47 populated. The intended pattern is to use this a number of times equal
48 to the number of declarations in a file, Bellman-Ford style. *)
49 (* TODO: make incrementing of bound less janky, probably by using MonoUtil
50 instead of all this. *)
51 let
52 (* DEBUG: remove printing when done. *)
53 fun tru msg = if doPrint then (print (msg ^ "\n"); true) else true
54 val rec eff' =
55 (* ASK: is there a better way? *)
56 fn EPrim _ => false
57 (* We don't know if local functions have effects when applied. *)
58 | ERel idx => if inFunction andalso idx >= bound
59 then tru ("rel" ^ Int.toString idx) else false
60 | ENamed name => if IS.member (effs, name) then tru "named" else false
61 | ECon (_, _, NONE) => false
62 | ECon (_, _, SOME e) => eff e
63 | ENone _ => false
64 | ESome (_, e) => eff e
65 (* TODO: use FFI whitelist. *)
66 | EFfi (m, f) => if ffiEffectful (m, f) then tru "ffi" else false
67 | EFfiApp (m, f, _) => if ffiEffectful (m, f) then tru "ffiapp" else false
68 (* ASK: we're calling functions effectful if they have effects when
69 applied or if the function expressions themselves have effects.
70 Is that okay? *)
71 (* This is okay because the values we ultimately care about aren't
72 functions, and this is a conservative approximation, anyway. *)
73 | EApp (eFun, eArg) => effectful doPrint effs true bound eFun orelse eff eArg
74 | EAbs (_, _, _, e) => effectful doPrint effs inFunction (bound+1) e
75 | EUnop (_, e) => eff e
76 | EBinop (_, _, e1, e2) => eff e1 orelse eff e2
77 | ERecord xs => List.exists (fn (_, e, _) => eff e) xs
78 | EField (e, _) => eff e
79 (* If any case could be effectful, consider it effectful. *)
80 | ECase (e, xs, _) => eff e orelse List.exists (fn (_, e) => eff e) xs
81 | EStrcat (e1, e2) => eff e1 orelse eff e2
82 (* ASK: how should we treat these three? *)
83 | EError _ => tru "error"
84 | EReturnBlob _ => tru "blob"
85 | ERedirect _ => tru "redirect"
86 (* EWrite is a special exception because we record writes when caching. *)
87 | EWrite _ => false
88 | ESeq (e1, e2) => eff e1 orelse eff e2
89 (* TODO: keep context of which local variables aren't effectful? Only
90 makes a difference for function expressions, though. *)
91 | ELet (_, _, eBind, eBody) => eff eBind orelse
92 effectful doPrint effs inFunction (bound+1) eBody
93 | EClosure (_, es) => List.exists eff es
94 (* TODO: deal with EQuery. *)
95 | EQuery _ => tru "query"
96 | EDml _ => tru "dml"
97 | ENextval _ => tru "nextval"
98 | ESetval _ => tru "setval"
99 | EUnurlify (e, _, _) => eff e
100 (* ASK: how should we treat this? *)
101 | EJavaScript _ => tru "javascript"
102 (* ASK: these are all effectful, right? *)
103 | ESignalReturn _ => tru "signalreturn"
104 | ESignalBind _ => tru "signalbind"
105 | ESignalSource _ => tru "signalsource"
106 | EServerCall _ => tru "servercall"
107 | ERecv _ => tru "recv"
108 | ESleep _ => tru "sleep"
109 | ESpawn _ => tru "spawn"
110 and eff = fn (e', _) => eff' e'
111 in
112 eff
113 end
114
115 (* TODO: test this. *)
116 val effectfulMap =
117 let
118 fun doVal ((_, name, _, e, _), effMap) =
119 if effectful false effMap false 0 e
120 then IS.add (effMap, name)
121 else effMap
122 val doDecl =
123 fn (DVal v, effMap) => doVal (v, effMap)
124 (* Repeat the list of declarations a number of times equal to its size. *)
125 | (DValRec vs, effMap) =>
126 List.foldl doVal effMap (List.concat (List.map (fn _ => vs) vs))
127 (* ASK: any other cases? *)
128 | (_, effMap) => effMap
129 in
130 MonoUtil.File.fold {typ = #2, exp = #2, decl = doDecl} IS.empty
131 end
132
133
134 (* SQL analysis. *)
19 135
20 val useInjIfPossible = 136 val useInjIfPossible =
21 fn SqConst prim => Inj (EPrim (Prim.String (Prim.Normal, Prim.toString prim)), ErrorMsg.dummySpan) 137 fn SqConst prim => Inj (EPrim (Prim.String (Prim.Normal, Prim.toString prim)),
138 ErrorMsg.dummySpan)
22 | sqexp => sqexp 139 | sqexp => sqexp
23 140
24 fun equalities (canonicalTable : string -> string) : 141 fun equalities (canonicalTable : string -> string) :
25 sqexp -> ((string * string) * Mono.exp) list option = 142 sqexp -> ((string * string) * Mono.exp) list option =
26 let 143 let
87 | Update (tab, _, _) => tab 204 | Update (tab, _, _) => tab
88 205
89 206
90 (* Program instrumentation. *) 207 (* Program instrumentation. *)
91 208
209 fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), ErrorMsg.dummySpan)
92 val stringTyp = (TFfi ("Basis", "string"), ErrorMsg.dummySpan) 210 val stringTyp = (TFfi ("Basis", "string"), ErrorMsg.dummySpan)
93 211
94 val sequence = 212 val sequence =
95 fn (exp :: exps) => 213 fn (exp :: exps) =>
96 let 214 let
101 | _ => raise Match 219 | _ => raise Match
102 220
103 fun ffiAppCache' (func, index, args) : Mono.exp' = 221 fun ffiAppCache' (func, index, args) : Mono.exp' =
104 EFfiApp ("Sqlcache", func ^ Int.toString index, args) 222 EFfiApp ("Sqlcache", func ^ Int.toString index, args)
105 223
106 fun ffiAppCache (func, index, args) : Mono. exp = 224 fun ffiAppCache (func, index, args) : Mono.exp =
107 (ffiAppCache' (func, index, args), ErrorMsg.dummySpan) 225 (ffiAppCache' (func, index, args), ErrorMsg.dummySpan)
108 226
109 val varPrefix = "queryResult" 227 val varPrefix = "queryResult"
110 228
111 fun indexOfName varName = 229 fun indexOfName varName =
112 if String.isPrefix varPrefix varName 230 if String.isPrefix varPrefix varName
113 then Int.fromString (String.extract (varName, String.size varPrefix, NONE)) 231 then Int.fromString (String.extract (varName, String.size varPrefix, NONE))
114 else NONE 232 else NONE
115 233
116 val incRels = MonoUtil.Exp.map {typ = fn x => x, exp = fn ERel n => ERel (n + 1) | x => x} 234 (* Always increments negative indices because that's what we need later. *)
235 fun incRelsBound bound inc =
236 MonoUtil.Exp.mapB
237 {typ = fn x => x,
238 exp = fn level =>
239 (fn ERel n => ERel (if n >= level orelse n < 0 then n + inc else n)
240 | x => x),
241 bind = fn (level, MonoUtil.Exp.RelE _) => level + 1 | (level, _) => level}
242 bound
243
244 val incRels = incRelsBound 0
117 245
118 (* Filled in by instrumentQuery during Monoize, used during Sqlcache. *) 246 (* Filled in by instrumentQuery during Monoize, used during Sqlcache. *)
119 val urlifiedRel0s : Mono.exp IM.map ref = ref IM.empty 247 val urlifiedRel0s : Mono.exp IM.map ref = ref IM.empty
120 248
121 (* Used by Monoize. *) 249 (* Used by Monoize. *)
127 (EQuery {state = typ, ...}, loc) => 255 (EQuery {state = typ, ...}, loc) =>
128 let 256 let
129 val i = !nextQuery before nextQuery := !nextQuery + 1 257 val i = !nextQuery before nextQuery := !nextQuery + 1
130 in 258 in
131 urlifiedRel0s := IM.insert (!urlifiedRel0s, i, urlifiedRel0); 259 urlifiedRel0s := IM.insert (!urlifiedRel0s, i, urlifiedRel0);
132 (* ASK: name variables properly? *)
133 (ELet (varPrefix ^ Int.toString i, typ, query, 260 (ELet (varPrefix ^ Int.toString i, typ, query,
134 (* Uses a dummy FFI call to keep the urlified expression around, which 261 (* Uses a dummy FFI call to keep the urlified expression around, which
135 in turn keeps the declarations required for urlification safe from 262 in turn keeps the declarations required for urlification safe from
136 MonoShake. The dummy call is removed during Sqlcache. *) 263 MonoShake. The dummy call is removed during Sqlcache. *)
137 (* ASK: is there a better way? *) 264 (* TODO: thread a Monoize.Fm.t through this module. *)
138 (ESeq ((EFfiApp ("Sqlcache", "dummy", [(urlifiedRel0, stringTyp)]), loc), 265 (ESeq ((EFfiApp ("Sqlcache", "dummy", [(urlifiedRel0, stringTyp)]), loc),
139 (ERel 0, loc)), 266 (ERel 0, loc)),
140 loc)), 267 loc)),
141 loc) 268 loc)
142 end 269 end
143 | _ => raise Match 270 | _ => raise Match
144 in 271 in
145 iq 272 iq
146 end 273 end
147 274
148 val gunk : ((string * string) * Mono.exp) list list ref = ref [[]]
149
150 fun cacheWrap (query, i, urlifiedRel0, eqs) = 275 fun cacheWrap (query, i, urlifiedRel0, eqs) =
151 case query of 276 case query of
152 (EQuery {state = typ, ...}, _) => 277 (EQuery {state = typ, ...}, _) =>
153 let 278 let
279 val () = ffiInfo := {index = i, params = length eqs} :: !ffiInfo
154 val loc = ErrorMsg.dummySpan 280 val loc = ErrorMsg.dummySpan
155 (* TODO: deal with effectful injected expressions. *) 281 (* We ensure before this step that all arguments aren't effectful.
156 val args = (ffiInfo := {index = i, params = length eqs} :: !ffiInfo; 282 by turning them into local variables as needed. *)
157 map (fn (_, e) => (e, stringTyp)) eqs) before gunk := eqs :: !gunk 283 val args = map (fn (_, e) => (e, stringTyp)) eqs
158 val argsInc = map (fn (e, t) => (incRels e, t)) args 284 val argsInc = map (fn (e, typ) => (incRels 1 e, typ)) args
285 val check = ffiAppCache ("check", i, args)
286 val store = ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argsInc)
287 val rel0 = (ERel 0, loc)
159 in 288 in
160 (ECase (ffiAppCache ("check", i, args), 289 (ECase (check,
161 [((PNone stringTyp, loc), 290 [((PNone stringTyp, loc),
162 (ELet ("q", typ, query, 291 (ELet ("q", typ, query, (ESeq (store, rel0), loc)), loc)),
163 (ESeq (ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argsInc),
164 (ERel 0, loc)),
165 loc)),
166 loc)),
167 ((PSome (stringTyp, (PVar ("hit", stringTyp), loc)), loc), 292 ((PSome (stringTyp, (PVar ("hit", stringTyp), loc)), loc),
168 (* ASK: what does this bool do? *) 293 (* Boolean is false because we're not unurlifying from a cookie. *)
169 (EUnurlify ((ERel 0, loc), typ, false), loc))], 294 (EUnurlify (rel0, typ, false), loc))],
170 {disc = stringTyp, result = typ}), 295 {disc = stringTyp, result = typ}),
171 loc) 296 loc)
172 end 297 end
173 | _ => raise Match 298 | _ => raise Match
174 299
179 Search.Continue x => x 304 Search.Continue x => x
180 | Search.Return _ => raise Match 305 | Search.Return _ => raise Match
181 306
182 fun fileMap doExp file = #1 (fileMapfold (fn x => fn _ => (doExp x, ())) file ()) 307 fun fileMap doExp file = #1 (fileMapfold (fn x => fn _ => (doExp x, ())) file ())
183 308
184 val addChecking = 309 fun addChecking file =
185 let 310 let
186 fun doExp queryInfo = 311 fun doExp queryInfo =
187 fn e' as ELet (v, t, queryExp as (EQuery {query = queryText, ...}, _), body) => 312 fn e' as ELet (v, t,
313 queryExp' as (EQuery {query = origQueryText,
314 initial, body, state, tables, exps}, queryLoc),
315 letBody) =>
188 let 316 let
317 val loc = ErrorMsg.dummySpan
318 val chunks = chunkify origQueryText
319 fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
320 val (newQueryText, newVariables) =
321 (* Important that this is foldr (to oppose foldl below). *)
322 List.foldr
323 (fn (chunk, (qText, newVars)) =>
324 case chunk of
325 Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars)
326 | Exp (e as (ERel _, _)) => (strcat (e, qText), newVars)
327 | Exp (e as (ENamed _, _)) => (strcat (e, qText), newVars)
328 (* Head of newVars has lowest index. *)
329 | Exp e =>
330 let
331 val n = length newVars
332 in
333 (* This is the (n + 1)th new variable, so
334 there are already n new variables bound,
335 so we increment indices by n. *)
336 (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars)
337 end
338 | String s => (strcat (stringExp s, qText), newVars))
339 (stringExp "", [])
340 chunks
341 fun wrapLets e' =
342 (* Important that this is foldl (to oppose foldr above). *)
343 List.foldl (fn (v, e') => ELet ("sqlArgz", stringTyp, v, (e', loc))) e' newVariables
344 (* Increment once for each new variable just made. *)
345 val queryExp = incRels (length newVariables)
346 (EQuery {query = newQueryText,
347 initial = initial,
348 body = body,
349 state = state,
350 tables = tables,
351 exps = exps},
352 queryLoc)
353 val (EQuery {query = queryText, ...}, _) = queryExp
354 (* val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText)); *)
189 fun bind x f = Option.mapPartial f x 355 fun bind x f = Option.mapPartial f x
356 fun guard b x = if b then x else NONE
357 (* DEBUG: set first boolean argument to true to turn on printing. *)
358 fun safe bound = not o effectful true (effectfulMap file) false bound
190 val attempt = 359 val attempt =
191 (* Ziv misses Haskell's do notation.... *) 360 (* Ziv misses Haskell's do notation.... *)
361 guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) (
192 bind (parse query queryText) (fn queryParsed => 362 bind (parse query queryText) (fn queryParsed =>
193 (Print.preface ("gunk> ", (MonoPrint.p_exp MonoEnv.empty queryExp));
194 bind (indexOfName v) (fn i => 363 bind (indexOfName v) (fn i =>
195 bind (equalitiesQuery queryParsed) (fn eqs => 364 bind (equalitiesQuery queryParsed) (fn eqs =>
196 bind (IM.find (!urlifiedRel0s, i)) (fn urlifiedRel0 => 365 bind (IM.find (!urlifiedRel0s, i)) (fn urlifiedRel0 =>
197 SOME (ELet (v, t, cacheWrap (queryExp, i, urlifiedRel0, eqs), body), 366 SOME (wrapLets (ELet (v, t,
367 cacheWrap (queryExp, i, urlifiedRel0, eqs),
368 incRelsBound 1 (length newVariables) letBody)),
198 SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, i)) 369 SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, i))
199 queryInfo 370 queryInfo
200 (tablesQuery queryParsed))))))) 371 (tablesQuery queryParsed)))))))
201 in 372 in
202 case attempt of 373 case attempt of
204 | NONE => (e', queryInfo) 375 | NONE => (e', queryInfo)
205 end 376 end
206 | ESeq ((EFfiApp ("Sqlcache", "dummy", _), _), (e', _)) => (e', queryInfo) 377 | ESeq ((EFfiApp ("Sqlcache", "dummy", _), _), (e', _)) => (e', queryInfo)
207 | e' => (e', queryInfo) 378 | e' => (e', queryInfo)
208 in 379 in
209 fn file => fileMapfold (fn exp => fn state => doExp state exp) file SIMM.empty 380 fileMapfold (fn exp => fn state => doExp state exp) file SIMM.empty
210 end 381 end
211 382
212 fun addFlushing (file, queryInfo) = 383 fun addFlushing (file, queryInfo) =
213 let 384 let
214 val allIndices : int list = SM.foldr (fn (x, acc) => IS.listItems x @ acc) [] queryInfo 385 val allIndices : int list = SM.foldr (fn (x, acc) => IS.listItems x @ acc) [] queryInfo
229 end 400 end
230 401
231 fun go file = 402 fun go file =
232 let 403 let
233 val () = Sql.sqlcacheMode := true 404 val () = Sql.sqlcacheMode := true
234 in 405 val file' = addFlushing (addChecking file)
235 addFlushing (addChecking file) before Sql.sqlcacheMode := false 406 val () = Sql.sqlcacheMode := false
407 in
408 file'
236 end 409 end
237 410
238 411
239 (* BEGIN OLD 412 (* BEGIN OLD
240 413