Mercurial > urweb

annotate src/sqlcache.sml @ 2262:34ad83d9b729

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