Mercurial > urweb

annotate src/sqlcache.sml @ 2289:78820fa8f5a7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix bugs for lock calculation and SQL parsing and add support for tasks.
author Ziv Scully <ziv@mit.edu>
date Sun, 15 Nov 2015 14:18:35 -0500
parents 98f96a976ede
children 50ad02829abd
rev   line source
ziv@2289 1 structure Sqlcache (* DEBUG :> SQLCACHE *) = struct
ziv@2209 2
ziv@2286 3
ziv@2286 4 (*********************)
ziv@2286 5 (* General Utilities *)
ziv@2286 6 (*********************)
ziv@2209 7
ziv@2276 8 structure IK = struct type ord_key = int val compare = Int.compare end
ziv@2209 9 structure IS = IntBinarySet
ziv@2209 10 structure IM = IntBinaryMap
ziv@2213 11 structure SK = struct type ord_key = string val compare = String.compare end
ziv@2213 12 structure SS = BinarySetFn(SK)
ziv@2213 13 structure SM = BinaryMapFn(SK)
ziv@2286 14 structure IIMM = MultimapFn(structure KeyMap = IM structure ValSet = IS)
ziv@2213 15 structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS)
ziv@2209 16
ziv@2274 17 fun id x = x
ziv@2274 18
ziv@2250 19 fun iterate f n x = if n < 0
ziv@2250 20 then raise Fail "Can't iterate function negative number of times."
ziv@2250 21 else if n = 0
ziv@2250 22 then x
ziv@2250 23 else iterate f (n-1) (f x)
ziv@2250 24
ziv@2286 25 (* From the MLton wiki. *)
ziv@2286 26 infix 3 <\ fun x <\ f = fn y => f (x, y) (* Left section *)
ziv@2286 27 infix 3 \> fun f \> y = f y (* Left application *)
ziv@2286 28
ziv@2286 29 fun mapFst f (x, y) = (f x, y)
ziv@2286 30
ziv@2286 31 (* Option monad. *)
ziv@2286 32 fun obind (x, f) = Option.mapPartial f x
ziv@2286 33 fun oguard (b, x) = if b then x else NONE
ziv@2286 34 fun omap f = fn SOME x => SOME (f x) | _ => NONE
ziv@2286 35 fun omap2 f = fn (SOME x, SOME y) => SOME (f (x,y)) | _ => NONE
ziv@2286 36 fun osequence ys = List.foldr (omap2 op::) (SOME []) ys
ziv@2286 37
ziv@2286 38 fun indexOf test =
ziv@2286 39 let
ziv@2286 40 fun f n =
ziv@2286 41 fn [] => NONE
ziv@2286 42 | (x::xs) => if test x then SOME n else f (n+1) xs
ziv@2286 43 in
ziv@2286 44 f 0
ziv@2286 45 end
ziv@2286 46
ziv@2286 47
ziv@2286 48 (************)
ziv@2286 49 (* Settings *)
ziv@2286 50 (************)
ziv@2286 51
ziv@2286 52 open Mono
ziv@2286 53
ziv@2268 54 (* Filled in by [addFlushing]. *)
ziv@2268 55 val ffiInfoRef : {index : int, params : int} list ref = ref []
ziv@2209 56
ziv@2268 57 fun resetFfiInfo () = ffiInfoRef := []
ziv@2227 58
ziv@2268 59 fun getFfiInfo () = !ffiInfoRef
ziv@2213 60
ziv@2215 61 (* Some FFIs have writing as their only effect, which the caching records. *)
ziv@2215 62 val ffiEffectful =
ziv@2223 63 (* ASK: how can this be less hard-coded? *)
ziv@2215 64 let
ziv@2258 65 val okayWrites = SS.fromList ["htmlifyInt_w",
ziv@2258 66 "htmlifyFloat_w",
ziv@2258 67 "htmlifyString_w",
ziv@2258 68 "htmlifyBool_w",
ziv@2258 69 "htmlifyTime_w",
ziv@2258 70 "attrifyInt_w",
ziv@2258 71 "attrifyFloat_w",
ziv@2258 72 "attrifyString_w",
ziv@2258 73 "attrifyChar_w",
ziv@2258 74 "urlifyInt_w",
ziv@2258 75 "urlifyFloat_w",
ziv@2258 76 "urlifyString_w",
ziv@2258 77 "urlifyBool_w",
ziv@2258 78 "urlifyChannel_w"]
ziv@2215 79 in
ziv@2265 80 (* ASK: is it okay to hardcode Sqlcache functions as effectful? *)
ziv@2215 81 fn (m, f) => Settings.isEffectful (m, f)
ziv@2258 82 andalso not (m = "Basis" andalso SS.member (okayWrites, f))
ziv@2215 83 end
ziv@2215 84
ziv@2278 85 val cacheRef = ref LruCache.cache
ziv@2278 86 fun setCache c = cacheRef := c
ziv@2278 87 fun getCache () = !cacheRef
ziv@2278 88
ziv@2278 89 val alwaysConsolidateRef = ref true
ziv@2278 90 fun setAlwaysConsolidate b = alwaysConsolidateRef := b
ziv@2278 91 fun getAlwaysConsolidate () = !alwaysConsolidateRef
ziv@2233 92
ziv@2286 93
ziv@2286 94 (************************)
ziv@2286 95 (* Really Useful Things *)
ziv@2286 96 (************************)
ziv@2286 97
ziv@2248 98 (* Used to have type context for local variables in MonoUtil functions. *)
ziv@2248 99 val doBind =
ziv@2262 100 fn (env, MonoUtil.Exp.RelE (x, t)) => MonoEnv.pushERel env x t NONE
ziv@2262 101 | (env, MonoUtil.Exp.NamedE (x, n, t, eo, s)) => MonoEnv.pushENamed env x n t eo s
ziv@2262 102 | (env, MonoUtil.Exp.Datatype (x, n, cs)) => MonoEnv.pushDatatype env x n cs
ziv@2215 103
ziv@2271 104 val dummyLoc = ErrorMsg.dummySpan
ziv@2271 105
ziv@2278 106 (* DEBUG *)
ziv@2278 107 fun printExp msg exp = Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_exp MonoEnv.empty exp)
ziv@2278 108 fun printExp' msg exp' = printExp msg (exp', dummyLoc)
ziv@2278 109 fun printTyp msg typ = Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_typ MonoEnv.empty typ)
ziv@2278 110 fun printTyp' msg typ' = printTyp msg (typ', dummyLoc)
ziv@2278 111 fun obindDebug printer (x, f) =
ziv@2278 112 case x of
ziv@2278 113 NONE => NONE
ziv@2278 114 | SOME x' => case f x' of
ziv@2278 115 NONE => (printer (); NONE)
ziv@2278 116 | y => y
ziv@2271 117
ziv@2268 118
ziv@2248 119 (*******************)
ziv@2248 120 (* Effect Analysis *)
ziv@2248 121 (*******************)
ziv@2215 122
ziv@2286 123 (* TODO: test this. *)
ziv@2286 124 fun transitiveAnalysis doVal state (decls, _) =
ziv@2286 125 let
ziv@2286 126 val doDecl =
ziv@2286 127 fn ((DVal v, _), state) => doVal (v, state)
ziv@2286 128 (* Pass over the list of values a number of times equal to its size,
ziv@2286 129 making sure whatever property we're testing propagates everywhere
ziv@2286 130 it should. This is analagous to the Bellman-Ford algorithm. *)
ziv@2286 131 | ((DValRec vs, _), state) =>
ziv@2286 132 iterate (fn state => List.foldl doVal state vs) (length vs) state
ziv@2286 133 | (_, state) => state
ziv@2286 134 in
ziv@2286 135 List.foldl doDecl state decls
ziv@2286 136 end
ziv@2286 137
ziv@2216 138 (* Makes an exception for [EWrite] (which is recorded when caching). *)
ziv@2248 139 fun effectful (effs : IS.set) =
ziv@2215 140 let
ziv@2248 141 val isFunction =
ziv@2248 142 fn (TFun _, _) => true
ziv@2248 143 | _ => false
ziv@2250 144 fun doExp (env, e) =
ziv@2248 145 case e of
ziv@2248 146 EPrim _ => false
ziv@2248 147 (* For now: variables of function type might be effectful, but
ziv@2248 148 others are fully evaluated and are therefore not effectful. *)
ziv@2250 149 | ERel n => isFunction (#2 (MonoEnv.lookupERel env n))
ziv@2248 150 | ENamed n => IS.member (effs, n)
ziv@2248 151 | EFfi (m, f) => ffiEffectful (m, f)
ziv@2248 152 | EFfiApp (m, f, _) => ffiEffectful (m, f)
ziv@2248 153 (* These aren't effectful unless a subexpression is. *)
ziv@2248 154 | ECon _ => false
ziv@2248 155 | ENone _ => false
ziv@2248 156 | ESome _ => false
ziv@2248 157 | EApp _ => false
ziv@2248 158 | EAbs _ => false
ziv@2248 159 | EUnop _ => false
ziv@2248 160 | EBinop _ => false
ziv@2248 161 | ERecord _ => false
ziv@2248 162 | EField _ => false
ziv@2248 163 | ECase _ => false
ziv@2248 164 | EStrcat _ => false
ziv@2248 165 (* EWrite is a special exception because we record writes when caching. *)
ziv@2248 166 | EWrite _ => false
ziv@2248 167 | ESeq _ => false
ziv@2248 168 | ELet _ => false
ziv@2250 169 | EUnurlify _ => false
ziv@2248 170 (* ASK: what should we do about closures? *)
ziv@2248 171 (* Everything else is some sort of effect. We could flip this and
ziv@2248 172 explicitly list bits of Mono that are effectful, but this is
ziv@2248 173 conservatively robust to future changes (however unlikely). *)
ziv@2248 174 | _ => true
ziv@2215 175 in
ziv@2248 176 MonoUtil.Exp.existsB {typ = fn _ => false, exp = doExp, bind = doBind}
ziv@2215 177 end
ziv@2215 178
ziv@2215 179 (* TODO: test this. *)
ziv@2286 180 fun effectfulDecls file =
ziv@2286 181 transitiveAnalysis (fn ((_, name, _, e, _), effs) =>
ziv@2286 182 if effectful effs MonoEnv.empty e
ziv@2286 183 then IS.add (effs, name)
ziv@2286 184 else effs)
ziv@2286 185 IS.empty
ziv@2286 186 file
ziv@2215 187
ziv@2215 188
ziv@2248 189 (*********************************)
ziv@2248 190 (* Boolean Formula Normalization *)
ziv@2248 191 (*********************************)
ziv@2216 192
ziv@2234 193 datatype junctionType = Conj | Disj
ziv@2216 194
ziv@2216 195 datatype 'atom formula =
ziv@2216 196 Atom of 'atom
ziv@2216 197 | Negate of 'atom formula
ziv@2234 198 | Combo of junctionType * 'atom formula list
ziv@2216 199
ziv@2243 200 (* Guaranteed to have all negation pushed to the atoms. *)
ziv@2243 201 datatype 'atom formula' =
ziv@2243 202 Atom' of 'atom
ziv@2243 203 | Combo' of junctionType * 'atom formula' list
ziv@2243 204
ziv@2234 205 val flipJt = fn Conj => Disj | Disj => Conj
ziv@2216 206
ziv@2236 207 fun concatMap f xs = List.concat (map f xs)
ziv@2216 208
ziv@2216 209 val rec cartesianProduct : 'a list list -> 'a list list =
ziv@2216 210 fn [] => [[]]
ziv@2236 211 | (xs :: xss) => concatMap (fn ys => concatMap (fn x => [x :: ys]) xs)
ziv@2236 212 (cartesianProduct xss)
ziv@2216 213
ziv@2218 214 (* Pushes all negation to the atoms.*)
ziv@2244 215 fun pushNegate (normalizeAtom : bool * 'atom -> 'atom) (negating : bool) =
ziv@2244 216 fn Atom x => Atom' (normalizeAtom (negating, x))
ziv@2244 217 | Negate f => pushNegate normalizeAtom (not negating) f
ziv@2244 218 | Combo (j, fs) => Combo' (if negating then flipJt j else j,
ziv@2244 219 map (pushNegate normalizeAtom negating) fs)
ziv@2218 220
ziv@2218 221 val rec flatten =
ziv@2243 222 fn Combo' (_, [f]) => flatten f
ziv@2243 223 | Combo' (j, fs) =>
ziv@2243 224 Combo' (j, List.foldr (fn (f, acc) =>
ziv@2243 225 case f of
ziv@2243 226 Combo' (j', fs') =>
ziv@2243 227 if j = j' orelse length fs' = 1
ziv@2243 228 then fs' @ acc
ziv@2243 229 else f :: acc
ziv@2243 230 | _ => f :: acc)
ziv@2243 231 []
ziv@2243 232 (map flatten fs))
ziv@2218 233 | f => f
ziv@2218 234
ziv@2243 235 (* [simplify] operates on the desired normal form. E.g., if [junc] is [Disj],
ziv@2243 236 consider the list of lists to be a disjunction of conjunctions. *)
ziv@2237 237 fun normalize' (simplify : 'a list list -> 'a list list)
ziv@2235 238 (junc : junctionType) =
ziv@2216 239 let
ziv@2235 240 fun norm junc =
ziv@2237 241 simplify
ziv@2243 242 o (fn Atom' x => [[x]]
ziv@2243 243 | Combo' (j, fs) =>
ziv@2235 244 let
ziv@2236 245 val fss = map (norm junc) fs
ziv@2235 246 in
ziv@2236 247 if j = junc
ziv@2236 248 then List.concat fss
ziv@2236 249 else map List.concat (cartesianProduct fss)
ziv@2235 250 end)
ziv@2216 251 in
ziv@2235 252 norm junc
ziv@2216 253 end
ziv@2216 254
ziv@2244 255 fun normalize simplify normalizeAtom junc =
ziv@2243 256 normalize' simplify junc
ziv@2235 257 o flatten
ziv@2244 258 o pushNegate normalizeAtom false
ziv@2216 259
ziv@2221 260 fun mapFormula mf =
ziv@2221 261 fn Atom x => Atom (mf x)
ziv@2221 262 | Negate f => Negate (mapFormula mf f)
ziv@2235 263 | Combo (j, fs) => Combo (j, map (mapFormula mf) fs)
ziv@2216 264
ziv@2274 265 fun mapFormulaExps mf = mapFormula (fn (cmp, e1, e2) => (cmp, mf e1, mf e2))
ziv@2274 266
ziv@2230 267
ziv@2248 268 (****************)
ziv@2248 269 (* SQL Analysis *)
ziv@2248 270 (****************)
ziv@2213 271
ziv@2240 272 structure CmpKey = struct
ziv@2235 273
ziv@2235 274 type ord_key = Sql.cmp
ziv@2235 275
ziv@2235 276 val compare =
ziv@2235 277 fn (Sql.Eq, Sql.Eq) => EQUAL
ziv@2235 278 | (Sql.Eq, _) => LESS
ziv@2235 279 | (_, Sql.Eq) => GREATER
ziv@2235 280 | (Sql.Ne, Sql.Ne) => EQUAL
ziv@2235 281 | (Sql.Ne, _) => LESS
ziv@2235 282 | (_, Sql.Ne) => GREATER
ziv@2235 283 | (Sql.Lt, Sql.Lt) => EQUAL
ziv@2235 284 | (Sql.Lt, _) => LESS
ziv@2235 285 | (_, Sql.Lt) => GREATER
ziv@2235 286 | (Sql.Le, Sql.Le) => EQUAL
ziv@2235 287 | (Sql.Le, _) => LESS
ziv@2235 288 | (_, Sql.Le) => GREATER
ziv@2235 289 | (Sql.Gt, Sql.Gt) => EQUAL
ziv@2235 290 | (Sql.Gt, _) => LESS
ziv@2235 291 | (_, Sql.Gt) => GREATER
ziv@2235 292 | (Sql.Ge, Sql.Ge) => EQUAL
ziv@2235 293
ziv@2235 294 end
ziv@2235 295
ziv@2216 296 val rec chooseTwos : 'a list -> ('a * 'a) list =
ziv@2216 297 fn [] => []
ziv@2216 298 | x :: ys => map (fn y => (x, y)) ys @ chooseTwos ys
ziv@2213 299
ziv@2237 300 fun removeRedundant madeRedundantBy zs =
ziv@2237 301 let
ziv@2237 302 fun removeRedundant' (xs, ys) =
ziv@2237 303 case xs of
ziv@2237 304 [] => ys
ziv@2237 305 | x :: xs' =>
ziv@2237 306 removeRedundant' (xs',
ziv@2237 307 if List.exists (fn y => madeRedundantBy (x, y)) (xs' @ ys)
ziv@2237 308 then ys
ziv@2237 309 else x :: ys)
ziv@2237 310 in
ziv@2237 311 removeRedundant' (zs, [])
ziv@2237 312 end
ziv@2237 313
ziv@2216 314 datatype atomExp =
ziv@2289 315 True
ziv@2289 316 | False
ziv@2289 317 | QueryArg of int
ziv@2216 318 | DmlRel of int
ziv@2216 319 | Prim of Prim.t
ziv@2216 320 | Field of string * string
ziv@2216 321
ziv@2216 322 structure AtomExpKey : ORD_KEY = struct
ziv@2216 323
ziv@2234 324 type ord_key = atomExp
ziv@2216 325
ziv@2234 326 val compare =
ziv@2289 327 fn (True, True) => EQUAL
ziv@2289 328 | (True, _) => LESS
ziv@2289 329 | (_, True) => GREATER
ziv@2289 330 | (False, False) => EQUAL
ziv@2289 331 | (False, _) => LESS
ziv@2289 332 | (_, False) => GREATER
ziv@2289 333 | (QueryArg n1, QueryArg n2) => Int.compare (n1, n2)
ziv@2234 334 | (QueryArg _, _) => LESS
ziv@2234 335 | (_, QueryArg _) => GREATER
ziv@2234 336 | (DmlRel n1, DmlRel n2) => Int.compare (n1, n2)
ziv@2234 337 | (DmlRel _, _) => LESS
ziv@2234 338 | (_, DmlRel _) => GREATER
ziv@2234 339 | (Prim p1, Prim p2) => Prim.compare (p1, p2)
ziv@2234 340 | (Prim _, _) => LESS
ziv@2234 341 | (_, Prim _) => GREATER
ziv@2234 342 | (Field (t1, f1), Field (t2, f2)) =>
ziv@2234 343 case String.compare (t1, t2) of
ziv@2234 344 EQUAL => String.compare (f1, f2)
ziv@2234 345 | ord => ord
ziv@2216 346
ziv@2216 347 end
ziv@2216 348
ziv@2244 349 structure AtomOptionKey = OptionKeyFn(AtomExpKey)
ziv@2244 350
ziv@2271 351 val rec tablesOfQuery =
ziv@2271 352 fn Sql.Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs)
ziv@2271 353 | Sql.Union (q1, q2) => SS.union (tablesOfQuery q1, tablesOfQuery q2)
ziv@2271 354
ziv@2271 355 val tableOfDml =
ziv@2271 356 fn Sql.Insert (tab, _) => tab
ziv@2271 357 | Sql.Delete (tab, _) => tab
ziv@2271 358 | Sql.Update (tab, _, _) => tab
ziv@2271 359
ziv@2271 360 val freeVars =
ziv@2271 361 MonoUtil.Exp.foldB
ziv@2271 362 {typ = #2,
ziv@2271 363 exp = fn (bound, ERel n, vars) => if n < bound
ziv@2271 364 then vars
ziv@2271 365 else IS.add (vars, n - bound)
ziv@2271 366 | (_, _, vars) => vars,
ziv@2273 367 bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1
ziv@2273 368 | (bound, _) => bound}
ziv@2271 369 0
ziv@2271 370 IS.empty
ziv@2271 371
ziv@2276 372 (* A path is a number of field projections of a variable. *)
ziv@2278 373 type path = int * string list
ziv@2276 374 structure PK = PairKeyFn(structure I = IK structure J = ListKeyFn(SK))
ziv@2276 375 structure PS = BinarySetFn(PK)
ziv@2276 376
ziv@2276 377 val pathOfExp =
ziv@2276 378 let
ziv@2276 379 fun readFields acc exp =
ziv@2276 380 acc
ziv@2276 381 <\obind\>
ziv@2276 382 (fn fs =>
ziv@2276 383 case #1 exp of
ziv@2276 384 ERel n => SOME (n, fs)
ziv@2276 385 | EField (exp, f) => readFields (SOME (f::fs)) exp
ziv@2276 386 | _ => NONE)
ziv@2276 387 in
ziv@2276 388 readFields (SOME [])
ziv@2276 389 end
ziv@2276 390
ziv@2276 391 fun expOfPath (n, fs) =
ziv@2276 392 List.foldl (fn (f, exp) => (EField (exp, f), dummyLoc)) (ERel n, dummyLoc) fs
ziv@2276 393
ziv@2276 394 fun freePaths'' bound exp paths =
ziv@2276 395 case pathOfExp (exp, dummyLoc) of
ziv@2276 396 NONE => paths
ziv@2276 397 | SOME (n, fs) => if n < bound then paths else PS.add (paths, (n - bound, fs))
ziv@2276 398
ziv@2276 399 (* ASK: nicer way? :( *)
ziv@2276 400 fun freePaths' bound exp =
ziv@2276 401 case #1 exp of
ziv@2276 402 EPrim _ => id
ziv@2276 403 | e as ERel _ => freePaths'' bound e
ziv@2276 404 | ENamed _ => id
ziv@2276 405 | ECon (_, _, data) => (case data of NONE => id | SOME e => freePaths' bound e)
ziv@2276 406 | ENone _ => id
ziv@2276 407 | ESome (_, e) => freePaths' bound e
ziv@2276 408 | EFfi _ => id
ziv@2276 409 | EFfiApp (_, _, args) =>
ziv@2276 410 List.foldl (fn ((e, _), acc) => freePaths' bound e o acc) id args
ziv@2276 411 | EApp (e1, e2) => freePaths' bound e1 o freePaths' bound e2
ziv@2276 412 | EAbs (_, _, _, e) => freePaths' (bound + 1) e
ziv@2276 413 | EUnop (_, e) => freePaths' bound e
ziv@2276 414 | EBinop (_, _, e1, e2) => freePaths' bound e1 o freePaths' bound e2
ziv@2276 415 | ERecord fields => List.foldl (fn ((_, e, _), acc) => freePaths' bound e o acc) id fields
ziv@2276 416 | e as EField _ => freePaths'' bound e
ziv@2276 417 | ECase (e, cases, _) =>
ziv@2278 418 List.foldl (fn ((p, e), acc) => freePaths' (MonoEnv.patBindsN p + bound) e o acc)
ziv@2276 419 (freePaths' bound e)
ziv@2276 420 cases
ziv@2276 421 | EStrcat (e1, e2) => freePaths' bound e1 o freePaths' bound e2
ziv@2276 422 | EError (e, _) => freePaths' bound e
ziv@2276 423 | EReturnBlob {blob, mimeType = e, ...} =>
ziv@2276 424 freePaths' bound e o (case blob of NONE => id | SOME e => freePaths' bound e)
ziv@2276 425 | ERedirect (e, _) => freePaths' bound e
ziv@2276 426 | EWrite e => freePaths' bound e
ziv@2276 427 | ESeq (e1, e2) => freePaths' bound e1 o freePaths' bound e2
ziv@2278 428 | ELet (_, _, e1, e2) => freePaths' bound e1 o freePaths' (bound + 1) e2
ziv@2276 429 | EClosure (_, es) => List.foldl (fn (e, acc) => freePaths' bound e o acc) id es
ziv@2276 430 | EQuery {query = e1, body = e2, initial = e3, ...} =>
ziv@2276 431 freePaths' bound e1 o freePaths' (bound + 2) e2 o freePaths' bound e3
ziv@2276 432 | EDml (e, _) => freePaths' bound e
ziv@2276 433 | ENextval e => freePaths' bound e
ziv@2276 434 | ESetval (e1, e2) => freePaths' bound e1 o freePaths' bound e2
ziv@2276 435 | EUnurlify (e, _, _) => freePaths' bound e
ziv@2276 436 | EJavaScript (_, e) => freePaths' bound e
ziv@2276 437 | ESignalReturn e => freePaths' bound e
ziv@2276 438 | ESignalBind (e1, e2) => freePaths' bound e1 o freePaths' bound e2
ziv@2276 439 | ESignalSource e => freePaths' bound e
ziv@2276 440 | EServerCall (e, _, _, _) => freePaths' bound e
ziv@2276 441 | ERecv (e, _) => freePaths' bound e
ziv@2276 442 | ESleep e => freePaths' bound e
ziv@2276 443 | ESpawn e => freePaths' bound e
ziv@2276 444
ziv@2276 445 fun freePaths exp = freePaths' 0 exp PS.empty
ziv@2276 446
ziv@2271 447 datatype unbind = Known of exp | Unknowns of int
ziv@2271 448
ziv@2273 449 datatype cacheArg = AsIs of exp | Urlify of exp
ziv@2273 450
ziv@2278 451 structure InvalInfo :> sig
ziv@2271 452 type t
ziv@2271 453 type state = {tableToIndices : SIMM.multimap,
ziv@2271 454 indexToInvalInfo : (t * int) IntBinaryMap.map,
ziv@2271 455 ffiInfo : {index : int, params : int} list,
ziv@2271 456 index : int}
ziv@2271 457 val empty : t
ziv@2271 458 val singleton : Sql.query -> t
ziv@2271 459 val query : t -> Sql.query
ziv@2278 460 val orderArgs : t * Mono.exp -> cacheArg list
ziv@2271 461 val unbind : t * unbind -> t option
ziv@2271 462 val union : t * t -> t
ziv@2271 463 val updateState : t * int * state -> state
ziv@2278 464 end = struct
ziv@2271 465
ziv@2276 466 (* Variable, field projections, possible wrapped sqlification FFI call. *)
ziv@2278 467 type sqlArg = path * (string * string * typ) option
ziv@2273 468
ziv@2273 469 type subst = sqlArg IM.map
ziv@2273 470
ziv@2273 471 (* TODO: store free variables as well? *)
ziv@2273 472 type t = (Sql.query * subst) list
ziv@2271 473
ziv@2271 474 type state = {tableToIndices : SIMM.multimap,
ziv@2271 475 indexToInvalInfo : (t * int) IntBinaryMap.map,
ziv@2271 476 ffiInfo : {index : int, params : int} list,
ziv@2271 477 index : int}
ziv@2271 478
ziv@2278 479 structure AK = PairKeyFn(
ziv@2278 480 structure I = PK
ziv@2278 481 structure J = OptionKeyFn(TripleKeyFn(
ziv@2276 482 structure I = SK
ziv@2276 483 structure J = SK
ziv@2276 484 structure K = struct type ord_key = Mono.typ val compare = MonoUtil.Typ.compare end)))
ziv@2276 485 structure AM = BinaryMapFn(AK)
ziv@2271 486
ziv@2273 487 (* Traversal Utilities *)
ziv@2273 488 (* TODO: get rid of unused ones. *)
ziv@2271 489
ziv@2271 490 (* Need lift', etc. because we don't have rank-2 polymorphism. This should
ziv@2273 491 probably use a functor (an ML one, not Haskell) but works for now. *)
ziv@2271 492 fun traverseSqexp (pure, _, lift, _, lift'', lift2, _) f =
ziv@2271 493 let
ziv@2271 494 val rec tr =
ziv@2271 495 fn Sql.SqNot se => lift Sql.SqNot (tr se)
ziv@2271 496 | Sql.Binop (r, se1, se2) =>
ziv@2271 497 lift2 (fn (trse1, trse2) => Sql.Binop (r, trse1, trse2)) (tr se1, tr se2)
ziv@2271 498 | Sql.SqKnown se => lift Sql.SqKnown (tr se)
ziv@2271 499 | Sql.Inj (e', loc) => lift'' (fn fe' => Sql.Inj (fe', loc)) (f e')
ziv@2271 500 | Sql.SqFunc (s, se) => lift (fn trse => Sql.SqFunc (s, trse)) (tr se)
ziv@2271 501 | se => pure se
ziv@2271 502 in
ziv@2271 503 tr
ziv@2271 504 end
ziv@2271 505
ziv@2271 506 fun traverseQuery (ops as (_, pure', _, lift', _, _, lift2')) f =
ziv@2271 507 let
ziv@2271 508 val rec mp =
ziv@2271 509 fn Sql.Query1 q =>
ziv@2271 510 (case #Where q of
ziv@2271 511 NONE => pure' (Sql.Query1 q)
ziv@2271 512 | SOME se =>
ziv@2271 513 lift' (fn mpse => Sql.Query1 {Select = #Select q,
ziv@2271 514 From = #From q,
ziv@2271 515 Where = SOME mpse})
ziv@2271 516 (traverseSqexp ops f se))
ziv@2271 517 | Sql.Union (q1, q2) => lift2' Sql.Union (mp q1, mp q2)
ziv@2271 518 in
ziv@2271 519 mp
ziv@2271 520 end
ziv@2271 521
ziv@2273 522 (* Include unused tuple elements in argument for convenience of using same
ziv@2273 523 argument as [traverseQuery]. *)
ziv@2273 524 fun traverseIM (pure, _, _, _, _, lift2, _) f =
ziv@2273 525 IM.foldli (fn (k, v, acc) => lift2 (fn (acc, w) => IM.insert (acc, k, w)) (acc, f (k,v)))
ziv@2273 526 (pure IM.empty)
ziv@2271 527
ziv@2273 528 fun traverseSubst (ops as (_, pure', lift, _, _, _, lift2')) f =
ziv@2273 529 let
ziv@2278 530 fun mp ((n, fields), sqlify) =
ziv@2278 531 lift (fn ((n', fields'), sqlify') =>
ziv@2276 532 let
ziv@2278 533 fun wrap sq = ((n', fields' @ fields), sq)
ziv@2276 534 in
ziv@2276 535 case (fields', sqlify', fields, sqlify) of
ziv@2276 536 (_, NONE, _, NONE) => wrap NONE
ziv@2276 537 | (_, NONE, _, sq as SOME _) => wrap sq
ziv@2276 538 (* Last case should suffice because we don't
ziv@2276 539 project from a sqlified value (which is a
ziv@2276 540 string). *)
ziv@2276 541 | (_, sq as SOME _, [], NONE) => wrap sq
ziv@2289 542 | _ => raise Fail "Sqlcache: traverseSubst"
ziv@2276 543 end)
ziv@2276 544 (f n)
ziv@2273 545 in
ziv@2273 546 traverseIM ops (fn (_, v) => mp v)
ziv@2273 547 end
ziv@2273 548
ziv@2273 549 fun monoidOps plus zero = (fn _ => zero, fn _ => zero,
ziv@2273 550 fn _ => fn x => x, fn _ => fn x => x, fn _ => fn x => x,
ziv@2273 551 fn _ => plus, fn _ => plus)
ziv@2273 552
ziv@2273 553 val optionOps = (SOME, SOME, omap, omap, omap, omap2, omap2)
ziv@2273 554
ziv@2273 555 fun foldMapQuery plus zero = traverseQuery (monoidOps plus zero)
ziv@2273 556 val omapQuery = traverseQuery optionOps
ziv@2273 557 fun foldMapIM plus zero = traverseIM (monoidOps plus zero)
ziv@2273 558 fun omapIM f = traverseIM optionOps f
ziv@2273 559 fun foldMapSubst plus zero = traverseSubst (monoidOps plus zero)
ziv@2273 560 fun omapSubst f = traverseSubst optionOps f
ziv@2271 561
ziv@2271 562 val varsOfQuery = foldMapQuery IS.union
ziv@2271 563 IS.empty
ziv@2271 564 (fn e' => freeVars (e', dummyLoc))
ziv@2271 565
ziv@2276 566 fun varsOfSubst subst = foldMapSubst IS.union IS.empty IS.singleton subst
ziv@2273 567
ziv@2271 568 val varsOfList =
ziv@2271 569 fn [] => IS.empty
ziv@2271 570 | (q::qs) => varsOfQuery (List.foldl Sql.Union q qs)
ziv@2271 571
ziv@2273 572 (* Signature Implementation *)
ziv@2273 573
ziv@2273 574 val empty = []
ziv@2273 575
ziv@2278 576 fun singleton q = [(q, IS.foldl (fn (n, acc) => IM.insert (acc, n, ((n, []), NONE)))
ziv@2273 577 IM.empty
ziv@2273 578 (varsOfQuery q))]
ziv@2273 579
ziv@2273 580 val union = op@
ziv@2273 581
ziv@2273 582 fun sqlArgsMap (qs : t) =
ziv@2271 583 let
ziv@2273 584 val args =
ziv@2273 585 List.foldl (fn ((q, subst), acc) =>
ziv@2273 586 IM.foldl (fn (arg, acc) => AM.insert (acc, arg, ())) acc subst)
ziv@2273 587 AM.empty
ziv@2273 588 qs
ziv@2273 589 val countRef = ref (~1)
ziv@2273 590 fun count () = (countRef := !countRef + 1; !countRef)
ziv@2273 591 in
ziv@2273 592 (* Maps each arg to a different consecutive integer, starting from 0. *)
ziv@2273 593 AM.map count args
ziv@2273 594 end
ziv@2273 595
ziv@2278 596 fun expOfArg (path, sqlify) =
ziv@2276 597 let
ziv@2278 598 val exp = expOfPath path
ziv@2276 599 in
ziv@2276 600 case sqlify of
ziv@2276 601 NONE => exp
ziv@2276 602 | SOME (m, x, typ) => (EFfiApp (m, x, [(exp, typ)]), dummyLoc)
ziv@2276 603 end
ziv@2273 604
ziv@2278 605 fun orderArgs (qs : t, exp) =
ziv@2273 606 let
ziv@2278 607 val paths = freePaths exp
ziv@2273 608 fun erel n = (ERel n, dummyLoc)
ziv@2273 609 val argsMap = sqlArgsMap qs
ziv@2273 610 val args = map (expOfArg o #1) (AM.listItemsi argsMap)
ziv@2276 611 val invalPaths = List.foldl PS.union PS.empty (map freePaths args)
ziv@2271 612 in
ziv@2271 613 (* Put arguments we might invalidate by first. *)
ziv@2273 614 map AsIs args
ziv@2273 615 (* TODO: make sure these variables are okay to remove from the argument list. *)
ziv@2276 616 @ map (Urlify o expOfPath) (PS.listItems (PS.difference (paths, invalPaths)))
ziv@2271 617 end
ziv@2271 618
ziv@2271 619 (* As a kludge, we rename the variables in the query to correspond to the
ziv@2271 620 argument of the cache they're part of. *)
ziv@2273 621 fun query (qs : t) =
ziv@2271 622 let
ziv@2273 623 val argsMap = sqlArgsMap qs
ziv@2273 624 fun substitute subst =
ziv@2273 625 fn ERel n => IM.find (subst, n)
ziv@2273 626 <\obind\>
ziv@2273 627 (fn arg =>
ziv@2273 628 AM.find (argsMap, arg)
ziv@2273 629 <\obind\>
ziv@2273 630 (fn n' => SOME (ERel n')))
ziv@2289 631 | _ => raise Fail "Sqlcache: query (a)"
ziv@2271 632 in
ziv@2273 633 case (map #1 qs) of
ziv@2273 634 (q :: qs) =>
ziv@2273 635 let
ziv@2273 636 val q = List.foldl Sql.Union q qs
ziv@2273 637 val ns = IS.listItems (varsOfQuery q)
ziv@2273 638 val rename =
ziv@2273 639 fn ERel n => omap ERel (indexOf (fn n' => n' = n) ns)
ziv@2289 640 | _ => raise Fail "Sqlcache: query (b)"
ziv@2273 641 in
ziv@2273 642 case omapQuery rename q of
ziv@2273 643 SOME q => q
ziv@2273 644 (* We should never get NONE because indexOf should never fail. *)
ziv@2289 645 | NONE => raise Fail "Sqlcache: query (c)"
ziv@2273 646 end
ziv@2273 647 (* We should never reach this case because [updateState] won't
ziv@2273 648 put anything in the state if there are no queries. *)
ziv@2289 649 | [] => raise Fail "Sqlcache: query (d)"
ziv@2271 650 end
ziv@2271 651
ziv@2276 652 val argOfExp =
ziv@2276 653 let
ziv@2276 654 fun doFields acc exp =
ziv@2276 655 acc
ziv@2276 656 <\obind\>
ziv@2276 657 (fn (fs, sqlify) =>
ziv@2276 658 case #1 exp of
ziv@2276 659 ERel n => SOME (n, fs, sqlify)
ziv@2276 660 | EField (exp, f) => doFields (SOME (f::fs, sqlify)) exp
ziv@2276 661 | _ => NONE)
ziv@2276 662 in
ziv@2276 663 fn (EFfiApp ("Basis", x, [(exp, typ)]), _) =>
ziv@2276 664 if String.isPrefix "sqlify" x
ziv@2278 665 then omap (fn path => (path, SOME ("Basis", x, typ))) (pathOfExp exp)
ziv@2276 666 else NONE
ziv@2278 667 | exp => omap (fn path => (path, NONE)) (pathOfExp exp)
ziv@2276 668 end
ziv@2273 669
ziv@2273 670 val unbind1 =
ziv@2273 671 fn Known e =>
ziv@2273 672 let
ziv@2273 673 val replacement = argOfExp e
ziv@2273 674 in
ziv@2273 675 omapSubst (fn 0 => replacement
ziv@2278 676 | n => SOME ((n-1, []), NONE))
ziv@2273 677 end
ziv@2278 678 | Unknowns k => omapSubst (fn n => if n < k then NONE else SOME ((n-k, []), NONE))
ziv@2271 679
ziv@2271 680 fun unbind (qs, ub) =
ziv@2271 681 case ub of
ziv@2271 682 (* Shortcut if nothing's changing. *)
ziv@2271 683 Unknowns 0 => SOME qs
ziv@2273 684 | _ => osequence (map (fn (q, subst) => unbind1 ub subst
ziv@2273 685 <\obind\>
ziv@2273 686 (fn subst' => SOME (q, subst'))) qs)
ziv@2271 687
ziv@2273 688 fun updateState (qs, numArgs, state as {index, ...} : state) =
ziv@2273 689 {tableToIndices = List.foldr (fn ((q, _), acc) =>
ziv@2271 690 SS.foldl (fn (tab, acc) =>
ziv@2271 691 SIMM.insert (acc, tab, index))
ziv@2271 692 acc
ziv@2271 693 (tablesOfQuery q))
ziv@2271 694 (#tableToIndices state)
ziv@2271 695 qs,
ziv@2271 696 indexToInvalInfo = IM.insert (#indexToInvalInfo state, index, (qs, numArgs)),
ziv@2271 697 ffiInfo = {index = index, params = numArgs} :: #ffiInfo state,
ziv@2271 698 index = index + 1}
ziv@2271 699
ziv@2271 700 end
ziv@2271 701
ziv@2216 702 structure UF = UnionFindFn(AtomExpKey)
ziv@2234 703
ziv@2273 704 val rec sqexpToFormula =
ziv@2273 705 fn Sql.SqTrue => Combo (Conj, [])
ziv@2273 706 | Sql.SqFalse => Combo (Disj, [])
ziv@2273 707 | Sql.SqNot e => Negate (sqexpToFormula e)
ziv@2273 708 | Sql.Binop (Sql.RCmp c, e1, e2) => Atom (c, e1, e2)
ziv@2273 709 | Sql.Binop (Sql.RLop l, p1, p2) => Combo (case l of Sql.And => Conj | Sql.Or => Disj,
ziv@2273 710 [sqexpToFormula p1, sqexpToFormula p2])
ziv@2289 711 | e as Sql.Field f => Atom (Sql.Eq, e, Sql.SqTrue)
ziv@2273 712 (* ASK: any other sqexps that can be props? *)
ziv@2289 713 | Sql.SqConst prim =>
ziv@2289 714 (case prim of
ziv@2289 715 (Prim.String (Prim.Normal, s)) =>
ziv@2289 716 if s = #trueString (Settings.currentDbms ())
ziv@2289 717 then Combo (Conj, [])
ziv@2289 718 else if s = #falseString (Settings.currentDbms ())
ziv@2289 719 then Combo (Disj, [])
ziv@2289 720 else raise Fail "Sqlcache: sqexpToFormula (SqConst a)"
ziv@2289 721 | _ => raise Fail "Sqlcache: sqexpToFormula (SqConst b)")
ziv@2289 722 | Sql.Computed _ => raise Fail "Sqlcache: sqexpToFormula (Computed)"
ziv@2289 723 | Sql.SqKnown _ => raise Fail "Sqlcache: sqexpToFormula (SqKnown)"
ziv@2289 724 | Sql.Inj _ => raise Fail "Sqlcache: sqexpToFormula (Inj)"
ziv@2289 725 | Sql.SqFunc _ => raise Fail "Sqlcache: sqexpToFormula (SqFunc)"
ziv@2289 726 | Sql.Unmodeled => raise Fail "Sqlcache: sqexpToFormula (Unmodeled)"
ziv@2289 727 | Sql.Null => raise Fail "Sqlcache: sqexpToFormula (Null)"
ziv@2273 728
ziv@2275 729 fun mapSqexpFields f =
ziv@2275 730 fn Sql.Field (t, v) => f (t, v)
ziv@2275 731 | Sql.SqNot e => Sql.SqNot (mapSqexpFields f e)
ziv@2275 732 | Sql.Binop (r, e1, e2) => Sql.Binop (r, mapSqexpFields f e1, mapSqexpFields f e2)
ziv@2275 733 | Sql.SqKnown e => Sql.SqKnown (mapSqexpFields f e)
ziv@2275 734 | Sql.SqFunc (s, e) => Sql.SqFunc (s, mapSqexpFields f e)
ziv@2275 735 | e => e
ziv@2275 736
ziv@2273 737 fun renameTables tablePairs =
ziv@2273 738 let
ziv@2275 739 fun rename table =
ziv@2273 740 case List.find (fn (_, t) => table = t) tablePairs of
ziv@2273 741 NONE => table
ziv@2273 742 | SOME (realTable, _) => realTable
ziv@2273 743 in
ziv@2275 744 mapSqexpFields (fn (t, f) => Sql.Field (rename t, f))
ziv@2273 745 end
ziv@2273 746
ziv@2274 747 fun queryToFormula marker =
ziv@2274 748 fn Sql.Query1 {Select = sitems, From = tablePairs, Where = wher} =>
ziv@2274 749 let
ziv@2274 750 val fWhere = case wher of
ziv@2274 751 NONE => Combo (Conj, [])
ziv@2275 752 | SOME e => sqexpToFormula (renameTables tablePairs e)
ziv@2274 753 in
ziv@2275 754 case marker of
ziv@2275 755 NONE => fWhere
ziv@2275 756 | SOME markFields =>
ziv@2275 757 let
ziv@2275 758 val fWhereMarked = mapFormulaExps markFields fWhere
ziv@2275 759 val toSqexp =
ziv@2275 760 fn Sql.SqField tf => Sql.Field tf
ziv@2275 761 | Sql.SqExp (se, _) => se
ziv@2275 762 fun ineq se = Atom (Sql.Ne, se, markFields se)
ziv@2275 763 val fIneqs = Combo (Disj, map (ineq o renameTables tablePairs o toSqexp) sitems)
ziv@2275 764 in
ziv@2275 765 (Combo (Conj,
ziv@2275 766 [fWhere,
ziv@2275 767 Combo (Disj,
ziv@2275 768 [Negate fWhereMarked,
ziv@2275 769 Combo (Conj, [fWhereMarked, fIneqs])])]))
ziv@2275 770 end
ziv@2274 771 end
ziv@2274 772 | Sql.Union (q1, q2) => Combo (Disj, [queryToFormula marker q1, queryToFormula marker q2])
ziv@2273 773
ziv@2274 774 fun valsToFormula (markLeft, markRight) (table, vals) =
ziv@2274 775 Combo (Conj,
ziv@2274 776 map (fn (field, v) => Atom (Sql.Eq, markLeft (Sql.Field (table, field)), markRight v))
ziv@2274 777 vals)
ziv@2273 778
ziv@2274 779 (* TODO: verify logic for insertion and deletion. *)
ziv@2274 780 val rec dmlToFormulaMarker =
ziv@2274 781 fn Sql.Insert (table, vals) => (valsToFormula (id, id) (table, vals), NONE)
ziv@2275 782 | Sql.Delete (table, wher) => (sqexpToFormula (renameTables [(table, "T")] wher), NONE)
ziv@2273 783 | Sql.Update (table, vals, wher) =>
ziv@2273 784 let
ziv@2275 785 val fWhere = sqexpToFormula (renameTables [(table, "T")] wher)
ziv@2274 786 fun fVals marks = valsToFormula marks (table, vals)
ziv@2273 787 val modifiedFields = SS.addList (SS.empty, map #1 vals)
ziv@2273 788 (* TODO: don't use field name hack. *)
ziv@2275 789 val markFields =
ziv@2275 790 mapSqexpFields (fn (t, v) => if t = table andalso SS.member (modifiedFields, v)
ziv@2276 791 then Sql.Field (t, v ^ "'")
ziv@2276 792 else Sql.Field (t, v))
ziv@2275 793 val mark = mapFormulaExps markFields
ziv@2273 794 in
ziv@2275 795 ((Combo (Disj, [Combo (Conj, [fVals (id, markFields), mark fWhere]),
ziv@2275 796 Combo (Conj, [fVals (markFields, id), fWhere])])),
ziv@2275 797 SOME markFields)
ziv@2273 798 end
ziv@2273 799
ziv@2274 800 fun pairToFormulas (query, dml) =
ziv@2274 801 let
ziv@2276 802 val (fDml, marker) = dmlToFormulaMarker dml
ziv@2274 803 in
ziv@2274 804 (queryToFormula marker query, fDml)
ziv@2274 805 end
ziv@2274 806
ziv@2235 807 structure ConflictMaps = struct
ziv@2235 808
ziv@2235 809 structure TK = TripleKeyFn(structure I = CmpKey
ziv@2244 810 structure J = AtomOptionKey
ziv@2244 811 structure K = AtomOptionKey)
ziv@2274 812
ziv@2244 813 structure TS : ORD_SET = BinarySetFn(TK)
ziv@2235 814
ziv@2235 815 val toKnownEquality =
ziv@2235 816 (* [NONE] here means unkown. Anything that isn't a comparison between two
ziv@2235 817 knowns shouldn't be used, and simply dropping unused terms is okay in
ziv@2235 818 disjunctive normal form. *)
ziv@2235 819 fn (Sql.Eq, SOME e1, SOME e2) => SOME (e1, e2)
ziv@2235 820 | _ => NONE
ziv@2235 821
ziv@2274 822 fun equivClasses atoms : atomExp list list option =
ziv@2274 823 let
ziv@2274 824 val uf = List.foldl UF.union' UF.empty (List.mapPartial toKnownEquality atoms)
ziv@2274 825 val contradiction =
ziv@2274 826 fn (cmp, SOME ae1, SOME ae2) => (cmp = Sql.Ne orelse cmp = Sql.Lt orelse cmp = Sql.Gt)
ziv@2275 827 andalso UF.together (uf, ae1, ae2)
ziv@2274 828 (* If we don't know one side of the comparision, not a contradiction. *)
ziv@2274 829 | _ => false
ziv@2274 830 in
ziv@2274 831 not (List.exists contradiction atoms) <\oguard\> SOME (UF.classes uf)
ziv@2274 832 end
ziv@2235 833
ziv@2235 834 fun addToEqs (eqs, n, e) =
ziv@2235 835 case IM.find (eqs, n) of
ziv@2235 836 (* Comparing to a constant is probably better than comparing to a
ziv@2235 837 variable? Checking that existing constants match a new ones is
ziv@2235 838 handled by [accumulateEqs]. *)
ziv@2235 839 SOME (Prim _) => eqs
ziv@2235 840 | _ => IM.insert (eqs, n, e)
ziv@2235 841
ziv@2235 842 val accumulateEqs =
ziv@2235 843 (* [NONE] means we have a contradiction. *)
ziv@2235 844 fn (_, NONE) => NONE
ziv@2235 845 | ((Prim p1, Prim p2), eqso) =>
ziv@2235 846 (case Prim.compare (p1, p2) of
ziv@2235 847 EQUAL => eqso
ziv@2235 848 | _ => NONE)
ziv@2235 849 | ((QueryArg n, Prim p), SOME eqs) => SOME (addToEqs (eqs, n, Prim p))
ziv@2235 850 | ((QueryArg n, DmlRel r), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r))
ziv@2235 851 | ((Prim p, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, Prim p))
ziv@2235 852 | ((DmlRel r, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r))
ziv@2235 853 (* TODO: deal with equalities between [DmlRel]s and [Prim]s.
ziv@2235 854 This would involve guarding the invalidation with a check for the
ziv@2235 855 relevant comparisons. *)
ziv@2235 856 | (_, eqso) => eqso
ziv@2235 857
ziv@2235 858 val eqsOfClass : atomExp list -> atomExp IM.map option =
ziv@2235 859 List.foldl accumulateEqs (SOME IM.empty)
ziv@2235 860 o chooseTwos
ziv@2235 861
ziv@2235 862 fun toAtomExps rel (cmp, e1, e2) =
ziv@2235 863 let
ziv@2235 864 val qa =
ziv@2235 865 (* Here [NONE] means unkown. *)
ziv@2235 866 fn Sql.SqConst p => SOME (Prim p)
ziv@2235 867 | Sql.Field tf => SOME (Field tf)
ziv@2235 868 | Sql.Inj (EPrim p, _) => SOME (Prim p)
ziv@2235 869 | Sql.Inj (ERel n, _) => SOME (rel n)
ziv@2235 870 (* We can't deal with anything else, e.g., CURRENT_TIMESTAMP
ziv@2235 871 becomes Sql.Unmodeled, which becomes NONE here. *)
ziv@2235 872 | _ => NONE
ziv@2235 873 in
ziv@2235 874 (cmp, qa e1, qa e2)
ziv@2235 875 end
ziv@2235 876
ziv@2244 877 val negateCmp =
ziv@2244 878 fn Sql.Eq => Sql.Ne
ziv@2244 879 | Sql.Ne => Sql.Eq
ziv@2244 880 | Sql.Lt => Sql.Ge
ziv@2244 881 | Sql.Le => Sql.Gt
ziv@2244 882 | Sql.Gt => Sql.Le
ziv@2244 883 | Sql.Ge => Sql.Lt
ziv@2244 884
ziv@2244 885 fun normalizeAtom (negating, (cmp, e1, e2)) =
ziv@2244 886 (* Restricting to Le/Lt and sorting the expressions in Eq/Ne helps with
ziv@2244 887 simplification, where we put the triples in sets. *)
ziv@2244 888 case (if negating then negateCmp cmp else cmp) of
ziv@2244 889 Sql.Eq => (case AtomOptionKey.compare (e1, e2) of
ziv@2244 890 LESS => (Sql.Eq, e2, e1)
ziv@2244 891 | _ => (Sql.Eq, e1, e2))
ziv@2244 892 | Sql.Ne => (case AtomOptionKey.compare (e1, e2) of
ziv@2244 893 LESS => (Sql.Ne, e2, e1)
ziv@2244 894 | _ => (Sql.Ne, e1, e2))
ziv@2244 895 | Sql.Lt => (Sql.Lt, e1, e2)
ziv@2244 896 | Sql.Le => (Sql.Le, e1, e2)
ziv@2244 897 | Sql.Gt => (Sql.Lt, e2, e1)
ziv@2244 898 | Sql.Ge => (Sql.Le, e2, e1)
ziv@2235 899
ziv@2235 900 val markQuery : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula ->
ziv@2235 901 (Sql.cmp * atomExp option * atomExp option) formula =
ziv@2235 902 mapFormula (toAtomExps QueryArg)
ziv@2235 903
ziv@2235 904 val markDml : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula ->
ziv@2235 905 (Sql.cmp * atomExp option * atomExp option) formula =
ziv@2235 906 mapFormula (toAtomExps DmlRel)
ziv@2250 907
ziv@2235 908 (* No eqs should have key conflicts because no variable is in two
ziv@2235 909 equivalence classes, so the [#1] could be [#2]. *)
ziv@2235 910 val mergeEqs : (atomExp IntBinaryMap.map option list
ziv@2235 911 -> atomExp IntBinaryMap.map option) =
ziv@2271 912 List.foldr (omap2 (IM.unionWith #1)) (SOME IM.empty)
ziv@2235 913
ziv@2239 914 val simplify =
ziv@2239 915 map TS.listItems
ziv@2239 916 o removeRedundant (fn (x, y) => TS.isSubset (y, x))
ziv@2239 917 o map (fn xs => TS.addList (TS.empty, xs))
ziv@2239 918
ziv@2235 919 fun dnf (fQuery, fDml) =
ziv@2244 920 normalize simplify normalizeAtom Disj (Combo (Conj, [markQuery fQuery, markDml fDml]))
ziv@2235 921
ziv@2274 922 val conflictMaps =
ziv@2274 923 List.mapPartial (mergeEqs o map eqsOfClass)
ziv@2274 924 o List.mapPartial equivClasses
ziv@2274 925 o dnf
ziv@2235 926
ziv@2235 927 end
ziv@2235 928
ziv@2235 929 val conflictMaps = ConflictMaps.conflictMaps
ziv@2213 930
ziv@2213 931
ziv@2265 932 (*************************************)
ziv@2265 933 (* Program Instrumentation Utilities *)
ziv@2265 934 (*************************************)
ziv@2213 935
ziv@2288 936 val {check, store, flush, lock, ...} = getCache ()
ziv@2233 937
ziv@2248 938 val dummyTyp = (TRecord [], dummyLoc)
ziv@2248 939
ziv@2230 940 fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), dummyLoc)
ziv@2230 941
ziv@2230 942 val stringTyp = (TFfi ("Basis", "string"), dummyLoc)
ziv@2213 943
ziv@2213 944 val sequence =
ziv@2213 945 fn (exp :: exps) =>
ziv@2213 946 let
ziv@2230 947 val loc = dummyLoc
ziv@2213 948 in
ziv@2213 949 List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps
ziv@2213 950 end
ziv@2289 951 | _ => raise Fail "Sqlcache: sequence"
ziv@2213 952
ziv@2248 953 (* Always increments negative indices as a hack we use later. *)
ziv@2248 954 fun incRels inc =
ziv@2215 955 MonoUtil.Exp.mapB
ziv@2248 956 {typ = fn t' => t',
ziv@2248 957 exp = fn bound =>
ziv@2248 958 (fn ERel n => ERel (if n >= bound orelse n < 0 then n + inc else n)
ziv@2248 959 | e' => e'),
ziv@2248 960 bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound}
ziv@2248 961 0
ziv@2213 962
ziv@2262 963 fun fileTopLevelMapfoldB doTopLevelExp (decls, sideInfo) state =
ziv@2262 964 let
ziv@2262 965 fun doVal env ((x, n, t, exp, s), state) =
ziv@2262 966 let
ziv@2262 967 val (exp, state) = doTopLevelExp env exp state
ziv@2262 968 in
ziv@2262 969 ((x, n, t, exp, s), state)
ziv@2262 970 end
ziv@2262 971 fun doDecl' env (decl', state) =
ziv@2262 972 case decl' of
ziv@2262 973 DVal v =>
ziv@2262 974 let
ziv@2262 975 val (v, state) = doVal env (v, state)
ziv@2262 976 in
ziv@2262 977 (DVal v, state)
ziv@2262 978 end
ziv@2262 979 | DValRec vs =>
ziv@2262 980 let
ziv@2262 981 val (vs, state) = ListUtil.foldlMap (doVal env) state vs
ziv@2262 982 in
ziv@2262 983 (DValRec vs, state)
ziv@2262 984 end
ziv@2262 985 | _ => (decl', state)
ziv@2262 986 fun doDecl (decl as (decl', loc), (env, state)) =
ziv@2262 987 let
ziv@2262 988 val env = MonoEnv.declBinds env decl
ziv@2262 989 val (decl', state) = doDecl' env (decl', state)
ziv@2262 990 in
ziv@2262 991 ((decl', loc), (env, state))
ziv@2262 992 end
ziv@2262 993 val (decls, (_, state)) = (ListUtil.foldlMap doDecl (MonoEnv.empty, state) decls)
ziv@2262 994 in
ziv@2262 995 ((decls, sideInfo), state)
ziv@2262 996 end
ziv@2262 997
ziv@2262 998 fun fileAllMapfoldB doExp file start =
ziv@2248 999 case MonoUtil.File.mapfoldB
ziv@2248 1000 {typ = Search.return2,
ziv@2250 1001 exp = fn env => fn e' => fn s => Search.Continue (doExp env e' s),
ziv@2248 1002 decl = fn _ => Search.return2,
ziv@2248 1003 bind = doBind}
ziv@2250 1004 MonoEnv.empty file start of
ziv@2213 1005 Search.Continue x => x
ziv@2289 1006 | Search.Return _ => raise Fail "Sqlcache: fileAllMapfoldB"
ziv@2213 1007
ziv@2262 1008 fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ())
ziv@2213 1009
ziv@2267 1010 (* TODO: make this a bit prettier.... *)
ziv@2267 1011 val simplifySql =
ziv@2266 1012 let
ziv@2267 1013 fun factorOutNontrivial text =
ziv@2267 1014 let
ziv@2267 1015 val loc = dummyLoc
ziv@2267 1016 fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
ziv@2267 1017 val chunks = Sql.chunkify text
ziv@2267 1018 val (newText, newVariables) =
ziv@2267 1019 (* Important that this is foldr (to oppose foldl below). *)
ziv@2267 1020 List.foldr
ziv@2267 1021 (fn (chunk, (qText, newVars)) =>
ziv@2267 1022 (* Variable bound to the head of newVars will have the lowest index. *)
ziv@2267 1023 case chunk of
ziv@2267 1024 (* EPrim should always be a string in this case. *)
ziv@2267 1025 Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars)
ziv@2267 1026 | Sql.Exp e =>
ziv@2267 1027 let
ziv@2267 1028 val n = length newVars
ziv@2267 1029 in
ziv@2267 1030 (* This is the (n+1)th new variable, so there are
ziv@2267 1031 already n new variables bound, so we increment
ziv@2267 1032 indices by n. *)
ziv@2267 1033 (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars)
ziv@2267 1034 end
ziv@2267 1035 | Sql.String s => (strcat (stringExp s, qText), newVars))
ziv@2267 1036 (stringExp "", [])
ziv@2267 1037 chunks
ziv@2267 1038 fun wrapLets e' =
ziv@2267 1039 (* Important that this is foldl (to oppose foldr above). *)
ziv@2273 1040 List.foldl (fn (v, e') => ELet ("sqlArg", stringTyp, v, (e', loc)))
ziv@2267 1041 e'
ziv@2267 1042 newVariables
ziv@2267 1043 val numArgs = length newVariables
ziv@2267 1044 in
ziv@2267 1045 (newText, wrapLets, numArgs)
ziv@2267 1046 end
ziv@2267 1047 fun doExp exp' =
ziv@2267 1048 let
ziv@2267 1049 val text = case exp' of
ziv@2267 1050 EQuery {query = text, ...} => text
ziv@2267 1051 | EDml (text, _) => text
ziv@2289 1052 | _ => raise Fail "Sqlcache: simplifySql (a)"
ziv@2267 1053 val (newText, wrapLets, numArgs) = factorOutNontrivial text
ziv@2267 1054 val newExp' = case exp' of
ziv@2267 1055 EQuery q => EQuery {query = newText,
ziv@2267 1056 exps = #exps q,
ziv@2267 1057 tables = #tables q,
ziv@2267 1058 state = #state q,
ziv@2267 1059 body = #body q,
ziv@2267 1060 initial = #initial q}
ziv@2267 1061 | EDml (_, failureMode) => EDml (newText, failureMode)
ziv@2289 1062 | _ => raise Fail "Sqlcache: simplifySql (b)"
ziv@2267 1063 in
ziv@2267 1064 (* Increment once for each new variable just made. This is
ziv@2267 1065 where we use the negative De Bruijn indices hack. *)
ziv@2267 1066 (* TODO: please don't use that hack. As anyone could have
ziv@2267 1067 predicted, it was incomprehensible a year later.... *)
ziv@2267 1068 wrapLets (#1 (incRels numArgs (newExp', dummyLoc)))
ziv@2267 1069 end
ziv@2266 1070 in
ziv@2267 1071 fileMap (fn exp' => case exp' of
ziv@2267 1072 EQuery _ => doExp exp'
ziv@2267 1073 | EDml _ => doExp exp'
ziv@2267 1074 | _ => exp')
ziv@2266 1075 end
ziv@2266 1076
ziv@2250 1077
ziv@2250 1078 (**********************)
ziv@2250 1079 (* Mono Type Checking *)
ziv@2250 1080 (**********************)
ziv@2250 1081
ziv@2250 1082 fun typOfExp' (env : MonoEnv.env) : exp' -> typ option =
ziv@2250 1083 fn EPrim p => SOME (TFfi ("Basis", case p of
ziv@2250 1084 Prim.Int _ => "int"
ziv@2250 1085 | Prim.Float _ => "double"
ziv@2250 1086 | Prim.String _ => "string"
ziv@2250 1087 | Prim.Char _ => "char"),
ziv@2250 1088 dummyLoc)
ziv@2250 1089 | ERel n => SOME (#2 (MonoEnv.lookupERel env n))
ziv@2250 1090 | ENamed n => SOME (#2 (MonoEnv.lookupENamed env n))
ziv@2250 1091 (* ASK: okay to make a new [ref] each time? *)
ziv@2250 1092 | ECon (dk, PConVar nCon, _) =>
ziv@2250 1093 let
ziv@2250 1094 val (_, _, nData) = MonoEnv.lookupConstructor env nCon
ziv@2250 1095 val (_, cs) = MonoEnv.lookupDatatype env nData
ziv@2250 1096 in
ziv@2250 1097 SOME (TDatatype (nData, ref (dk, cs)), dummyLoc)
ziv@2250 1098 end
ziv@2250 1099 | ECon (_, PConFfi {mod = s, datatyp, ...}, _) => SOME (TFfi (s, datatyp), dummyLoc)
ziv@2250 1100 | ENone t => SOME (TOption t, dummyLoc)
ziv@2250 1101 | ESome (t, _) => SOME (TOption t, dummyLoc)
ziv@2250 1102 | EFfi _ => NONE
ziv@2250 1103 | EFfiApp _ => NONE
ziv@2250 1104 | EApp (e1, e2) => (case typOfExp env e1 of
ziv@2250 1105 SOME (TFun (_, t), _) => SOME t
ziv@2250 1106 | _ => NONE)
ziv@2250 1107 | EAbs (_, t1, t2, _) => SOME (TFun (t1, t2), dummyLoc)
ziv@2250 1108 (* ASK: is this right? *)
ziv@2250 1109 | EUnop (unop, e) => (case unop of
ziv@2250 1110 "!" => SOME (TFfi ("Basis", "bool"), dummyLoc)
ziv@2250 1111 | "-" => typOfExp env e
ziv@2250 1112 | _ => NONE)
ziv@2250 1113 (* ASK: how should this (and other "=> NONE" cases) work? *)
ziv@2250 1114 | EBinop _ => NONE
ziv@2250 1115 | ERecord fields => SOME (TRecord (map (fn (s, _, t) => (s, t)) fields), dummyLoc)
ziv@2250 1116 | EField (e, s) => (case typOfExp env e of
ziv@2250 1117 SOME (TRecord fields, _) =>
ziv@2286 1118 omap #2 (List.find (fn (s', _) => s = s') fields)
ziv@2250 1119 | _ => NONE)
ziv@2250 1120 | ECase (_, _, {result, ...}) => SOME result
ziv@2250 1121 | EStrcat _ => SOME (TFfi ("Basis", "string"), dummyLoc)
ziv@2250 1122 | EWrite _ => SOME (TRecord [], dummyLoc)
ziv@2250 1123 | ESeq (_, e) => typOfExp env e
ziv@2250 1124 | ELet (s, t, e1, e2) => typOfExp (MonoEnv.pushERel env s t (SOME e1)) e2
ziv@2250 1125 | EClosure _ => NONE
ziv@2250 1126 | EUnurlify (_, t, _) => SOME t
ziv@2269 1127 | EQuery {state, ...} => SOME state
ziv@2276 1128 | e => NONE
ziv@2250 1129
ziv@2250 1130 and typOfExp env (e', loc) = typOfExp' env e'
ziv@2250 1131
ziv@2250 1132
ziv@2266 1133 (***********)
ziv@2266 1134 (* Caching *)
ziv@2266 1135 (***********)
ziv@2250 1136
ziv@2271 1137 type state = InvalInfo.state
ziv@2271 1138
ziv@2271 1139 datatype subexp = Cachable of InvalInfo.t * (state -> exp * state) | Impure of exp
ziv@2271 1140
ziv@2271 1141 val isImpure =
ziv@2271 1142 fn Cachable _ => false
ziv@2271 1143 | Impure _ => true
ziv@2271 1144
ziv@2271 1145 val runSubexp : subexp * state -> exp * state =
ziv@2271 1146 fn (Cachable (_, f), state) => f state
ziv@2271 1147 | (Impure e, state) => (e, state)
ziv@2271 1148
ziv@2271 1149 val invalInfoOfSubexp =
ziv@2271 1150 fn Cachable (invalInfo, _) => invalInfo
ziv@2289 1151 | Impure _ => raise Fail "Sqlcache: invalInfoOfSubexp"
ziv@2271 1152
ziv@2271 1153 fun cacheWrap (env, exp, typ, args, index) =
ziv@2265 1154 let
ziv@2265 1155 val loc = dummyLoc
ziv@2265 1156 val rel0 = (ERel 0, loc)
ziv@2265 1157 in
ziv@2271 1158 case MonoFooify.urlify env (rel0, typ) of
ziv@2265 1159 NONE => NONE
ziv@2265 1160 | SOME urlified =>
ziv@2265 1161 let
ziv@2265 1162 (* We ensure before this step that all arguments aren't effectful.
ziv@2265 1163 by turning them into local variables as needed. *)
ziv@2265 1164 val argsInc = map (incRels 1) args
ziv@2268 1165 val check = (check (index, args), loc)
ziv@2268 1166 val store = (store (index, argsInc, urlified), loc)
ziv@2265 1167 in
ziv@2271 1168 SOME (ECase (check,
ziv@2271 1169 [((PNone stringTyp, loc),
ziv@2273 1170 (ELet ("q", typ, exp, (ESeq (store, rel0), loc)), loc)),
ziv@2273 1171 ((PSome (stringTyp, (PVar ("hit", stringTyp), loc)), loc),
ziv@2271 1172 (* Boolean is false because we're not unurlifying from a cookie. *)
ziv@2271 1173 (EUnurlify (rel0, typ, false), loc))],
ziv@2271 1174 {disc = (TOption stringTyp, loc), result = typ}))
ziv@2265 1175 end
ziv@2265 1176 end
ziv@2265 1177
ziv@2258 1178 val expSize = MonoUtil.Exp.fold {typ = #2, exp = fn (_, n) => n+1} 0
ziv@2258 1179
ziv@2259 1180 (* TODO: pick a number. *)
ziv@2278 1181 val sizeWorthCaching = 5
ziv@2259 1182
ziv@2269 1183 val worthCaching =
ziv@2269 1184 fn EQuery _ => true
ziv@2269 1185 | exp' => expSize (exp', dummyLoc) > sizeWorthCaching
ziv@2269 1186
ziv@2278 1187 fun shouldConsolidate args =
ziv@2278 1188 let
ziv@2278 1189 val isAsIs = fn AsIs _ => true | Urlify _ => false
ziv@2278 1190 in
ziv@2278 1191 getAlwaysConsolidate ()
ziv@2278 1192 orelse not (List.exists isAsIs args andalso List.exists (not o isAsIs) args)
ziv@2278 1193 end
ziv@2278 1194
ziv@2273 1195 fun cacheExp (env, exp', invalInfo, state : state) =
ziv@2273 1196 case worthCaching exp' <\oguard\> typOfExp' env exp' of
ziv@2269 1197 NONE => NONE
ziv@2269 1198 | SOME (TFun _, _) => NONE
ziv@2269 1199 | SOME typ =>
ziv@2271 1200 let
ziv@2278 1201 val args = InvalInfo.orderArgs (invalInfo, (exp', dummyLoc))
ziv@2278 1202 in
ziv@2278 1203 shouldConsolidate args
ziv@2278 1204 <\oguard\>
ziv@2278 1205 List.foldr (fn (arg, acc) =>
ziv@2278 1206 acc
ziv@2278 1207 <\obind\>
ziv@2278 1208 (fn args' =>
ziv@2278 1209 (case arg of
ziv@2278 1210 AsIs exp => SOME exp
ziv@2278 1211 | Urlify exp =>
ziv@2278 1212 typOfExp env exp
ziv@2278 1213 <\obind\>
ziv@2278 1214 (fn typ => (MonoFooify.urlify env (exp, typ))))
ziv@2278 1215 <\obind\>
ziv@2278 1216 (fn arg' => SOME (arg' :: args'))))
ziv@2278 1217 (SOME [])
ziv@2278 1218 args
ziv@2278 1219 <\obind\>
ziv@2278 1220 (fn args' =>
ziv@2278 1221 cacheWrap (env, (exp', dummyLoc), typ, args', #index state)
ziv@2278 1222 <\obind\>
ziv@2278 1223 (fn cachedExp =>
ziv@2278 1224 SOME (cachedExp, InvalInfo.updateState (invalInfo, length args', state))))
ziv@2271 1225 end
ziv@2269 1226
ziv@2271 1227 fun cacheQuery (effs, env, q) : subexp =
ziv@2266 1228 let
ziv@2266 1229 (* We use dummyTyp here. I think this is okay because databases don't
ziv@2266 1230 store (effectful) functions, but perhaps there's some pathalogical
ziv@2266 1231 corner case missing.... *)
ziv@2266 1232 fun safe bound =
ziv@2266 1233 not
ziv@2266 1234 o effectful effs
ziv@2266 1235 (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE)
ziv@2266 1236 bound
ziv@2266 1237 env)
ziv@2271 1238 val {query = queryText, initial, body, ...} = q
ziv@2266 1239 val attempt =
ziv@2266 1240 (* Ziv misses Haskell's do notation.... *)
ziv@2267 1241 (safe 0 queryText andalso safe 0 initial andalso safe 2 body)
ziv@2273 1242 <\oguard\>
ziv@2268 1243 Sql.parse Sql.query queryText
ziv@2273 1244 <\obind\>
ziv@2268 1245 (fn queryParsed =>
ziv@2271 1246 let
ziv@2271 1247 val invalInfo = InvalInfo.singleton queryParsed
ziv@2271 1248 fun mkExp state =
ziv@2271 1249 case cacheExp (env, EQuery q, invalInfo, state) of
ziv@2271 1250 NONE => ((EQuery q, dummyLoc), state)
ziv@2271 1251 | SOME (cachedExp, state) => ((cachedExp, dummyLoc), state)
ziv@2271 1252 in
ziv@2271 1253 SOME (Cachable (invalInfo, mkExp))
ziv@2271 1254 end)
ziv@2266 1255 in
ziv@2266 1256 case attempt of
ziv@2271 1257 NONE => Impure (EQuery q, dummyLoc)
ziv@2271 1258 | SOME subexp => subexp
ziv@2266 1259 end
ziv@2266 1260
ziv@2278 1261 fun cacheTree (effs : IS.set) ((env, exp as (exp', loc)), state) =
ziv@2250 1262 let
ziv@2271 1263 fun wrapBindN (f : exp list -> exp')
ziv@2271 1264 (args : ((MonoEnv.env * exp) * unbind) list) =
ziv@2250 1265 let
ziv@2271 1266 val (subexps, state) =
ziv@2271 1267 ListUtil.foldlMap (cacheTree effs)
ziv@2271 1268 state
ziv@2271 1269 (map #1 args)
ziv@2268 1270 fun mkExp state = mapFst (fn exps => (f exps, loc))
ziv@2268 1271 (ListUtil.foldlMap runSubexp state subexps)
ziv@2271 1272 val attempt =
ziv@2271 1273 if List.exists isImpure subexps
ziv@2271 1274 then NONE
ziv@2271 1275 else (List.foldl (omap2 InvalInfo.union)
ziv@2271 1276 (SOME InvalInfo.empty)
ziv@2271 1277 (ListPair.map
ziv@2271 1278 (fn (subexp, (_, unbinds)) =>
ziv@2271 1279 InvalInfo.unbind (invalInfoOfSubexp subexp, unbinds))
ziv@2271 1280 (subexps, args)))
ziv@2273 1281 <\obind\>
ziv@2271 1282 (fn invalInfo =>
ziv@2271 1283 SOME (Cachable (invalInfo,
ziv@2271 1284 fn state =>
ziv@2271 1285 case cacheExp (env,
ziv@2271 1286 f (map (#2 o #1) args),
ziv@2271 1287 invalInfo,
ziv@2271 1288 state) of
ziv@2271 1289 NONE => mkExp state
ziv@2271 1290 | SOME (e', state) => ((e', loc), state)),
ziv@2271 1291 state))
ziv@2250 1292 in
ziv@2271 1293 case attempt of
ziv@2271 1294 SOME (subexp, state) => (subexp, state)
ziv@2271 1295 | NONE => mapFst Impure (mkExp state)
ziv@2250 1296 end
ziv@2250 1297 fun wrapBind1 f arg =
ziv@2289 1298 wrapBindN (fn [arg] => f arg
ziv@2289 1299 | _ => raise Fail "Sqlcache: cacheTree (a)") [arg]
ziv@2250 1300 fun wrapBind2 f (arg1, arg2) =
ziv@2289 1301 wrapBindN (fn [arg1, arg2] => f (arg1, arg2)
ziv@2289 1302 | _ => raise Fail "Sqlcache: cacheTree (b)") [arg1, arg2]
ziv@2271 1303 fun wrapN f es = wrapBindN f (map (fn e => ((env, e), Unknowns 0)) es)
ziv@2271 1304 fun wrap1 f e = wrapBind1 f ((env, e), Unknowns 0)
ziv@2271 1305 fun wrap2 f (e1, e2) = wrapBind2 f (((env, e1), Unknowns 0), ((env, e2), Unknowns 0))
ziv@2250 1306 in
ziv@2250 1307 case exp' of
ziv@2250 1308 ECon (dk, pc, SOME e) => wrap1 (fn e => ECon (dk, pc, SOME e)) e
ziv@2250 1309 | ESome (t, e) => wrap1 (fn e => ESome (t, e)) e
ziv@2250 1310 | EFfiApp (s1, s2, args) =>
ziv@2258 1311 if ffiEffectful (s1, s2)
ziv@2266 1312 then (Impure exp, state)
ziv@2258 1313 else wrapN (fn es =>
ziv@2258 1314 EFfiApp (s1, s2, ListPair.map (fn (e, (_, t)) => (e, t)) (es, args)))
ziv@2258 1315 (map #1 args)
ziv@2250 1316 | EApp (e1, e2) => wrap2 EApp (e1, e2)
ziv@2250 1317 | EAbs (s, t1, t2, e) =>
ziv@2250 1318 wrapBind1 (fn e => EAbs (s, t1, t2, e))
ziv@2271 1319 ((MonoEnv.pushERel env s t1 NONE, e), Unknowns 1)
ziv@2250 1320 | EUnop (s, e) => wrap1 (fn e => EUnop (s, e)) e
ziv@2250 1321 | EBinop (bi, s, e1, e2) => wrap2 (fn (e1, e2) => EBinop (bi, s, e1, e2)) (e1, e2)
ziv@2250 1322 | ERecord fields =>
ziv@2250 1323 wrapN (fn es => ERecord (ListPair.map (fn (e, (s, _, t)) => (s, e, t)) (es, fields)))
ziv@2250 1324 (map #2 fields)
ziv@2250 1325 | EField (e, s) => wrap1 (fn e => EField (e, s)) e
ziv@2250 1326 | ECase (e, cases, {disc, result}) =>
ziv@2250 1327 wrapBindN (fn (e::es) =>
ziv@2250 1328 ECase (e,
ziv@2250 1329 (ListPair.map (fn (e, (p, _)) => (p, e)) (es, cases)),
ziv@2256 1330 {disc = disc, result = result})
ziv@2289 1331 | _ => raise Fail "Sqlcache: cacheTree (c)")
ziv@2271 1332 (((env, e), Unknowns 0)
ziv@2271 1333 :: map (fn (p, e) =>
ziv@2271 1334 ((MonoEnv.patBinds env p, e), Unknowns (MonoEnv.patBindsN p)))
ziv@2271 1335 cases)
ziv@2250 1336 | EStrcat (e1, e2) => wrap2 EStrcat (e1, e2)
ziv@2250 1337 (* We record page writes, so they're cachable. *)
ziv@2250 1338 | EWrite e => wrap1 EWrite e
ziv@2250 1339 | ESeq (e1, e2) => wrap2 ESeq (e1, e2)
ziv@2250 1340 | ELet (s, t, e1, e2) =>
ziv@2250 1341 wrapBind2 (fn (e1, e2) => ELet (s, t, e1, e2))
ziv@2271 1342 (((env, e1), Unknowns 0),
ziv@2271 1343 ((MonoEnv.pushERel env s t (SOME e1), e2), Known e1))
ziv@2250 1344 (* ASK: | EClosure (n, es) => ? *)
ziv@2250 1345 | EUnurlify (e, t, b) => wrap1 (fn e => EUnurlify (e, t, b)) e
ziv@2271 1346 | EQuery q => (cacheQuery (effs, env, q), state)
ziv@2269 1347 | _ => (if effectful effs env exp
ziv@2269 1348 then Impure exp
ziv@2271 1349 else Cachable (InvalInfo.empty,
ziv@2271 1350 fn state =>
ziv@2271 1351 case cacheExp (env, exp', InvalInfo.empty, state) of
ziv@2269 1352 NONE => ((exp', loc), state)
ziv@2269 1353 | SOME (exp', state) => ((exp', loc), state)),
ziv@2269 1354 state)
ziv@2256 1355 end
ziv@2256 1356
ziv@2266 1357 fun addCaching file =
ziv@2256 1358 let
ziv@2266 1359 val effs = effectfulDecls file
ziv@2271 1360 fun doTopLevelExp env exp state = runSubexp (cacheTree effs ((env, exp), state))
ziv@2256 1361 in
ziv@2271 1362 (fileTopLevelMapfoldB doTopLevelExp
ziv@2271 1363 file
ziv@2271 1364 {tableToIndices = SIMM.empty,
ziv@2271 1365 indexToInvalInfo = IM.empty,
ziv@2271 1366 ffiInfo = [],
ziv@2271 1367 index = 0},
ziv@2271 1368 effs)
ziv@2265 1369 end
ziv@2265 1370
ziv@2265 1371
ziv@2265 1372 (************)
ziv@2265 1373 (* Flushing *)
ziv@2265 1374 (************)
ziv@2265 1375
ziv@2265 1376 structure Invalidations = struct
ziv@2265 1377
ziv@2265 1378 val loc = dummyLoc
ziv@2265 1379
ziv@2265 1380 val optionAtomExpToExp =
ziv@2265 1381 fn NONE => (ENone stringTyp, loc)
ziv@2265 1382 | SOME e => (ESome (stringTyp,
ziv@2265 1383 (case e of
ziv@2265 1384 DmlRel n => ERel n
ziv@2265 1385 | Prim p => EPrim p
ziv@2265 1386 (* TODO: make new type containing only these two. *)
ziv@2289 1387 | _ => raise Fail "Sqlcache: optionAtomExpToExp",
ziv@2265 1388 loc)),
ziv@2265 1389 loc)
ziv@2265 1390
ziv@2265 1391 fun eqsToInvalidation numArgs eqs =
ziv@2269 1392 List.tabulate (numArgs, (fn n => IM.find (eqs, n)))
ziv@2265 1393
ziv@2265 1394 (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here
ziv@2265 1395 represents unknown, which means a wider invalidation. *)
ziv@2265 1396 val rec madeRedundantBy : atomExp option list * atomExp option list -> bool =
ziv@2265 1397 fn ([], []) => true
ziv@2265 1398 | (_ :: xs, NONE :: ys) => madeRedundantBy (xs, ys)
ziv@2265 1399 | (SOME x :: xs, SOME y :: ys) => (case AtomExpKey.compare (x, y) of
ziv@2265 1400 EQUAL => madeRedundantBy (xs, ys)
ziv@2265 1401 | _ => false)
ziv@2265 1402 | _ => false
ziv@2265 1403
ziv@2271 1404 fun invalidations ((invalInfo, numArgs), dml) =
ziv@2271 1405 let
ziv@2271 1406 val query = InvalInfo.query invalInfo
ziv@2271 1407 in
ziv@2271 1408 (map (map optionAtomExpToExp)
ziv@2271 1409 o removeRedundant madeRedundantBy
ziv@2271 1410 o map (eqsToInvalidation numArgs)
ziv@2273 1411 o conflictMaps)
ziv@2274 1412 (pairToFormulas (query, dml))
ziv@2271 1413 end
ziv@2265 1414
ziv@2265 1415 end
ziv@2265 1416
ziv@2265 1417 val invalidations = Invalidations.invalidations
ziv@2265 1418
ziv@2273 1419 fun addFlushing ((file, {tableToIndices, indexToInvalInfo, ffiInfo, ...} : state), effs) =
ziv@2265 1420 let
ziv@2265 1421 val flushes = List.concat
ziv@2265 1422 o map (fn (i, argss) => map (fn args => flush (i, args)) argss)
ziv@2265 1423 val doExp =
ziv@2267 1424 fn dmlExp as EDml (dmlText, failureMode) =>
ziv@2265 1425 let
ziv@2265 1426 val inval =
ziv@2265 1427 case Sql.parse Sql.dml dmlText of
ziv@2265 1428 SOME dmlParsed =>
ziv@2271 1429 SOME (map (fn i => (case IM.find (indexToInvalInfo, i) of
ziv@2271 1430 SOME invalInfo =>
ziv@2271 1431 (i, invalidations (invalInfo, dmlParsed))
ziv@2265 1432 (* TODO: fail more gracefully. *)
ziv@2271 1433 (* This probably means invalidating everything.... *)
ziv@2289 1434 | NONE => raise Fail "Sqlcache: addFlushing (a)"))
ziv@2271 1435 (SIMM.findList (tableToIndices, tableOfDml dmlParsed)))
ziv@2265 1436 | NONE => NONE
ziv@2265 1437 in
ziv@2265 1438 case inval of
ziv@2265 1439 (* TODO: fail more gracefully. *)
ziv@2289 1440 NONE => raise Fail "Sqlcache: addFlushing (b)"
ziv@2267 1441 | SOME invs => sequence (flushes invs @ [dmlExp])
ziv@2265 1442 end
ziv@2265 1443 | e' => e'
ziv@2274 1444 val file = fileMap doExp file
ziv@2274 1445
ziv@2265 1446 in
ziv@2268 1447 ffiInfoRef := ffiInfo;
ziv@2274 1448 file
ziv@2265 1449 end
ziv@2265 1450
ziv@2265 1451
ziv@2286 1452 (***********)
ziv@2286 1453 (* Locking *)
ziv@2286 1454 (***********)
ziv@2286 1455
ziv@2288 1456 (* TODO: do this less evilly by not relying on specific FFI names, please? *)
ziv@2289 1457 fun locksNeeded (lockMap : {store : IIMM.multimap, flush : IIMM.multimap}) =
ziv@2289 1458 MonoUtil.Exp.fold
ziv@2289 1459 {typ = #2,
ziv@2289 1460 exp = fn (EFfiApp ("Sqlcache", x, _), state as {store, flush}) =>
ziv@2289 1461 (case Int.fromString (String.extract (x, 5, NONE)) of
ziv@2289 1462 NONE => state
ziv@2289 1463 | SOME index =>
ziv@2289 1464 if String.isPrefix "flush" x
ziv@2289 1465 then {store = store, flush = IS.add (flush, index)}
ziv@2289 1466 else if String.isPrefix "store" x
ziv@2289 1467 then {store = IS.add (store, index), flush = flush}
ziv@2289 1468 else state)
ziv@2289 1469 | (ENamed n, {store, flush}) =>
ziv@2289 1470 {store = IS.union (store, IIMM.findSet (#store lockMap, n)),
ziv@2289 1471 flush = IS.union (flush, IIMM.findSet (#flush lockMap, n))}
ziv@2289 1472 | (_, state) => state}
ziv@2289 1473 {store = IS.empty, flush = IS.empty}
ziv@2289 1474
ziv@2289 1475 fun lockMapOfFile file =
ziv@2286 1476 transitiveAnalysis
ziv@2286 1477 (fn ((_, name, _, e, _), state) =>
ziv@2289 1478 let
ziv@2289 1479 val locks = locksNeeded state e
ziv@2289 1480 in
ziv@2289 1481 {store = IIMM.insertSet (#store state, name, #store locks),
ziv@2289 1482 flush = IIMM.insertSet (#flush state, name, #flush locks)}
ziv@2289 1483 end)
ziv@2286 1484 {store = IIMM.empty, flush = IIMM.empty}
ziv@2286 1485 file
ziv@2286 1486
ziv@2286 1487 fun exports (decls, _) =
ziv@2286 1488 List.foldl (fn ((DExport (_, _, n, _, _, _), _), ns) => IS.add (ns, n)
ziv@2286 1489 | (_, ns) => ns)
ziv@2286 1490 IS.empty
ziv@2286 1491 decls
ziv@2286 1492
ziv@2288 1493 fun wrapLocks (locks, (exp', loc)) =
ziv@2288 1494 case exp' of
ziv@2288 1495 EAbs (s, t1, t2, exp) => (EAbs (s, t1, t2, wrapLocks (locks, exp)), loc)
ziv@2288 1496 | _ => (List.foldr (fn (l, e') => sequence [lock l, e']) exp' locks, loc)
ziv@2286 1497
ziv@2288 1498 fun addLocking file =
ziv@2288 1499 let
ziv@2289 1500 val lockMap = lockMapOfFile file
ziv@2289 1501 fun lockList {store, flush} =
ziv@2288 1502 let
ziv@2289 1503 val ls = map (fn i => (i, true)) (IS.listItems flush)
ziv@2289 1504 @ map (fn i => (i, false)) (IS.listItems (IS.difference (store, flush)))
ziv@2288 1505 in
ziv@2288 1506 ListMergeSort.sort (fn ((i, _), (j, _)) => i > j) ls
ziv@2288 1507 end
ziv@2289 1508 fun locksOfName n =
ziv@2289 1509 lockList {store = IIMM.findSet (#flush lockMap, n),
ziv@2289 1510 flush =IIMM.findSet (#store lockMap, n)}
ziv@2289 1511 val locksOfExp = lockList o locksNeeded lockMap
ziv@2288 1512 val expts = exports file
ziv@2288 1513 fun doVal (v as (x, n, t, exp, s)) =
ziv@2288 1514 if IS.member (expts, n)
ziv@2289 1515 then (x, n, t, wrapLocks ((locksOfName n), exp), s)
ziv@2288 1516 else v
ziv@2288 1517 val doDecl =
ziv@2288 1518 fn (DVal v, loc) => (DVal (doVal v), loc)
ziv@2288 1519 | (DValRec vs, loc) => (DValRec (map doVal vs), loc)
ziv@2289 1520 | (DTask (exp1, exp2), loc) => (DTask (exp1, wrapLocks (locksOfExp exp2, exp2)), loc)
ziv@2288 1521 | decl => decl
ziv@2288 1522 in
ziv@2288 1523 mapFst (map doDecl) file
ziv@2288 1524 end
ziv@2288 1525
ziv@2286 1526
ziv@2268 1527 (************************)
ziv@2268 1528 (* Compiler Entry Point *)
ziv@2268 1529 (************************)
ziv@2265 1530
ziv@2265 1531 val inlineSql =
ziv@2265 1532 let
ziv@2265 1533 val doExp =
ziv@2265 1534 (* TODO: EQuery, too? *)
ziv@2265 1535 (* ASK: should this live in [MonoOpt]? *)
ziv@2265 1536 fn EDml ((ECase (disc, cases, {disc = dTyp, ...}), loc), failureMode) =>
ziv@2265 1537 let
ziv@2265 1538 val newCases = map (fn (p, e) => (p, (EDml (e, failureMode), loc))) cases
ziv@2265 1539 in
ziv@2265 1540 ECase (disc, newCases, {disc = dTyp, result = (TRecord [], loc)})
ziv@2265 1541 end
ziv@2265 1542 | e => e
ziv@2265 1543 in
ziv@2265 1544 fileMap doExp
ziv@2265 1545 end
ziv@2265 1546
ziv@2262 1547 fun insertAfterDatatypes ((decls, sideInfo), newDecls) =
ziv@2262 1548 let
ziv@2262 1549 val (datatypes, others) = List.partition (fn (DDatatype _, _) => true | _ => false) decls
ziv@2262 1550 in
ziv@2262 1551 (datatypes @ newDecls @ others, sideInfo)
ziv@2262 1552 end
ziv@2262 1553
ziv@2288 1554 val go' = addLocking o addFlushing o addCaching o simplifySql o inlineSql
ziv@2256 1555
ziv@2256 1556 fun go file =
ziv@2256 1557 let
ziv@2256 1558 (* TODO: do something nicer than [Sql] being in one of two modes. *)
ziv@2256 1559 val () = (resetFfiInfo (); Sql.sqlcacheMode := true)
ziv@2262 1560 val file = go' file
ziv@2262 1561 (* Important that this happens after [MonoFooify.urlify] calls! *)
ziv@2262 1562 val fmDecls = MonoFooify.getNewFmDecls ()
ziv@2256 1563 val () = Sql.sqlcacheMode := false
ziv@2256 1564 in
ziv@2262 1565 insertAfterDatatypes (file, rev fmDecls)
ziv@2250 1566 end
ziv@2250 1567
ziv@2209 1568 end