Mercurial > urweb

annotate src/sqlcache.sml @ 2258:b1ba35ce2613

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