Mercurial > urweb

annotate src/sqlcache.sml @ 2269:f7bc7c11a656

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Make SQL caches use more of the pure caching machinery, but it's brittle.
author Ziv Scully <ziv@mit.edu>
date Thu, 15 Oct 2015 00:52:04 -0400
parents bc1ef958d801
children 85f91c7452b0
rev   line source
ziv@2250 1 structure Sqlcache :> SQLCACHE = struct
ziv@2209 2
ziv@2209 3 open Mono
ziv@2209 4
ziv@2209 5 structure IS = IntBinarySet
ziv@2209 6 structure IM = IntBinaryMap
ziv@2213 7 structure SK = struct type ord_key = string val compare = String.compare end
ziv@2213 8 structure SS = BinarySetFn(SK)
ziv@2213 9 structure SM = BinaryMapFn(SK)
ziv@2213 10 structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS)
ziv@2209 11
ziv@2250 12 fun iterate f n x = if n < 0
ziv@2250 13 then raise Fail "Can't iterate function negative number of times."
ziv@2250 14 else if n = 0
ziv@2250 15 then x
ziv@2250 16 else iterate f (n-1) (f x)
ziv@2250 17
ziv@2268 18 (* Filled in by [addFlushing]. *)
ziv@2268 19 val ffiInfoRef : {index : int, params : int} list ref = ref []
ziv@2209 20
ziv@2268 21 fun resetFfiInfo () = ffiInfoRef := []
ziv@2227 22
ziv@2268 23 fun getFfiInfo () = !ffiInfoRef
ziv@2213 24
ziv@2215 25 (* Some FFIs have writing as their only effect, which the caching records. *)
ziv@2215 26 val ffiEffectful =
ziv@2223 27 (* ASK: how can this be less hard-coded? *)
ziv@2215 28 let
ziv@2258 29 val okayWrites = SS.fromList ["htmlifyInt_w",
ziv@2258 30 "htmlifyFloat_w",
ziv@2258 31 "htmlifyString_w",
ziv@2258 32 "htmlifyBool_w",
ziv@2258 33 "htmlifyTime_w",
ziv@2258 34 "attrifyInt_w",
ziv@2258 35 "attrifyFloat_w",
ziv@2258 36 "attrifyString_w",
ziv@2258 37 "attrifyChar_w",
ziv@2258 38 "urlifyInt_w",
ziv@2258 39 "urlifyFloat_w",
ziv@2258 40 "urlifyString_w",
ziv@2258 41 "urlifyBool_w",
ziv@2258 42 "urlifyChannel_w"]
ziv@2215 43 in
ziv@2265 44 (* ASK: is it okay to hardcode Sqlcache functions as effectful? *)
ziv@2215 45 fn (m, f) => Settings.isEffectful (m, f)
ziv@2258 46 andalso not (m = "Basis" andalso SS.member (okayWrites, f))
ziv@2215 47 end
ziv@2215 48
ziv@2234 49 val cache = ref LruCache.cache
ziv@2233 50 fun setCache c = cache := c
ziv@2233 51 fun getCache () = !cache
ziv@2233 52
ziv@2248 53 (* Used to have type context for local variables in MonoUtil functions. *)
ziv@2248 54 val doBind =
ziv@2262 55 fn (env, MonoUtil.Exp.RelE (x, t)) => MonoEnv.pushERel env x t NONE
ziv@2262 56 | (env, MonoUtil.Exp.NamedE (x, n, t, eo, s)) => MonoEnv.pushENamed env x n t eo s
ziv@2262 57 | (env, MonoUtil.Exp.Datatype (x, n, cs)) => MonoEnv.pushDatatype env x n cs
ziv@2215 58
ziv@2266 59 (***********************)
ziv@2266 60 (* General Combinators *)
ziv@2266 61 (***********************)
ziv@2266 62
ziv@2266 63 (* From the MLton wiki. *)
ziv@2266 64 infixr 3 /> fun f /> y = fn x => f (x, y) (* Right section *)
ziv@2266 65 infixr 3 </ fun x </ f = f x (* Right application *)
ziv@2266 66
ziv@2266 67 (* Option monad. *)
ziv@2266 68 fun obind (x, f) = Option.mapPartial f x
ziv@2266 69 fun oguard (b, x) = if b then x else NONE
ziv@2248 70
ziv@2268 71 fun mapFst f (x, y) = (f x, y)
ziv@2268 72
ziv@2268 73
ziv@2248 74 (*******************)
ziv@2248 75 (* Effect Analysis *)
ziv@2248 76 (*******************)
ziv@2215 77
ziv@2216 78 (* Makes an exception for [EWrite] (which is recorded when caching). *)
ziv@2248 79 fun effectful (effs : IS.set) =
ziv@2215 80 let
ziv@2248 81 val isFunction =
ziv@2248 82 fn (TFun _, _) => true
ziv@2248 83 | _ => false
ziv@2250 84 fun doExp (env, e) =
ziv@2248 85 case e of
ziv@2248 86 EPrim _ => false
ziv@2248 87 (* For now: variables of function type might be effectful, but
ziv@2248 88 others are fully evaluated and are therefore not effectful. *)
ziv@2250 89 | ERel n => isFunction (#2 (MonoEnv.lookupERel env n))
ziv@2248 90 | ENamed n => IS.member (effs, n)
ziv@2248 91 | EFfi (m, f) => ffiEffectful (m, f)
ziv@2248 92 | EFfiApp (m, f, _) => ffiEffectful (m, f)
ziv@2248 93 (* These aren't effectful unless a subexpression is. *)
ziv@2248 94 | ECon _ => false
ziv@2248 95 | ENone _ => false
ziv@2248 96 | ESome _ => false
ziv@2248 97 | EApp _ => false
ziv@2248 98 | EAbs _ => false
ziv@2248 99 | EUnop _ => false
ziv@2248 100 | EBinop _ => false
ziv@2248 101 | ERecord _ => false
ziv@2248 102 | EField _ => false
ziv@2248 103 | ECase _ => false
ziv@2248 104 | EStrcat _ => false
ziv@2248 105 (* EWrite is a special exception because we record writes when caching. *)
ziv@2248 106 | EWrite _ => false
ziv@2248 107 | ESeq _ => false
ziv@2248 108 | ELet _ => false
ziv@2250 109 | EUnurlify _ => false
ziv@2248 110 (* ASK: what should we do about closures? *)
ziv@2248 111 (* Everything else is some sort of effect. We could flip this and
ziv@2248 112 explicitly list bits of Mono that are effectful, but this is
ziv@2248 113 conservatively robust to future changes (however unlikely). *)
ziv@2248 114 | _ => true
ziv@2215 115 in
ziv@2248 116 MonoUtil.Exp.existsB {typ = fn _ => false, exp = doExp, bind = doBind}
ziv@2215 117 end
ziv@2215 118
ziv@2215 119 (* TODO: test this. *)
ziv@2252 120 fun effectfulDecls (decls, _) =
ziv@2215 121 let
ziv@2248 122 fun doVal ((_, name, _, e, _), effs) =
ziv@2250 123 if effectful effs MonoEnv.empty e
ziv@2248 124 then IS.add (effs, name)
ziv@2248 125 else effs
ziv@2215 126 val doDecl =
ziv@2248 127 fn ((DVal v, _), effs) => doVal (v, effs)
ziv@2248 128 (* Repeat the list of declarations a number of times equal to its size,
ziv@2248 129 making sure effectfulness propagates everywhere it should. This is
ziv@2248 130 analagous to the Bellman-Ford algorithm. *)
ziv@2248 131 | ((DValRec vs, _), effs) =>
ziv@2248 132 List.foldl doVal effs (List.concat (List.map (fn _ => vs) vs))
ziv@2215 133 (* ASK: any other cases? *)
ziv@2248 134 | (_, effs) => effs
ziv@2215 135 in
ziv@2248 136 List.foldl doDecl IS.empty decls
ziv@2215 137 end
ziv@2215 138
ziv@2215 139
ziv@2248 140 (*********************************)
ziv@2248 141 (* Boolean Formula Normalization *)
ziv@2248 142 (*********************************)
ziv@2216 143
ziv@2234 144 datatype junctionType = Conj | Disj
ziv@2216 145
ziv@2216 146 datatype 'atom formula =
ziv@2216 147 Atom of 'atom
ziv@2216 148 | Negate of 'atom formula
ziv@2234 149 | Combo of junctionType * 'atom formula list
ziv@2216 150
ziv@2243 151 (* Guaranteed to have all negation pushed to the atoms. *)
ziv@2243 152 datatype 'atom formula' =
ziv@2243 153 Atom' of 'atom
ziv@2243 154 | Combo' of junctionType * 'atom formula' list
ziv@2243 155
ziv@2234 156 val flipJt = fn Conj => Disj | Disj => Conj
ziv@2216 157
ziv@2236 158 fun concatMap f xs = List.concat (map f xs)
ziv@2216 159
ziv@2216 160 val rec cartesianProduct : 'a list list -> 'a list list =
ziv@2216 161 fn [] => [[]]
ziv@2236 162 | (xs :: xss) => concatMap (fn ys => concatMap (fn x => [x :: ys]) xs)
ziv@2236 163 (cartesianProduct xss)
ziv@2216 164
ziv@2218 165 (* Pushes all negation to the atoms.*)
ziv@2244 166 fun pushNegate (normalizeAtom : bool * 'atom -> 'atom) (negating : bool) =
ziv@2244 167 fn Atom x => Atom' (normalizeAtom (negating, x))
ziv@2244 168 | Negate f => pushNegate normalizeAtom (not negating) f
ziv@2244 169 | Combo (j, fs) => Combo' (if negating then flipJt j else j,
ziv@2244 170 map (pushNegate normalizeAtom negating) fs)
ziv@2218 171
ziv@2218 172 val rec flatten =
ziv@2243 173 fn Combo' (_, [f]) => flatten f
ziv@2243 174 | Combo' (j, fs) =>
ziv@2243 175 Combo' (j, List.foldr (fn (f, acc) =>
ziv@2243 176 case f of
ziv@2243 177 Combo' (j', fs') =>
ziv@2243 178 if j = j' orelse length fs' = 1
ziv@2243 179 then fs' @ acc
ziv@2243 180 else f :: acc
ziv@2243 181 | _ => f :: acc)
ziv@2243 182 []
ziv@2243 183 (map flatten fs))
ziv@2218 184 | f => f
ziv@2218 185
ziv@2243 186 (* [simplify] operates on the desired normal form. E.g., if [junc] is [Disj],
ziv@2243 187 consider the list of lists to be a disjunction of conjunctions. *)
ziv@2237 188 fun normalize' (simplify : 'a list list -> 'a list list)
ziv@2235 189 (junc : junctionType) =
ziv@2216 190 let
ziv@2235 191 fun norm junc =
ziv@2237 192 simplify
ziv@2243 193 o (fn Atom' x => [[x]]
ziv@2243 194 | Combo' (j, fs) =>
ziv@2235 195 let
ziv@2236 196 val fss = map (norm junc) fs
ziv@2235 197 in
ziv@2236 198 if j = junc
ziv@2236 199 then List.concat fss
ziv@2236 200 else map List.concat (cartesianProduct fss)
ziv@2235 201 end)
ziv@2216 202 in
ziv@2235 203 norm junc
ziv@2216 204 end
ziv@2216 205
ziv@2244 206 fun normalize simplify normalizeAtom junc =
ziv@2243 207 normalize' simplify junc
ziv@2235 208 o flatten
ziv@2244 209 o pushNegate normalizeAtom false
ziv@2216 210
ziv@2221 211 fun mapFormula mf =
ziv@2221 212 fn Atom x => Atom (mf x)
ziv@2221 213 | Negate f => Negate (mapFormula mf f)
ziv@2235 214 | Combo (j, fs) => Combo (j, map (mapFormula mf) fs)
ziv@2216 215
ziv@2230 216
ziv@2248 217 (****************)
ziv@2248 218 (* SQL Analysis *)
ziv@2248 219 (****************)
ziv@2213 220
ziv@2240 221 structure CmpKey = struct
ziv@2235 222
ziv@2235 223 type ord_key = Sql.cmp
ziv@2235 224
ziv@2235 225 val compare =
ziv@2235 226 fn (Sql.Eq, Sql.Eq) => EQUAL
ziv@2235 227 | (Sql.Eq, _) => LESS
ziv@2235 228 | (_, Sql.Eq) => GREATER
ziv@2235 229 | (Sql.Ne, Sql.Ne) => EQUAL
ziv@2235 230 | (Sql.Ne, _) => LESS
ziv@2235 231 | (_, Sql.Ne) => GREATER
ziv@2235 232 | (Sql.Lt, Sql.Lt) => EQUAL
ziv@2235 233 | (Sql.Lt, _) => LESS
ziv@2235 234 | (_, Sql.Lt) => GREATER
ziv@2235 235 | (Sql.Le, Sql.Le) => EQUAL
ziv@2235 236 | (Sql.Le, _) => LESS
ziv@2235 237 | (_, Sql.Le) => GREATER
ziv@2235 238 | (Sql.Gt, Sql.Gt) => EQUAL
ziv@2235 239 | (Sql.Gt, _) => LESS
ziv@2235 240 | (_, Sql.Gt) => GREATER
ziv@2235 241 | (Sql.Ge, Sql.Ge) => EQUAL
ziv@2235 242
ziv@2235 243 end
ziv@2235 244
ziv@2216 245 val rec chooseTwos : 'a list -> ('a * 'a) list =
ziv@2216 246 fn [] => []
ziv@2216 247 | x :: ys => map (fn y => (x, y)) ys @ chooseTwos ys
ziv@2213 248
ziv@2237 249 fun removeRedundant madeRedundantBy zs =
ziv@2237 250 let
ziv@2237 251 fun removeRedundant' (xs, ys) =
ziv@2237 252 case xs of
ziv@2237 253 [] => ys
ziv@2237 254 | x :: xs' =>
ziv@2237 255 removeRedundant' (xs',
ziv@2237 256 if List.exists (fn y => madeRedundantBy (x, y)) (xs' @ ys)
ziv@2237 257 then ys
ziv@2237 258 else x :: ys)
ziv@2237 259 in
ziv@2237 260 removeRedundant' (zs, [])
ziv@2237 261 end
ziv@2237 262
ziv@2216 263 datatype atomExp =
ziv@2216 264 QueryArg of int
ziv@2216 265 | DmlRel of int
ziv@2216 266 | Prim of Prim.t
ziv@2216 267 | Field of string * string
ziv@2216 268
ziv@2216 269 structure AtomExpKey : ORD_KEY = struct
ziv@2216 270
ziv@2234 271 type ord_key = atomExp
ziv@2216 272
ziv@2234 273 val compare =
ziv@2234 274 fn (QueryArg n1, QueryArg n2) => Int.compare (n1, n2)
ziv@2234 275 | (QueryArg _, _) => LESS
ziv@2234 276 | (_, QueryArg _) => GREATER
ziv@2234 277 | (DmlRel n1, DmlRel n2) => Int.compare (n1, n2)
ziv@2234 278 | (DmlRel _, _) => LESS
ziv@2234 279 | (_, DmlRel _) => GREATER
ziv@2234 280 | (Prim p1, Prim p2) => Prim.compare (p1, p2)
ziv@2234 281 | (Prim _, _) => LESS
ziv@2234 282 | (_, Prim _) => GREATER
ziv@2234 283 | (Field (t1, f1), Field (t2, f2)) =>
ziv@2234 284 case String.compare (t1, t2) of
ziv@2234 285 EQUAL => String.compare (f1, f2)
ziv@2234 286 | ord => ord
ziv@2216 287
ziv@2216 288 end
ziv@2216 289
ziv@2244 290 structure AtomOptionKey = OptionKeyFn(AtomExpKey)
ziv@2244 291
ziv@2216 292 structure UF = UnionFindFn(AtomExpKey)
ziv@2234 293
ziv@2235 294 structure ConflictMaps = struct
ziv@2235 295
ziv@2235 296 structure TK = TripleKeyFn(structure I = CmpKey
ziv@2244 297 structure J = AtomOptionKey
ziv@2244 298 structure K = AtomOptionKey)
ziv@2244 299 structure TS : ORD_SET = BinarySetFn(TK)
ziv@2235 300
ziv@2235 301 val toKnownEquality =
ziv@2235 302 (* [NONE] here means unkown. Anything that isn't a comparison between two
ziv@2235 303 knowns shouldn't be used, and simply dropping unused terms is okay in
ziv@2235 304 disjunctive normal form. *)
ziv@2235 305 fn (Sql.Eq, SOME e1, SOME e2) => SOME (e1, e2)
ziv@2235 306 | _ => NONE
ziv@2235 307
ziv@2235 308 val equivClasses : (Sql.cmp * atomExp option * atomExp option) list -> atomExp list list =
ziv@2235 309 UF.classes
ziv@2235 310 o List.foldl UF.union' UF.empty
ziv@2235 311 o List.mapPartial toKnownEquality
ziv@2235 312
ziv@2235 313 fun addToEqs (eqs, n, e) =
ziv@2235 314 case IM.find (eqs, n) of
ziv@2235 315 (* Comparing to a constant is probably better than comparing to a
ziv@2235 316 variable? Checking that existing constants match a new ones is
ziv@2235 317 handled by [accumulateEqs]. *)
ziv@2235 318 SOME (Prim _) => eqs
ziv@2235 319 | _ => IM.insert (eqs, n, e)
ziv@2235 320
ziv@2235 321 val accumulateEqs =
ziv@2235 322 (* [NONE] means we have a contradiction. *)
ziv@2235 323 fn (_, NONE) => NONE
ziv@2235 324 | ((Prim p1, Prim p2), eqso) =>
ziv@2235 325 (case Prim.compare (p1, p2) of
ziv@2235 326 EQUAL => eqso
ziv@2235 327 | _ => NONE)
ziv@2235 328 | ((QueryArg n, Prim p), SOME eqs) => SOME (addToEqs (eqs, n, Prim p))
ziv@2235 329 | ((QueryArg n, DmlRel r), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r))
ziv@2235 330 | ((Prim p, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, Prim p))
ziv@2235 331 | ((DmlRel r, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r))
ziv@2235 332 (* TODO: deal with equalities between [DmlRel]s and [Prim]s.
ziv@2235 333 This would involve guarding the invalidation with a check for the
ziv@2235 334 relevant comparisons. *)
ziv@2235 335 | (_, eqso) => eqso
ziv@2235 336
ziv@2235 337 val eqsOfClass : atomExp list -> atomExp IM.map option =
ziv@2235 338 List.foldl accumulateEqs (SOME IM.empty)
ziv@2235 339 o chooseTwos
ziv@2235 340
ziv@2235 341 fun toAtomExps rel (cmp, e1, e2) =
ziv@2235 342 let
ziv@2235 343 val qa =
ziv@2235 344 (* Here [NONE] means unkown. *)
ziv@2235 345 fn Sql.SqConst p => SOME (Prim p)
ziv@2235 346 | Sql.Field tf => SOME (Field tf)
ziv@2235 347 | Sql.Inj (EPrim p, _) => SOME (Prim p)
ziv@2235 348 | Sql.Inj (ERel n, _) => SOME (rel n)
ziv@2235 349 (* We can't deal with anything else, e.g., CURRENT_TIMESTAMP
ziv@2235 350 becomes Sql.Unmodeled, which becomes NONE here. *)
ziv@2235 351 | _ => NONE
ziv@2235 352 in
ziv@2235 353 (cmp, qa e1, qa e2)
ziv@2235 354 end
ziv@2235 355
ziv@2244 356 val negateCmp =
ziv@2244 357 fn Sql.Eq => Sql.Ne
ziv@2244 358 | Sql.Ne => Sql.Eq
ziv@2244 359 | Sql.Lt => Sql.Ge
ziv@2244 360 | Sql.Le => Sql.Gt
ziv@2244 361 | Sql.Gt => Sql.Le
ziv@2244 362 | Sql.Ge => Sql.Lt
ziv@2244 363
ziv@2244 364 fun normalizeAtom (negating, (cmp, e1, e2)) =
ziv@2244 365 (* Restricting to Le/Lt and sorting the expressions in Eq/Ne helps with
ziv@2244 366 simplification, where we put the triples in sets. *)
ziv@2244 367 case (if negating then negateCmp cmp else cmp) of
ziv@2244 368 Sql.Eq => (case AtomOptionKey.compare (e1, e2) of
ziv@2244 369 LESS => (Sql.Eq, e2, e1)
ziv@2244 370 | _ => (Sql.Eq, e1, e2))
ziv@2244 371 | Sql.Ne => (case AtomOptionKey.compare (e1, e2) of
ziv@2244 372 LESS => (Sql.Ne, e2, e1)
ziv@2244 373 | _ => (Sql.Ne, e1, e2))
ziv@2244 374 | Sql.Lt => (Sql.Lt, e1, e2)
ziv@2244 375 | Sql.Le => (Sql.Le, e1, e2)
ziv@2244 376 | Sql.Gt => (Sql.Lt, e2, e1)
ziv@2244 377 | Sql.Ge => (Sql.Le, e2, e1)
ziv@2235 378
ziv@2235 379 val markQuery : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula ->
ziv@2235 380 (Sql.cmp * atomExp option * atomExp option) formula =
ziv@2235 381 mapFormula (toAtomExps QueryArg)
ziv@2235 382
ziv@2235 383 val markDml : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula ->
ziv@2235 384 (Sql.cmp * atomExp option * atomExp option) formula =
ziv@2235 385 mapFormula (toAtomExps DmlRel)
ziv@2250 386
ziv@2235 387 (* No eqs should have key conflicts because no variable is in two
ziv@2235 388 equivalence classes, so the [#1] could be [#2]. *)
ziv@2235 389 val mergeEqs : (atomExp IntBinaryMap.map option list
ziv@2235 390 -> atomExp IntBinaryMap.map option) =
ziv@2235 391 List.foldr (fn (SOME eqs, SOME acc) => SOME (IM.unionWith #1 (eqs, acc)) | _ => NONE)
ziv@2235 392 (SOME IM.empty)
ziv@2235 393
ziv@2239 394 val simplify =
ziv@2239 395 map TS.listItems
ziv@2239 396 o removeRedundant (fn (x, y) => TS.isSubset (y, x))
ziv@2239 397 o map (fn xs => TS.addList (TS.empty, xs))
ziv@2239 398
ziv@2235 399 fun dnf (fQuery, fDml) =
ziv@2244 400 normalize simplify normalizeAtom Disj (Combo (Conj, [markQuery fQuery, markDml fDml]))
ziv@2235 401
ziv@2235 402 val conflictMaps = List.mapPartial (mergeEqs o map eqsOfClass o equivClasses) o dnf
ziv@2235 403
ziv@2235 404 end
ziv@2235 405
ziv@2235 406 val conflictMaps = ConflictMaps.conflictMaps
ziv@2213 407
ziv@2216 408 val rec sqexpToFormula =
ziv@2234 409 fn Sql.SqTrue => Combo (Conj, [])
ziv@2234 410 | Sql.SqFalse => Combo (Disj, [])
ziv@2216 411 | Sql.SqNot e => Negate (sqexpToFormula e)
ziv@2216 412 | Sql.Binop (Sql.RCmp c, e1, e2) => Atom (c, e1, e2)
ziv@2234 413 | Sql.Binop (Sql.RLop l, p1, p2) => Combo (case l of Sql.And => Conj | Sql.Or => Disj,
ziv@2216 414 [sqexpToFormula p1, sqexpToFormula p2])
ziv@2216 415 (* ASK: any other sqexps that can be props? *)
ziv@2216 416 | _ => raise Match
ziv@2213 417
ziv@2218 418 fun renameTables tablePairs =
ziv@2216 419 let
ziv@2216 420 fun renameString table =
ziv@2216 421 case List.find (fn (_, t) => table = t) tablePairs of
ziv@2216 422 NONE => table
ziv@2216 423 | SOME (realTable, _) => realTable
ziv@2216 424 val renameSqexp =
ziv@2216 425 fn Sql.Field (table, field) => Sql.Field (renameString table, field)
ziv@2216 426 | e => e
ziv@2218 427 fun renameAtom (cmp, e1, e2) = (cmp, renameSqexp e1, renameSqexp e2)
ziv@2216 428 in
ziv@2218 429 mapFormula renameAtom
ziv@2216 430 end
ziv@2218 431
ziv@2218 432 val rec queryToFormula =
ziv@2234 433 fn Sql.Query1 {Where = NONE, ...} => Combo (Conj, [])
ziv@2218 434 | Sql.Query1 {From = tablePairs, Where = SOME e, ...} =>
ziv@2218 435 renameTables tablePairs (sqexpToFormula e)
ziv@2234 436 | Sql.Union (q1, q2) => Combo (Disj, [queryToFormula q1, queryToFormula q2])
ziv@2216 437
ziv@2218 438 fun valsToFormula (table, vals) =
ziv@2234 439 Combo (Conj, map (fn (field, v) => Atom (Sql.Eq, Sql.Field (table, field), v)) vals)
ziv@2218 440
ziv@2216 441 val rec dmlToFormula =
ziv@2221 442 fn Sql.Insert (table, vals) => valsToFormula (table, vals)
ziv@2218 443 | Sql.Delete (table, wher) => renameTables [(table, "T")] (sqexpToFormula wher)
ziv@2218 444 | Sql.Update (table, vals, wher) =>
ziv@2218 445 let
ziv@2221 446 val fWhere = sqexpToFormula wher
ziv@2221 447 val fVals = valsToFormula (table, vals)
ziv@2237 448 val modifiedFields = SS.addList (SS.empty, map #1 vals)
ziv@2221 449 (* TODO: don't use field name hack. *)
ziv@2221 450 val markField =
ziv@2237 451 fn e as Sql.Field (t, v) => if SS.member (modifiedFields, v)
ziv@2237 452 then Sql.Field (t, v ^ "'")
ziv@2237 453 else e
ziv@2221 454 | e => e
ziv@2221 455 val mark = mapFormula (fn (cmp, e1, e2) => (cmp, markField e1, markField e2))
ziv@2218 456 in
ziv@2218 457 renameTables [(table, "T")]
ziv@2234 458 (Combo (Disj, [Combo (Conj, [fVals, mark fWhere]),
ziv@2244 459 Combo (Conj, [mark fVals, fWhere])]))
ziv@2218 460 end
ziv@2213 461
ziv@2213 462 val rec tablesQuery =
ziv@2216 463 fn Sql.Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs)
ziv@2216 464 | Sql.Union (q1, q2) => SS.union (tablesQuery q1, tablesQuery q2)
ziv@2213 465
ziv@2213 466 val tableDml =
ziv@2216 467 fn Sql.Insert (tab, _) => tab
ziv@2216 468 | Sql.Delete (tab, _) => tab
ziv@2216 469 | Sql.Update (tab, _, _) => tab
ziv@2213 470
ziv@2213 471
ziv@2265 472 (*************************************)
ziv@2265 473 (* Program Instrumentation Utilities *)
ziv@2265 474 (*************************************)
ziv@2213 475
ziv@2234 476 val varName =
ziv@2234 477 let
ziv@2234 478 val varNumber = ref 0
ziv@2234 479 in
ziv@2234 480 fn s => (varNumber := !varNumber + 1; s ^ Int.toString (!varNumber))
ziv@2234 481 end
ziv@2234 482
ziv@2233 483 val {check, store, flush, ...} = getCache ()
ziv@2233 484
ziv@2230 485 val dummyLoc = ErrorMsg.dummySpan
ziv@2216 486
ziv@2248 487 val dummyTyp = (TRecord [], dummyLoc)
ziv@2248 488
ziv@2230 489 fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), dummyLoc)
ziv@2230 490
ziv@2230 491 val stringTyp = (TFfi ("Basis", "string"), dummyLoc)
ziv@2213 492
ziv@2213 493 val sequence =
ziv@2213 494 fn (exp :: exps) =>
ziv@2213 495 let
ziv@2230 496 val loc = dummyLoc
ziv@2213 497 in
ziv@2213 498 List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps
ziv@2213 499 end
ziv@2213 500 | _ => raise Match
ziv@2213 501
ziv@2248 502 (* Always increments negative indices as a hack we use later. *)
ziv@2248 503 fun incRels inc =
ziv@2215 504 MonoUtil.Exp.mapB
ziv@2248 505 {typ = fn t' => t',
ziv@2248 506 exp = fn bound =>
ziv@2248 507 (fn ERel n => ERel (if n >= bound orelse n < 0 then n + inc else n)
ziv@2248 508 | e' => e'),
ziv@2248 509 bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound}
ziv@2248 510 0
ziv@2213 511
ziv@2262 512 fun fileTopLevelMapfoldB doTopLevelExp (decls, sideInfo) state =
ziv@2262 513 let
ziv@2262 514 fun doVal env ((x, n, t, exp, s), state) =
ziv@2262 515 let
ziv@2262 516 val (exp, state) = doTopLevelExp env exp state
ziv@2262 517 in
ziv@2262 518 ((x, n, t, exp, s), state)
ziv@2262 519 end
ziv@2262 520 fun doDecl' env (decl', state) =
ziv@2262 521 case decl' of
ziv@2262 522 DVal v =>
ziv@2262 523 let
ziv@2262 524 val (v, state) = doVal env (v, state)
ziv@2262 525 in
ziv@2262 526 (DVal v, state)
ziv@2262 527 end
ziv@2262 528 | DValRec vs =>
ziv@2262 529 let
ziv@2262 530 val (vs, state) = ListUtil.foldlMap (doVal env) state vs
ziv@2262 531 in
ziv@2262 532 (DValRec vs, state)
ziv@2262 533 end
ziv@2262 534 | _ => (decl', state)
ziv@2262 535 fun doDecl (decl as (decl', loc), (env, state)) =
ziv@2262 536 let
ziv@2262 537 val env = MonoEnv.declBinds env decl
ziv@2262 538 val (decl', state) = doDecl' env (decl', state)
ziv@2262 539 in
ziv@2262 540 ((decl', loc), (env, state))
ziv@2262 541 end
ziv@2262 542 val (decls, (_, state)) = (ListUtil.foldlMap doDecl (MonoEnv.empty, state) decls)
ziv@2262 543 in
ziv@2262 544 ((decls, sideInfo), state)
ziv@2262 545 end
ziv@2262 546
ziv@2262 547 fun fileAllMapfoldB doExp file start =
ziv@2248 548 case MonoUtil.File.mapfoldB
ziv@2248 549 {typ = Search.return2,
ziv@2250 550 exp = fn env => fn e' => fn s => Search.Continue (doExp env e' s),
ziv@2248 551 decl = fn _ => Search.return2,
ziv@2248 552 bind = doBind}
ziv@2250 553 MonoEnv.empty file start of
ziv@2213 554 Search.Continue x => x
ziv@2213 555 | Search.Return _ => raise Match
ziv@2213 556
ziv@2262 557 fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ())
ziv@2213 558
ziv@2267 559 (* TODO: make this a bit prettier.... *)
ziv@2267 560 val simplifySql =
ziv@2266 561 let
ziv@2267 562 fun factorOutNontrivial text =
ziv@2267 563 let
ziv@2267 564 val loc = dummyLoc
ziv@2267 565 fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
ziv@2267 566 val chunks = Sql.chunkify text
ziv@2267 567 val (newText, newVariables) =
ziv@2267 568 (* Important that this is foldr (to oppose foldl below). *)
ziv@2267 569 List.foldr
ziv@2267 570 (fn (chunk, (qText, newVars)) =>
ziv@2267 571 (* Variable bound to the head of newVars will have the lowest index. *)
ziv@2267 572 case chunk of
ziv@2267 573 (* EPrim should always be a string in this case. *)
ziv@2267 574 Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars)
ziv@2267 575 | Sql.Exp e =>
ziv@2267 576 let
ziv@2267 577 val n = length newVars
ziv@2267 578 in
ziv@2267 579 (* This is the (n+1)th new variable, so there are
ziv@2267 580 already n new variables bound, so we increment
ziv@2267 581 indices by n. *)
ziv@2267 582 (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars)
ziv@2267 583 end
ziv@2267 584 | Sql.String s => (strcat (stringExp s, qText), newVars))
ziv@2267 585 (stringExp "", [])
ziv@2267 586 chunks
ziv@2267 587 fun wrapLets e' =
ziv@2267 588 (* Important that this is foldl (to oppose foldr above). *)
ziv@2267 589 List.foldl (fn (v, e') => ELet (varName "sqlArg", stringTyp, v, (e', loc)))
ziv@2267 590 e'
ziv@2267 591 newVariables
ziv@2267 592 val numArgs = length newVariables
ziv@2267 593 in
ziv@2267 594 (newText, wrapLets, numArgs)
ziv@2267 595 end
ziv@2267 596 fun doExp exp' =
ziv@2267 597 let
ziv@2267 598 val text = case exp' of
ziv@2267 599 EQuery {query = text, ...} => text
ziv@2267 600 | EDml (text, _) => text
ziv@2267 601 | _ => raise Match
ziv@2267 602 val (newText, wrapLets, numArgs) = factorOutNontrivial text
ziv@2267 603 val newExp' = case exp' of
ziv@2267 604 EQuery q => EQuery {query = newText,
ziv@2267 605 exps = #exps q,
ziv@2267 606 tables = #tables q,
ziv@2267 607 state = #state q,
ziv@2267 608 body = #body q,
ziv@2267 609 initial = #initial q}
ziv@2267 610 | EDml (_, failureMode) => EDml (newText, failureMode)
ziv@2267 611 | _ => raise Match
ziv@2267 612 in
ziv@2267 613 (* Increment once for each new variable just made. This is
ziv@2267 614 where we use the negative De Bruijn indices hack. *)
ziv@2267 615 (* TODO: please don't use that hack. As anyone could have
ziv@2267 616 predicted, it was incomprehensible a year later.... *)
ziv@2267 617 wrapLets (#1 (incRels numArgs (newExp', dummyLoc)))
ziv@2267 618 end
ziv@2266 619 in
ziv@2267 620 fileMap (fn exp' => case exp' of
ziv@2267 621 EQuery _ => doExp exp'
ziv@2267 622 | EDml _ => doExp exp'
ziv@2267 623 | _ => exp')
ziv@2266 624 end
ziv@2266 625
ziv@2250 626
ziv@2250 627 (**********************)
ziv@2250 628 (* Mono Type Checking *)
ziv@2250 629 (**********************)
ziv@2250 630
ziv@2250 631 fun typOfExp' (env : MonoEnv.env) : exp' -> typ option =
ziv@2250 632 fn EPrim p => SOME (TFfi ("Basis", case p of
ziv@2250 633 Prim.Int _ => "int"
ziv@2250 634 | Prim.Float _ => "double"
ziv@2250 635 | Prim.String _ => "string"
ziv@2250 636 | Prim.Char _ => "char"),
ziv@2250 637 dummyLoc)
ziv@2250 638 | ERel n => SOME (#2 (MonoEnv.lookupERel env n))
ziv@2250 639 | ENamed n => SOME (#2 (MonoEnv.lookupENamed env n))
ziv@2250 640 (* ASK: okay to make a new [ref] each time? *)
ziv@2250 641 | ECon (dk, PConVar nCon, _) =>
ziv@2250 642 let
ziv@2250 643 val (_, _, nData) = MonoEnv.lookupConstructor env nCon
ziv@2250 644 val (_, cs) = MonoEnv.lookupDatatype env nData
ziv@2250 645 in
ziv@2250 646 SOME (TDatatype (nData, ref (dk, cs)), dummyLoc)
ziv@2250 647 end
ziv@2250 648 | ECon (_, PConFfi {mod = s, datatyp, ...}, _) => SOME (TFfi (s, datatyp), dummyLoc)
ziv@2250 649 | ENone t => SOME (TOption t, dummyLoc)
ziv@2250 650 | ESome (t, _) => SOME (TOption t, dummyLoc)
ziv@2250 651 | EFfi _ => NONE
ziv@2250 652 | EFfiApp _ => NONE
ziv@2250 653 | EApp (e1, e2) => (case typOfExp env e1 of
ziv@2250 654 SOME (TFun (_, t), _) => SOME t
ziv@2250 655 | _ => NONE)
ziv@2250 656 | EAbs (_, t1, t2, _) => SOME (TFun (t1, t2), dummyLoc)
ziv@2250 657 (* ASK: is this right? *)
ziv@2250 658 | EUnop (unop, e) => (case unop of
ziv@2250 659 "!" => SOME (TFfi ("Basis", "bool"), dummyLoc)
ziv@2250 660 | "-" => typOfExp env e
ziv@2250 661 | _ => NONE)
ziv@2250 662 (* ASK: how should this (and other "=> NONE" cases) work? *)
ziv@2250 663 | EBinop _ => NONE
ziv@2250 664 | ERecord fields => SOME (TRecord (map (fn (s, _, t) => (s, t)) fields), dummyLoc)
ziv@2250 665 | EField (e, s) => (case typOfExp env e of
ziv@2250 666 SOME (TRecord fields, _) =>
ziv@2250 667 (case List.find (fn (s', _) => s = s') fields of
ziv@2250 668 SOME (_, t) => SOME t
ziv@2250 669 | _ => NONE)
ziv@2250 670 | _ => NONE)
ziv@2250 671 | ECase (_, _, {result, ...}) => SOME result
ziv@2250 672 | EStrcat _ => SOME (TFfi ("Basis", "string"), dummyLoc)
ziv@2250 673 | EWrite _ => SOME (TRecord [], dummyLoc)
ziv@2250 674 | ESeq (_, e) => typOfExp env e
ziv@2250 675 | ELet (s, t, e1, e2) => typOfExp (MonoEnv.pushERel env s t (SOME e1)) e2
ziv@2250 676 | EClosure _ => NONE
ziv@2250 677 | EUnurlify (_, t, _) => SOME t
ziv@2269 678 | EQuery {state, ...} => SOME state
ziv@2256 679 | _ => NONE
ziv@2250 680
ziv@2250 681 and typOfExp env (e', loc) = typOfExp' env e'
ziv@2250 682
ziv@2250 683
ziv@2266 684 (***********)
ziv@2266 685 (* Caching *)
ziv@2266 686 (***********)
ziv@2250 687
ziv@2267 688 (*
ziv@2267 689
ziv@2267 690 To get the invalidations for a dml, we need (each <- is list-monad-y):
ziv@2267 691 * table <- dml
ziv@2267 692 * cache <- table
ziv@2267 693 * query <- cache
ziv@2267 694 * inval <- (query, dml),
ziv@2267 695 where inval is a list of query argument indices, so
ziv@2267 696 * way to change query args in inval to cache args.
ziv@2267 697 For now, the last one is just
ziv@2267 698 * a map from query arg number to the corresponding free variable (per query)
ziv@2267 699 * a map from free variable to cache arg number (per cache).
ziv@2267 700 Both queries and caches should have IDs.
ziv@2267 701
ziv@2267 702 *)
ziv@2267 703
ziv@2268 704 fun cacheWrap (env, exp, resultTyp, args, state as (_, _, ffiInfo, index)) =
ziv@2265 705 let
ziv@2265 706 val loc = dummyLoc
ziv@2265 707 val rel0 = (ERel 0, loc)
ziv@2265 708 in
ziv@2265 709 case MonoFooify.urlify env (rel0, resultTyp) of
ziv@2265 710 NONE => NONE
ziv@2265 711 | SOME urlified =>
ziv@2265 712 let
ziv@2265 713 (* We ensure before this step that all arguments aren't effectful.
ziv@2265 714 by turning them into local variables as needed. *)
ziv@2265 715 val argsInc = map (incRels 1) args
ziv@2268 716 val check = (check (index, args), loc)
ziv@2268 717 val store = (store (index, argsInc, urlified), loc)
ziv@2265 718 in
ziv@2268 719 SOME ((ECase
ziv@2268 720 (check,
ziv@2268 721 [((PNone stringTyp, loc),
ziv@2268 722 (ELet (varName "q", resultTyp, exp, (ESeq (store, rel0), loc)), loc)),
ziv@2268 723 ((PSome (stringTyp, (PVar (varName "hit", stringTyp), loc)), loc),
ziv@2268 724 (* Boolean is false because we're not unurlifying from a cookie. *)
ziv@2268 725 (EUnurlify (rel0, resultTyp, false), loc))],
ziv@2268 726 {disc = (TOption stringTyp, loc), result = resultTyp})),
ziv@2268 727 (#1 state,
ziv@2268 728 #2 state,
ziv@2268 729 {index = index, params = length args} :: ffiInfo,
ziv@2268 730 index + 1))
ziv@2265 731 end
ziv@2265 732 end
ziv@2265 733
ziv@2267 734 val maxFreeVar =
ziv@2267 735 MonoUtil.Exp.foldB
ziv@2267 736 {typ = #2,
ziv@2267 737 exp = fn (bound, ERel n, v) => Int.max (v, n - bound) | (_, _, v) => v,
ziv@2267 738 bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound}
ziv@2267 739 0
ziv@2267 740 ~1
ziv@2267 741
ziv@2257 742 val freeVars =
ziv@2257 743 IS.listItems
ziv@2257 744 o MonoUtil.Exp.foldB
ziv@2257 745 {typ = #2,
ziv@2257 746 exp = fn (bound, ERel n, vars) => if n < bound
ziv@2257 747 then vars
ziv@2257 748 else IS.add (vars, n - bound)
ziv@2257 749 | (_, _, vars) => vars,
ziv@2257 750 bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound}
ziv@2257 751 0
ziv@2257 752 IS.empty
ziv@2257 753
ziv@2258 754 val expSize = MonoUtil.Exp.fold {typ = #2, exp = fn (_, n) => n+1} 0
ziv@2258 755
ziv@2268 756 type state = (SIMM.multimap
ziv@2268 757 * (Sql.query * int) IntBinaryMap.map
ziv@2268 758 * {index : int, params : int} list
ziv@2268 759 * int)
ziv@2268 760
ziv@2268 761 datatype subexp = Cachable of state -> (exp * state) | Impure of exp
ziv@2250 762
ziv@2250 763 val isImpure =
ziv@2267 764 fn Cachable _ => false
ziv@2250 765 | Impure _ => true
ziv@2250 766
ziv@2268 767 val runSubexp : subexp * state -> exp * state =
ziv@2268 768 fn (Cachable f, state) => f state
ziv@2268 769 | (Impure e, state) => (e, state)
ziv@2250 770
ziv@2259 771 (* TODO: pick a number. *)
ziv@2259 772 val sizeWorthCaching = 5
ziv@2259 773
ziv@2269 774 val worthCaching =
ziv@2269 775 fn EQuery _ => true
ziv@2269 776 | exp' => expSize (exp', dummyLoc) > sizeWorthCaching
ziv@2269 777
ziv@2269 778 fun cachePure (env, exp', state as (_, _, _, index)) =
ziv@2269 779 case (worthCaching exp')
ziv@2269 780 </oguard/>
ziv@2269 781 typOfExp' env exp' of
ziv@2269 782 NONE => NONE
ziv@2269 783 | SOME (TFun _, _) => NONE
ziv@2269 784 | SOME typ =>
ziv@2269 785 (List.foldr (fn (_, NONE) => NONE
ziv@2269 786 | ((n, typ), SOME args) =>
ziv@2269 787 (MonoFooify.urlify env ((ERel n, dummyLoc), typ))
ziv@2269 788 </obind/>
ziv@2269 789 (fn arg => SOME (arg :: args)))
ziv@2269 790 (SOME [])
ziv@2269 791 (map (fn n => (n, #2 (MonoEnv.lookupERel env n)))
ziv@2269 792 (ListMergeSort.sort op> (freeVars (exp', dummyLoc)))))
ziv@2269 793 </obind/>
ziv@2269 794 (fn args => cacheWrap (env, (exp', dummyLoc), typ, args, state))
ziv@2269 795
ziv@2268 796 fun cacheQuery (effs, env, state, q) : (exp' * state) =
ziv@2266 797 let
ziv@2268 798 val (tableToIndices, indexToQueryNumArgs, ffiInfo, index) = state
ziv@2269 799 val {query = queryText, initial, body, ...} = q
ziv@2267 800 val numArgs = maxFreeVar queryText + 1
ziv@2266 801 (* DEBUG *)
ziv@2266 802 (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *)
ziv@2266 803 (* We use dummyTyp here. I think this is okay because databases don't
ziv@2266 804 store (effectful) functions, but perhaps there's some pathalogical
ziv@2266 805 corner case missing.... *)
ziv@2266 806 fun safe bound =
ziv@2266 807 not
ziv@2266 808 o effectful effs
ziv@2266 809 (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE)
ziv@2266 810 bound
ziv@2266 811 env)
ziv@2269 812 val {state = resultTyp, ...} = q
ziv@2269 813 val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc))
ziv@2266 814 val attempt =
ziv@2266 815 (* Ziv misses Haskell's do notation.... *)
ziv@2267 816 (safe 0 queryText andalso safe 0 initial andalso safe 2 body)
ziv@2268 817 </oguard/>
ziv@2268 818 Sql.parse Sql.query queryText
ziv@2268 819 </obind/>
ziv@2268 820 (fn queryParsed =>
ziv@2269 821 (cachePure (env, EQuery q, state))
ziv@2268 822 </obind/>
ziv@2268 823 (fn (cachedExp, state) =>
ziv@2268 824 SOME (cachedExp,
ziv@2268 825 (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index))
ziv@2268 826 tableToIndices
ziv@2268 827 (tablesQuery queryParsed),
ziv@2268 828 IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)),
ziv@2268 829 #3 state,
ziv@2268 830 #4 state))))
ziv@2266 831 in
ziv@2266 832 case attempt of
ziv@2266 833 SOME pair => pair
ziv@2268 834 | NONE => (EQuery q, state)
ziv@2266 835 end
ziv@2266 836
ziv@2268 837 fun cache (effs : IS.set) ((env, exp as (exp', loc)), state) =
ziv@2250 838 let
ziv@2268 839 fun wrapBindN (f : exp list -> exp') (args : (MonoEnv.env * exp) list) =
ziv@2250 840 let
ziv@2266 841 val (subexps, state) = ListUtil.foldlMap (cache effs) state args
ziv@2268 842 fun mkExp state = mapFst (fn exps => (f exps, loc))
ziv@2268 843 (ListUtil.foldlMap runSubexp state subexps)
ziv@2250 844 in
ziv@2250 845 if List.exists isImpure subexps
ziv@2268 846 then mapFst Impure (mkExp state)
ziv@2268 847 else (Cachable (fn state =>
ziv@2268 848 case cachePure (env, f (map #2 args), state) of
ziv@2268 849 NONE => mkExp state
ziv@2268 850 | SOME (e', state) => ((e', loc), state)),
ziv@2268 851 state)
ziv@2250 852 end
ziv@2250 853 fun wrapBind1 f arg =
ziv@2250 854 wrapBindN (fn [arg] => f arg | _ => raise Match) [arg]
ziv@2250 855 fun wrapBind2 f (arg1, arg2) =
ziv@2250 856 wrapBindN (fn [arg1, arg2] => f (arg1, arg2) | _ => raise Match) [arg1, arg2]
ziv@2250 857 fun wrapN f es = wrapBindN f (map (fn e => (env, e)) es)
ziv@2250 858 fun wrap1 f e = wrapBind1 f (env, e)
ziv@2250 859 fun wrap2 f (e1, e2) = wrapBind2 f ((env, e1), (env, e2))
ziv@2250 860 in
ziv@2250 861 case exp' of
ziv@2250 862 ECon (dk, pc, SOME e) => wrap1 (fn e => ECon (dk, pc, SOME e)) e
ziv@2250 863 | ESome (t, e) => wrap1 (fn e => ESome (t, e)) e
ziv@2250 864 | EFfiApp (s1, s2, args) =>
ziv@2258 865 if ffiEffectful (s1, s2)
ziv@2266 866 then (Impure exp, state)
ziv@2258 867 else wrapN (fn es =>
ziv@2258 868 EFfiApp (s1, s2, ListPair.map (fn (e, (_, t)) => (e, t)) (es, args)))
ziv@2258 869 (map #1 args)
ziv@2250 870 | EApp (e1, e2) => wrap2 EApp (e1, e2)
ziv@2250 871 | EAbs (s, t1, t2, e) =>
ziv@2250 872 wrapBind1 (fn e => EAbs (s, t1, t2, e))
ziv@2250 873 (MonoEnv.pushERel env s t1 NONE, e)
ziv@2250 874 | EUnop (s, e) => wrap1 (fn e => EUnop (s, e)) e
ziv@2250 875 | EBinop (bi, s, e1, e2) => wrap2 (fn (e1, e2) => EBinop (bi, s, e1, e2)) (e1, e2)
ziv@2250 876 | ERecord fields =>
ziv@2250 877 wrapN (fn es => ERecord (ListPair.map (fn (e, (s, _, t)) => (s, e, t)) (es, fields)))
ziv@2250 878 (map #2 fields)
ziv@2250 879 | EField (e, s) => wrap1 (fn e => EField (e, s)) e
ziv@2250 880 | ECase (e, cases, {disc, result}) =>
ziv@2250 881 wrapBindN (fn (e::es) =>
ziv@2250 882 ECase (e,
ziv@2250 883 (ListPair.map (fn (e, (p, _)) => (p, e)) (es, cases)),
ziv@2256 884 {disc = disc, result = result})
ziv@2256 885 | _ => raise Match)
ziv@2250 886 ((env, e) :: map (fn (p, e) => (MonoEnv.patBinds env p, e)) cases)
ziv@2250 887 | EStrcat (e1, e2) => wrap2 EStrcat (e1, e2)
ziv@2250 888 (* We record page writes, so they're cachable. *)
ziv@2250 889 | EWrite e => wrap1 EWrite e
ziv@2250 890 | ESeq (e1, e2) => wrap2 ESeq (e1, e2)
ziv@2250 891 | ELet (s, t, e1, e2) =>
ziv@2250 892 wrapBind2 (fn (e1, e2) => ELet (s, t, e1, e2))
ziv@2250 893 ((env, e1), (MonoEnv.pushERel env s t (SOME e1), e2))
ziv@2250 894 (* ASK: | EClosure (n, es) => ? *)
ziv@2250 895 | EUnurlify (e, t, b) => wrap1 (fn e => EUnurlify (e, t, b)) e
ziv@2266 896 | EQuery q =>
ziv@2266 897 let
ziv@2268 898 val (exp', state) = cacheQuery (effs, env, state, q)
ziv@2266 899 in
ziv@2266 900 (Impure (exp', loc), state)
ziv@2266 901 end
ziv@2269 902 | _ => (if effectful effs env exp
ziv@2269 903 then Impure exp
ziv@2269 904 else Cachable (fn state =>
ziv@2268 905 case cachePure (env, exp', state) of
ziv@2269 906 NONE => ((exp', loc), state)
ziv@2269 907 | SOME (exp', state) => ((exp', loc), state)),
ziv@2269 908 state)
ziv@2256 909 end
ziv@2256 910
ziv@2266 911 fun addCaching file =
ziv@2256 912 let
ziv@2266 913 val effs = effectfulDecls file
ziv@2268 914 fun doTopLevelExp env exp state = runSubexp (cache effs ((env, exp), state))
ziv@2256 915 in
ziv@2268 916 ((fileTopLevelMapfoldB doTopLevelExp file (SIMM.empty, IM.empty, [], 0)), effs)
ziv@2265 917 end
ziv@2265 918
ziv@2265 919
ziv@2265 920 (************)
ziv@2265 921 (* Flushing *)
ziv@2265 922 (************)
ziv@2265 923
ziv@2265 924 structure Invalidations = struct
ziv@2265 925
ziv@2265 926 val loc = dummyLoc
ziv@2265 927
ziv@2265 928 val optionAtomExpToExp =
ziv@2265 929 fn NONE => (ENone stringTyp, loc)
ziv@2265 930 | SOME e => (ESome (stringTyp,
ziv@2265 931 (case e of
ziv@2265 932 DmlRel n => ERel n
ziv@2265 933 | Prim p => EPrim p
ziv@2265 934 (* TODO: make new type containing only these two. *)
ziv@2265 935 | _ => raise Match,
ziv@2265 936 loc)),
ziv@2265 937 loc)
ziv@2265 938
ziv@2265 939 fun eqsToInvalidation numArgs eqs =
ziv@2269 940 List.tabulate (numArgs, (fn n => IM.find (eqs, n)))
ziv@2265 941
ziv@2265 942 (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here
ziv@2265 943 represents unknown, which means a wider invalidation. *)
ziv@2265 944 val rec madeRedundantBy : atomExp option list * atomExp option list -> bool =
ziv@2265 945 fn ([], []) => true
ziv@2265 946 | (_ :: xs, NONE :: ys) => madeRedundantBy (xs, ys)
ziv@2265 947 | (SOME x :: xs, SOME y :: ys) => (case AtomExpKey.compare (x, y) of
ziv@2265 948 EQUAL => madeRedundantBy (xs, ys)
ziv@2265 949 | _ => false)
ziv@2265 950 | _ => false
ziv@2265 951
ziv@2265 952 fun eqss (query, dml) = conflictMaps (queryToFormula query, dmlToFormula dml)
ziv@2265 953
ziv@2265 954 fun invalidations ((query, numArgs), dml) =
ziv@2265 955 (map (map optionAtomExpToExp)
ziv@2265 956 o removeRedundant madeRedundantBy
ziv@2265 957 o map (eqsToInvalidation numArgs)
ziv@2265 958 o eqss)
ziv@2265 959 (query, dml)
ziv@2265 960
ziv@2265 961 end
ziv@2265 962
ziv@2265 963 val invalidations = Invalidations.invalidations
ziv@2265 964
ziv@2265 965 (* DEBUG *)
ziv@2265 966 (* val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] *)
ziv@2265 967 (* val gunk' : exp list ref = ref [] *)
ziv@2265 968
ziv@2268 969 fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, ffiInfo, index)), effs) =
ziv@2265 970 let
ziv@2265 971 val flushes = List.concat
ziv@2265 972 o map (fn (i, argss) => map (fn args => flush (i, args)) argss)
ziv@2265 973 val doExp =
ziv@2267 974 fn dmlExp as EDml (dmlText, failureMode) =>
ziv@2265 975 let
ziv@2265 976 (* DEBUG *)
ziv@2265 977 (* val () = gunk' := origDmlText :: !gunk' *)
ziv@2265 978 (* val () = Print.preface ("SQLCACHE: ", (MonoPrint.p_exp MonoEnv.empty origDmlText)) *)
ziv@2265 979 val inval =
ziv@2265 980 case Sql.parse Sql.dml dmlText of
ziv@2265 981 SOME dmlParsed =>
ziv@2265 982 SOME (map (fn i => (case IM.find (indexToQueryNumArgs, i) of
ziv@2265 983 SOME queryNumArgs =>
ziv@2265 984 (* DEBUG *)
ziv@2265 985 ((* gunk := (queryNumArgs, dmlParsed) :: !gunk; *)
ziv@2265 986 (i, invalidations (queryNumArgs, dmlParsed)))
ziv@2265 987 (* TODO: fail more gracefully. *)
ziv@2265 988 | NONE => raise Match))
ziv@2265 989 (SIMM.findList (tableToIndices, tableDml dmlParsed)))
ziv@2265 990 | NONE => NONE
ziv@2265 991 in
ziv@2265 992 case inval of
ziv@2265 993 (* TODO: fail more gracefully. *)
ziv@2265 994 NONE => raise Match
ziv@2267 995 | SOME invs => sequence (flushes invs @ [dmlExp])
ziv@2265 996 end
ziv@2265 997 | e' => e'
ziv@2265 998 in
ziv@2265 999 (* DEBUG *)
ziv@2265 1000 (* gunk := []; *)
ziv@2268 1001 ffiInfoRef := ffiInfo;
ziv@2266 1002 fileMap doExp file
ziv@2265 1003 end
ziv@2265 1004
ziv@2265 1005
ziv@2268 1006 (************************)
ziv@2268 1007 (* Compiler Entry Point *)
ziv@2268 1008 (************************)
ziv@2265 1009
ziv@2265 1010 val inlineSql =
ziv@2265 1011 let
ziv@2265 1012 val doExp =
ziv@2265 1013 (* TODO: EQuery, too? *)
ziv@2265 1014 (* ASK: should this live in [MonoOpt]? *)
ziv@2265 1015 fn EDml ((ECase (disc, cases, {disc = dTyp, ...}), loc), failureMode) =>
ziv@2265 1016 let
ziv@2265 1017 val newCases = map (fn (p, e) => (p, (EDml (e, failureMode), loc))) cases
ziv@2265 1018 in
ziv@2265 1019 ECase (disc, newCases, {disc = dTyp, result = (TRecord [], loc)})
ziv@2265 1020 end
ziv@2265 1021 | e => e
ziv@2265 1022 in
ziv@2265 1023 fileMap doExp
ziv@2265 1024 end
ziv@2265 1025
ziv@2262 1026 fun insertAfterDatatypes ((decls, sideInfo), newDecls) =
ziv@2262 1027 let
ziv@2262 1028 val (datatypes, others) = List.partition (fn (DDatatype _, _) => true | _ => false) decls
ziv@2262 1029 in
ziv@2262 1030 (datatypes @ newDecls @ others, sideInfo)
ziv@2262 1031 end
ziv@2262 1032
ziv@2267 1033 val go' = addFlushing o addCaching o simplifySql o inlineSql
ziv@2256 1034
ziv@2256 1035 fun go file =
ziv@2256 1036 let
ziv@2256 1037 (* TODO: do something nicer than [Sql] being in one of two modes. *)
ziv@2256 1038 val () = (resetFfiInfo (); Sql.sqlcacheMode := true)
ziv@2262 1039 val file = go' file
ziv@2262 1040 (* Important that this happens after [MonoFooify.urlify] calls! *)
ziv@2262 1041 val fmDecls = MonoFooify.getNewFmDecls ()
ziv@2256 1042 val () = Sql.sqlcacheMode := false
ziv@2256 1043 in
ziv@2262 1044 insertAfterDatatypes (file, rev fmDecls)
ziv@2250 1045 end
ziv@2250 1046
ziv@2209 1047 end