Mercurial > urweb

annotate src/sqlcache.sml @ 2295:e6c5bb62fef8

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