Mercurial > urweb

annotate src/sqlcache.sml @ 2276:c05f9a5e0f0f

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