Mercurial > urweb

annotate src/sqlcache.sml @ 2215:639e62ca2530

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Mostly finish effectfulness analysis.
author Ziv Scully <ziv@mit.edu>
date Fri, 31 Oct 2014 09:25:03 -0400
parents 365727ff68f4
children 70ec9bb337be
rev   line source
ziv@2213 1 structure Sqlcache (* :> SQLCACHE *) = struct
ziv@2209 2
ziv@2209 3 open Sql
ziv@2209 4 open Mono
ziv@2209 5
ziv@2209 6 structure IS = IntBinarySet
ziv@2209 7 structure IM = IntBinaryMap
ziv@2213 8 structure SK = struct type ord_key = string val compare = String.compare end
ziv@2213 9 structure SS = BinarySetFn(SK)
ziv@2213 10 structure SM = BinaryMapFn(SK)
ziv@2213 11 structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS)
ziv@2209 12
ziv@2213 13 (* Filled in by cacheWrap during Sqlcache. *)
ziv@2213 14 val ffiInfo : {index : int, params : int} list ref = ref []
ziv@2209 15
ziv@2213 16 fun getFfiInfo () = !ffiInfo
ziv@2213 17
ziv@2215 18 (* Some FFIs have writing as their only effect, which the caching records. *)
ziv@2215 19 val ffiEffectful =
ziv@2215 20 let
ziv@2215 21 val fs = SS.fromList ["htmlifyInt_w",
ziv@2215 22 "htmlifyFloat_w",
ziv@2215 23 "htmlifyString_w",
ziv@2215 24 "htmlifyBool_w",
ziv@2215 25 "htmlifyTime_w",
ziv@2215 26 "attrifyInt_w",
ziv@2215 27 "attrifyFloat_w",
ziv@2215 28 "attrifyString_w",
ziv@2215 29 "attrifyChar_w",
ziv@2215 30 "urlifyInt_w",
ziv@2215 31 "urlifyFloat_w",
ziv@2215 32 "urlifyString_w",
ziv@2215 33 "urlifyBool_w",
ziv@2215 34 "urlifyChannel_w"]
ziv@2215 35 in
ziv@2215 36 fn (m, f) => Settings.isEffectful (m, f)
ziv@2215 37 andalso not (m = "Basis" andalso SS.member (fs, f))
ziv@2215 38 end
ziv@2215 39
ziv@2215 40
ziv@2215 41 (* Effect analysis. *)
ziv@2215 42
ziv@2215 43 (* Makes an exception for EWrite (which is recorded when caching). *)
ziv@2215 44 fun effectful doPrint (effs : IS.set) (inFunction : bool) (bound : int) : Mono.exp -> bool =
ziv@2215 45 (* If result is true, expression is definitely effectful. If result is
ziv@2215 46 false, then expression is definitely not effectful if effs is fully
ziv@2215 47 populated. The intended pattern is to use this a number of times equal
ziv@2215 48 to the number of declarations in a file, Bellman-Ford style. *)
ziv@2215 49 (* TODO: make incrementing of bound less janky, probably by using MonoUtil
ziv@2215 50 instead of all this. *)
ziv@2215 51 let
ziv@2215 52 (* DEBUG: remove printing when done. *)
ziv@2215 53 fun tru msg = if doPrint then (print (msg ^ "\n"); true) else true
ziv@2215 54 val rec eff' =
ziv@2215 55 (* ASK: is there a better way? *)
ziv@2215 56 fn EPrim _ => false
ziv@2215 57 (* We don't know if local functions have effects when applied. *)
ziv@2215 58 | ERel idx => if inFunction andalso idx >= bound
ziv@2215 59 then tru ("rel" ^ Int.toString idx) else false
ziv@2215 60 | ENamed name => if IS.member (effs, name) then tru "named" else false
ziv@2215 61 | ECon (_, _, NONE) => false
ziv@2215 62 | ECon (_, _, SOME e) => eff e
ziv@2215 63 | ENone _ => false
ziv@2215 64 | ESome (_, e) => eff e
ziv@2215 65 (* TODO: use FFI whitelist. *)
ziv@2215 66 | EFfi (m, f) => if ffiEffectful (m, f) then tru "ffi" else false
ziv@2215 67 | EFfiApp (m, f, _) => if ffiEffectful (m, f) then tru "ffiapp" else false
ziv@2215 68 (* ASK: we're calling functions effectful if they have effects when
ziv@2215 69 applied or if the function expressions themselves have effects.
ziv@2215 70 Is that okay? *)
ziv@2215 71 (* This is okay because the values we ultimately care about aren't
ziv@2215 72 functions, and this is a conservative approximation, anyway. *)
ziv@2215 73 | EApp (eFun, eArg) => effectful doPrint effs true bound eFun orelse eff eArg
ziv@2215 74 | EAbs (_, _, _, e) => effectful doPrint effs inFunction (bound+1) e
ziv@2215 75 | EUnop (_, e) => eff e
ziv@2215 76 | EBinop (_, _, e1, e2) => eff e1 orelse eff e2
ziv@2215 77 | ERecord xs => List.exists (fn (_, e, _) => eff e) xs
ziv@2215 78 | EField (e, _) => eff e
ziv@2215 79 (* If any case could be effectful, consider it effectful. *)
ziv@2215 80 | ECase (e, xs, _) => eff e orelse List.exists (fn (_, e) => eff e) xs
ziv@2215 81 | EStrcat (e1, e2) => eff e1 orelse eff e2
ziv@2215 82 (* ASK: how should we treat these three? *)
ziv@2215 83 | EError _ => tru "error"
ziv@2215 84 | EReturnBlob _ => tru "blob"
ziv@2215 85 | ERedirect _ => tru "redirect"
ziv@2215 86 (* EWrite is a special exception because we record writes when caching. *)
ziv@2215 87 | EWrite _ => false
ziv@2215 88 | ESeq (e1, e2) => eff e1 orelse eff e2
ziv@2215 89 (* TODO: keep context of which local variables aren't effectful? Only
ziv@2215 90 makes a difference for function expressions, though. *)
ziv@2215 91 | ELet (_, _, eBind, eBody) => eff eBind orelse
ziv@2215 92 effectful doPrint effs inFunction (bound+1) eBody
ziv@2215 93 | EClosure (_, es) => List.exists eff es
ziv@2215 94 (* TODO: deal with EQuery. *)
ziv@2215 95 | EQuery _ => tru "query"
ziv@2215 96 | EDml _ => tru "dml"
ziv@2215 97 | ENextval _ => tru "nextval"
ziv@2215 98 | ESetval _ => tru "setval"
ziv@2215 99 | EUnurlify (e, _, _) => eff e
ziv@2215 100 (* ASK: how should we treat this? *)
ziv@2215 101 | EJavaScript _ => tru "javascript"
ziv@2215 102 (* ASK: these are all effectful, right? *)
ziv@2215 103 | ESignalReturn _ => tru "signalreturn"
ziv@2215 104 | ESignalBind _ => tru "signalbind"
ziv@2215 105 | ESignalSource _ => tru "signalsource"
ziv@2215 106 | EServerCall _ => tru "servercall"
ziv@2215 107 | ERecv _ => tru "recv"
ziv@2215 108 | ESleep _ => tru "sleep"
ziv@2215 109 | ESpawn _ => tru "spawn"
ziv@2215 110 and eff = fn (e', _) => eff' e'
ziv@2215 111 in
ziv@2215 112 eff
ziv@2215 113 end
ziv@2215 114
ziv@2215 115 (* TODO: test this. *)
ziv@2215 116 val effectfulMap =
ziv@2215 117 let
ziv@2215 118 fun doVal ((_, name, _, e, _), effMap) =
ziv@2215 119 if effectful false effMap false 0 e
ziv@2215 120 then IS.add (effMap, name)
ziv@2215 121 else effMap
ziv@2215 122 val doDecl =
ziv@2215 123 fn (DVal v, effMap) => doVal (v, effMap)
ziv@2215 124 (* Repeat the list of declarations a number of times equal to its size. *)
ziv@2215 125 | (DValRec vs, effMap) =>
ziv@2215 126 List.foldl doVal effMap (List.concat (List.map (fn _ => vs) vs))
ziv@2215 127 (* ASK: any other cases? *)
ziv@2215 128 | (_, effMap) => effMap
ziv@2215 129 in
ziv@2215 130 MonoUtil.File.fold {typ = #2, exp = #2, decl = doDecl} IS.empty
ziv@2215 131 end
ziv@2215 132
ziv@2215 133
ziv@2215 134 (* SQL analysis. *)
ziv@2213 135
ziv@2213 136 val useInjIfPossible =
ziv@2215 137 fn SqConst prim => Inj (EPrim (Prim.String (Prim.Normal, Prim.toString prim)),
ziv@2215 138 ErrorMsg.dummySpan)
ziv@2213 139 | sqexp => sqexp
ziv@2213 140
ziv@2213 141 fun equalities (canonicalTable : string -> string) :
ziv@2213 142 sqexp -> ((string * string) * Mono.exp) list option =
ziv@2213 143 let
ziv@2213 144 val rec eqs =
ziv@2213 145 fn Binop (Exps f, e1, e2) =>
ziv@2213 146 (* TODO: use a custom datatype in Exps instead of a function. *)
ziv@2213 147 (case f (Var 1, Var 2) of
ziv@2213 148 Reln (Eq, [Var 1, Var 2]) =>
ziv@2213 149 let
ziv@2213 150 val (e1', e2') = (useInjIfPossible e1, useInjIfPossible e2)
ziv@2213 151 in
ziv@2213 152 case (e1', e2') of
ziv@2213 153 (Field (t, f), Inj i) => SOME [((canonicalTable t, f), i)]
ziv@2213 154 | (Inj i, Field (t, f)) => SOME [((canonicalTable t, f), i)]
ziv@2213 155 | _ => NONE
ziv@2213 156 end
ziv@2213 157 | _ => NONE)
ziv@2213 158 | Binop (Props f, e1, e2) =>
ziv@2213 159 (* TODO: use a custom datatype in Props instead of a function. *)
ziv@2213 160 (case f (True, False) of
ziv@2213 161 And (True, False) =>
ziv@2213 162 (case (eqs e1, eqs e2) of
ziv@2213 163 (SOME eqs1, SOME eqs2) => SOME (eqs1 @ eqs2)
ziv@2213 164 | _ => NONE)
ziv@2213 165 | _ => NONE)
ziv@2213 166 | _ => NONE
ziv@2213 167 in
ziv@2213 168 eqs
ziv@2213 169 end
ziv@2213 170
ziv@2213 171 val equalitiesQuery =
ziv@2213 172 fn Query1 {From = tablePairs, Where = SOME exp, ...} =>
ziv@2213 173 equalities
ziv@2213 174 (* If we have [SELECT ... FROM T AS T' ...], use T, not T'. *)
ziv@2213 175 (fn t =>
ziv@2213 176 case List.find (fn (_, tAs) => t = tAs) tablePairs of
ziv@2213 177 NONE => t
ziv@2213 178 | SOME (tOrig, _) => tOrig)
ziv@2213 179 exp
ziv@2213 180 | Query1 {Where = NONE, ...} => SOME []
ziv@2213 181 | _ => NONE
ziv@2213 182
ziv@2213 183 val equalitiesDml =
ziv@2213 184 fn Insert (tab, eqs) => SOME (List.mapPartial
ziv@2213 185 (fn (name, sqexp) =>
ziv@2213 186 case useInjIfPossible sqexp of
ziv@2213 187 Inj e => SOME ((tab, name), e)
ziv@2213 188 | _ => NONE)
ziv@2213 189 eqs)
ziv@2213 190 | Delete (tab, exp) => equalities (fn _ => tab) exp
ziv@2213 191 (* TODO: examine the updated values and not just the way they're filtered. *)
ziv@2213 192 (* For example, UPDATE foo SET Id = 9001 WHERE Id = 42 should update both the
ziv@2213 193 Id = 42 and Id = 9001 cache entries. Could also think of it as doing a
ziv@2213 194 Delete immediately followed by an Insert. *)
ziv@2213 195 | Update (tab, _, exp) => equalities (fn _ => tab) exp
ziv@2213 196
ziv@2213 197 val rec tablesQuery =
ziv@2213 198 fn Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs)
ziv@2213 199 | Union (q1, q2) => SS.union (tablesQuery q1, tablesQuery q2)
ziv@2213 200
ziv@2213 201 val tableDml =
ziv@2213 202 fn Insert (tab, _) => tab
ziv@2213 203 | Delete (tab, _) => tab
ziv@2213 204 | Update (tab, _, _) => tab
ziv@2213 205
ziv@2213 206
ziv@2213 207 (* Program instrumentation. *)
ziv@2213 208
ziv@2215 209 fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), ErrorMsg.dummySpan)
ziv@2213 210 val stringTyp = (TFfi ("Basis", "string"), ErrorMsg.dummySpan)
ziv@2213 211
ziv@2213 212 val sequence =
ziv@2213 213 fn (exp :: exps) =>
ziv@2213 214 let
ziv@2213 215 val loc = ErrorMsg.dummySpan
ziv@2213 216 in
ziv@2213 217 List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps
ziv@2213 218 end
ziv@2213 219 | _ => raise Match
ziv@2213 220
ziv@2213 221 fun ffiAppCache' (func, index, args) : Mono.exp' =
ziv@2213 222 EFfiApp ("Sqlcache", func ^ Int.toString index, args)
ziv@2213 223
ziv@2215 224 fun ffiAppCache (func, index, args) : Mono.exp =
ziv@2213 225 (ffiAppCache' (func, index, args), ErrorMsg.dummySpan)
ziv@2213 226
ziv@2213 227 val varPrefix = "queryResult"
ziv@2213 228
ziv@2213 229 fun indexOfName varName =
ziv@2213 230 if String.isPrefix varPrefix varName
ziv@2213 231 then Int.fromString (String.extract (varName, String.size varPrefix, NONE))
ziv@2213 232 else NONE
ziv@2213 233
ziv@2215 234 (* Always increments negative indices because that's what we need later. *)
ziv@2215 235 fun incRelsBound bound inc =
ziv@2215 236 MonoUtil.Exp.mapB
ziv@2215 237 {typ = fn x => x,
ziv@2215 238 exp = fn level =>
ziv@2215 239 (fn ERel n => ERel (if n >= level orelse n < 0 then n + inc else n)
ziv@2215 240 | x => x),
ziv@2215 241 bind = fn (level, MonoUtil.Exp.RelE _) => level + 1 | (level, _) => level}
ziv@2215 242 bound
ziv@2215 243
ziv@2215 244 val incRels = incRelsBound 0
ziv@2213 245
ziv@2213 246 (* Filled in by instrumentQuery during Monoize, used during Sqlcache. *)
ziv@2213 247 val urlifiedRel0s : Mono.exp IM.map ref = ref IM.empty
ziv@2213 248
ziv@2213 249 (* Used by Monoize. *)
ziv@2213 250 val instrumentQuery =
ziv@2213 251 let
ziv@2213 252 val nextQuery = ref 0
ziv@2213 253 fun iq (query, urlifiedRel0) =
ziv@2213 254 case query of
ziv@2213 255 (EQuery {state = typ, ...}, loc) =>
ziv@2213 256 let
ziv@2213 257 val i = !nextQuery before nextQuery := !nextQuery + 1
ziv@2213 258 in
ziv@2213 259 urlifiedRel0s := IM.insert (!urlifiedRel0s, i, urlifiedRel0);
ziv@2213 260 (ELet (varPrefix ^ Int.toString i, typ, query,
ziv@2213 261 (* Uses a dummy FFI call to keep the urlified expression around, which
ziv@2213 262 in turn keeps the declarations required for urlification safe from
ziv@2213 263 MonoShake. The dummy call is removed during Sqlcache. *)
ziv@2215 264 (* TODO: thread a Monoize.Fm.t through this module. *)
ziv@2213 265 (ESeq ((EFfiApp ("Sqlcache", "dummy", [(urlifiedRel0, stringTyp)]), loc),
ziv@2213 266 (ERel 0, loc)),
ziv@2213 267 loc)),
ziv@2213 268 loc)
ziv@2213 269 end
ziv@2213 270 | _ => raise Match
ziv@2213 271 in
ziv@2213 272 iq
ziv@2213 273 end
ziv@2213 274
ziv@2213 275 fun cacheWrap (query, i, urlifiedRel0, eqs) =
ziv@2213 276 case query of
ziv@2213 277 (EQuery {state = typ, ...}, _) =>
ziv@2213 278 let
ziv@2215 279 val () = ffiInfo := {index = i, params = length eqs} :: !ffiInfo
ziv@2213 280 val loc = ErrorMsg.dummySpan
ziv@2215 281 (* We ensure before this step that all arguments aren't effectful.
ziv@2215 282 by turning them into local variables as needed. *)
ziv@2215 283 val args = map (fn (_, e) => (e, stringTyp)) eqs
ziv@2215 284 val argsInc = map (fn (e, typ) => (incRels 1 e, typ)) args
ziv@2215 285 val check = ffiAppCache ("check", i, args)
ziv@2215 286 val store = ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argsInc)
ziv@2215 287 val rel0 = (ERel 0, loc)
ziv@2213 288 in
ziv@2215 289 (ECase (check,
ziv@2213 290 [((PNone stringTyp, loc),
ziv@2215 291 (ELet ("q", typ, query, (ESeq (store, rel0), loc)), loc)),
ziv@2213 292 ((PSome (stringTyp, (PVar ("hit", stringTyp), loc)), loc),
ziv@2215 293 (* Boolean is false because we're not unurlifying from a cookie. *)
ziv@2215 294 (EUnurlify (rel0, typ, false), loc))],
ziv@2213 295 {disc = stringTyp, result = typ}),
ziv@2213 296 loc)
ziv@2213 297 end
ziv@2213 298 | _ => raise Match
ziv@2213 299
ziv@2213 300 fun fileMapfold doExp file start =
ziv@2213 301 case MonoUtil.File.mapfold {typ = Search.return2,
ziv@2213 302 exp = fn x => (fn s => Search.Continue (doExp x s)),
ziv@2213 303 decl = Search.return2} file start of
ziv@2213 304 Search.Continue x => x
ziv@2213 305 | Search.Return _ => raise Match
ziv@2213 306
ziv@2213 307 fun fileMap doExp file = #1 (fileMapfold (fn x => fn _ => (doExp x, ())) file ())
ziv@2213 308
ziv@2215 309 fun addChecking file =
ziv@2213 310 let
ziv@2213 311 fun doExp queryInfo =
ziv@2215 312 fn e' as ELet (v, t,
ziv@2215 313 queryExp' as (EQuery {query = origQueryText,
ziv@2215 314 initial, body, state, tables, exps}, queryLoc),
ziv@2215 315 letBody) =>
ziv@2213 316 let
ziv@2215 317 val loc = ErrorMsg.dummySpan
ziv@2215 318 val chunks = chunkify origQueryText
ziv@2215 319 fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
ziv@2215 320 val (newQueryText, newVariables) =
ziv@2215 321 (* Important that this is foldr (to oppose foldl below). *)
ziv@2215 322 List.foldr
ziv@2215 323 (fn (chunk, (qText, newVars)) =>
ziv@2215 324 case chunk of
ziv@2215 325 Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars)
ziv@2215 326 | Exp (e as (ERel _, _)) => (strcat (e, qText), newVars)
ziv@2215 327 | Exp (e as (ENamed _, _)) => (strcat (e, qText), newVars)
ziv@2215 328 (* Head of newVars has lowest index. *)
ziv@2215 329 | Exp e =>
ziv@2215 330 let
ziv@2215 331 val n = length newVars
ziv@2215 332 in
ziv@2215 333 (* This is the (n + 1)th new variable, so
ziv@2215 334 there are already n new variables bound,
ziv@2215 335 so we increment indices by n. *)
ziv@2215 336 (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars)
ziv@2215 337 end
ziv@2215 338 | String s => (strcat (stringExp s, qText), newVars))
ziv@2215 339 (stringExp "", [])
ziv@2215 340 chunks
ziv@2215 341 fun wrapLets e' =
ziv@2215 342 (* Important that this is foldl (to oppose foldr above). *)
ziv@2215 343 List.foldl (fn (v, e') => ELet ("sqlArgz", stringTyp, v, (e', loc))) e' newVariables
ziv@2215 344 (* Increment once for each new variable just made. *)
ziv@2215 345 val queryExp = incRels (length newVariables)
ziv@2215 346 (EQuery {query = newQueryText,
ziv@2215 347 initial = initial,
ziv@2215 348 body = body,
ziv@2215 349 state = state,
ziv@2215 350 tables = tables,
ziv@2215 351 exps = exps},
ziv@2215 352 queryLoc)
ziv@2215 353 val (EQuery {query = queryText, ...}, _) = queryExp
ziv@2215 354 (* val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText)); *)
ziv@2213 355 fun bind x f = Option.mapPartial f x
ziv@2215 356 fun guard b x = if b then x else NONE
ziv@2215 357 (* DEBUG: set first boolean argument to true to turn on printing. *)
ziv@2215 358 fun safe bound = not o effectful true (effectfulMap file) false bound
ziv@2213 359 val attempt =
ziv@2213 360 (* Ziv misses Haskell's do notation.... *)
ziv@2215 361 guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) (
ziv@2213 362 bind (parse query queryText) (fn queryParsed =>
ziv@2213 363 bind (indexOfName v) (fn i =>
ziv@2213 364 bind (equalitiesQuery queryParsed) (fn eqs =>
ziv@2213 365 bind (IM.find (!urlifiedRel0s, i)) (fn urlifiedRel0 =>
ziv@2215 366 SOME (wrapLets (ELet (v, t,
ziv@2215 367 cacheWrap (queryExp, i, urlifiedRel0, eqs),
ziv@2215 368 incRelsBound 1 (length newVariables) letBody)),
ziv@2213 369 SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, i))
ziv@2213 370 queryInfo
ziv@2213 371 (tablesQuery queryParsed)))))))
ziv@2213 372 in
ziv@2213 373 case attempt of
ziv@2213 374 SOME pair => pair
ziv@2213 375 | NONE => (e', queryInfo)
ziv@2213 376 end
ziv@2213 377 | ESeq ((EFfiApp ("Sqlcache", "dummy", _), _), (e', _)) => (e', queryInfo)
ziv@2213 378 | e' => (e', queryInfo)
ziv@2213 379 in
ziv@2215 380 fileMapfold (fn exp => fn state => doExp state exp) file SIMM.empty
ziv@2213 381 end
ziv@2213 382
ziv@2213 383 fun addFlushing (file, queryInfo) =
ziv@2213 384 let
ziv@2213 385 val allIndices : int list = SM.foldr (fn (x, acc) => IS.listItems x @ acc) [] queryInfo
ziv@2213 386 fun flushes indices = map (fn i => ffiAppCache' ("flush", i, [])) indices
ziv@2213 387 val doExp =
ziv@2213 388 fn dmlExp as EDml (dmlText, _) =>
ziv@2213 389 let
ziv@2213 390 val indices =
ziv@2213 391 case parse dml dmlText of
ziv@2213 392 SOME dmlParsed => SIMM.findList (queryInfo, tableDml dmlParsed)
ziv@2213 393 | NONE => allIndices
ziv@2213 394 in
ziv@2213 395 sequence (flushes indices @ [dmlExp])
ziv@2213 396 end
ziv@2213 397 | e' => e'
ziv@2213 398 in
ziv@2213 399 fileMap doExp file
ziv@2213 400 end
ziv@2213 401
ziv@2213 402 fun go file =
ziv@2213 403 let
ziv@2213 404 val () = Sql.sqlcacheMode := true
ziv@2215 405 val file' = addFlushing (addChecking file)
ziv@2215 406 val () = Sql.sqlcacheMode := false
ziv@2213 407 in
ziv@2215 408 file'
ziv@2213 409 end
ziv@2213 410
ziv@2213 411
ziv@2213 412 (* BEGIN OLD
ziv@2212 413
ziv@2212 414 fun intExp (n, loc) = (EPrim (Prim.Int (Int64.fromInt n)), loc)
ziv@2212 415 fun intTyp loc = (TFfi ("Basis", "int"), loc)
ziv@2213 416 fun stringExp (s, loc) = (EPrim (Prim.String (Prim.Normal, s)), loc)
ziv@2213 417
ziv@2212 418 fun boolPat (b, loc) = (PCon (Enum,
ziv@2212 419 PConFfi {mod = "Basis", datatyp = "bool", arg = NONE,
ziv@2212 420 con = if b then "True" else "False"},
ziv@2212 421 NONE),
ziv@2212 422 loc)
ziv@2212 423 fun boolTyp loc = (TFfi ("Basis", "int"), loc)
ziv@2212 424
ziv@2213 425 fun ffiAppExp (module, func, index, args, loc) =
ziv@2213 426 (EFfiApp (module, func ^ Int.toString index, args), loc)
ziv@2212 427
ziv@2213 428 val sequence =
ziv@2213 429 fn ((exp :: exps), loc) =>
ziv@2212 430 List.foldl (fn (exp, seq) => (ESeq (seq, exp), loc)) exp exps
ziv@2213 431 | _ => raise Match
ziv@2212 432
ziv@2212 433 fun antiguardUnit (cond, exp, loc) =
ziv@2212 434 (ECase (cond,
ziv@2212 435 [(boolPat (false, loc), exp),
ziv@2212 436 (boolPat (true, loc), (ERecord [], loc))],
ziv@2212 437 {disc = boolTyp loc, result = (TRecord [], loc)}),
ziv@2212 438 loc)
ziv@2212 439
ziv@2212 440 fun underAbs f (exp as (exp', loc)) =
ziv@2212 441 case exp' of
ziv@2212 442 EAbs (x, y, z, body) => (EAbs (x, y, z, underAbs f body), loc)
ziv@2212 443 | _ => f exp
ziv@2212 444
ziv@2212 445
ziv@2209 446 val rec tablesRead =
ziv@2213 447 fn Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs)
ziv@2213 448 | Union (q1, q2) => SS.union (tablesRead q1, tablesRead q2)
ziv@2209 449
ziv@2209 450 val tableWritten =
ziv@2209 451 fn Insert (tab, _) => tab
ziv@2209 452 | Delete (tab, _) => tab
ziv@2209 453 | Update (tab, _, _) => tab
ziv@2209 454
ziv@2209 455 fun tablesInExp' exp' =
ziv@2209 456 let
ziv@2209 457 val nothing = {read = SS.empty, written = SS.empty}
ziv@2209 458 in
ziv@2209 459 case exp' of
ziv@2213 460 EQuery {query = e, ...} =>
ziv@2209 461 (case parse query e of
ziv@2209 462 SOME q => {read = tablesRead q, written = SS.empty}
ziv@2209 463 | NONE => nothing)
ziv@2209 464 | EDml (e, _) =>
ziv@2209 465 (case parse dml e of
ziv@2209 466 SOME q => {read = SS.empty, written = SS.singleton (tableWritten q)}
ziv@2209 467 | NONE => nothing)
ziv@2209 468 | _ => nothing
ziv@2209 469 end
ziv@2209 470
ziv@2209 471 val tablesInExp =
ziv@2209 472 let
ziv@2209 473 fun addTables (exp', {read, written}) =
ziv@2213 474 let
ziv@2213 475 val {read = r, written = w} = tablesInExp' exp'
ziv@2213 476 in
ziv@2213 477 {read = SS.union (r, read), written = SS.union (w, written)}
ziv@2213 478 end
ziv@2209 479 in
ziv@2209 480 MonoUtil.Exp.fold {typ = #2, exp = addTables}
ziv@2209 481 {read = SS.empty, written = SS.empty}
ziv@2209 482 end
ziv@2209 483
ziv@2209 484 fun addCacheCheck (index, exp) =
ziv@2209 485 let
ziv@2209 486 fun f (body as (_, loc)) =
ziv@2209 487 let
ziv@2209 488 val check = ffiAppExp ("Cache", "check", index, loc)
ziv@2209 489 val store = ffiAppExp ("Cache", "store", index, loc)
ziv@2209 490 in
ziv@2212 491 antiguardUnit (check, sequence ([body, store], loc), loc)
ziv@2209 492 end
ziv@2209 493 in
ziv@2209 494 underAbs f exp
ziv@2209 495 end
ziv@2209 496
ziv@2209 497 fun addCacheFlush (exp, tablesToIndices) =
ziv@2209 498 let
ziv@2209 499 fun addIndices (table, indices) = IS.union (indices, SIMM.find (tablesToIndices, table))
ziv@2209 500 fun f (body as (_, loc)) =
ziv@2209 501 let
ziv@2209 502 fun mapFfi func = List.map (fn i => ffiAppExp ("Cache", func, i, loc))
ziv@2209 503 val flushes =
ziv@2209 504 IS.listItems (SS.foldr addIndices IS.empty (#written (tablesInExp body)))
ziv@2209 505 in
ziv@2212 506 sequence (mapFfi "flush" flushes @ [body] @ mapFfi "ready" flushes, loc)
ziv@2209 507 end
ziv@2209 508 in
ziv@2209 509 underAbs f exp
ziv@2209 510 end
ziv@2209 511
ziv@2209 512 val handlerIndices =
ziv@2209 513 let
ziv@2209 514 val isUnit =
ziv@2209 515 fn (TRecord [], _) => true
ziv@2209 516 | _ => false
ziv@2209 517 fun maybeAdd (d, soFar as {readers, writers}) =
ziv@2209 518 case d of
ziv@2209 519 DExport (Link ReadOnly, _, name, typs, typ, _) =>
ziv@2209 520 if List.all isUnit (typ::typs)
ziv@2209 521 then {readers = IS.add (readers, name), writers = writers}
ziv@2209 522 else soFar
ziv@2209 523 | DExport (_, _, name, _, _, _) => (* Not read only. *)
ziv@2209 524 {readers = readers, writers = IS.add (writers, name)}
ziv@2209 525 | _ => soFar
ziv@2209 526 in
ziv@2209 527 MonoUtil.File.fold {typ = #2, exp = #2, decl = maybeAdd}
ziv@2209 528 {readers = IS.empty, writers = IS.empty}
ziv@2209 529 end
ziv@2209 530
ziv@2209 531 fun fileFoldMapiSelected f init (file, indices) =
ziv@2209 532 let
ziv@2209 533 fun doExp (original as ((a, index, b, exp, c), state)) =
ziv@2209 534 if IS.member (indices, index)
ziv@2209 535 then let val (newExp, newState) = f (index, exp, state)
ziv@2209 536 in ((a, index, b, newExp, c), newState) end
ziv@2209 537 else original
ziv@2209 538 fun doDecl decl state =
ziv@2209 539 let
ziv@2209 540 val result =
ziv@2209 541 case decl of
ziv@2209 542 DVal x =>
ziv@2209 543 let val (y, newState) = doExp (x, state)
ziv@2209 544 in (DVal y, newState) end
ziv@2209 545 | DValRec xs =>
ziv@2209 546 let val (ys, newState) = ListUtil.foldlMap doExp state xs
ziv@2209 547 in (DValRec ys, newState) end
ziv@2209 548 | _ => (decl, state)
ziv@2209 549 in
ziv@2209 550 Search.Continue result
ziv@2209 551 end
ziv@2209 552 fun nada x y = Search.Continue (x, y)
ziv@2209 553 in
ziv@2209 554 case MonoUtil.File.mapfold {typ = nada, exp = nada, decl = doDecl} file init of
ziv@2209 555 Search.Continue x => x
ziv@2213 556 | _ => raise Match (* Should never happen. *)
ziv@2209 557 end
ziv@2209 558
ziv@2209 559 fun fileMapSelected f = #1 o fileFoldMapiSelected (fn (_, x, _) => (f x, ())) ()
ziv@2209 560
ziv@2209 561 val addCacheChecking =
ziv@2209 562 let
ziv@2209 563 fun f (index, exp, tablesToIndices) =
ziv@2209 564 (addCacheCheck (index, exp),
ziv@2209 565 SS.foldr (fn (table, tsToIs) => SIMM.insert (tsToIs, table, index))
ziv@2209 566 tablesToIndices
ziv@2209 567 (#read (tablesInExp exp)))
ziv@2209 568 in
ziv@2209 569 fileFoldMapiSelected f (SM.empty)
ziv@2209 570 end
ziv@2209 571
ziv@2209 572 fun addCacheFlushing (file, tablesToIndices, writers) =
ziv@2209 573 fileMapSelected (fn exp => addCacheFlush (exp, tablesToIndices)) (file, writers)
ziv@2209 574
ziv@2209 575 fun go file =
ziv@2209 576 let
ziv@2209 577 val {readers, writers} = handlerIndices file
ziv@2209 578 val (fileWithChecks, tablesToIndices) = addCacheChecking (file, readers)
ziv@2209 579 in
ziv@2209 580 ffiIndices := IS.listItems readers;
ziv@2209 581 addCacheFlushing (fileWithChecks, tablesToIndices, writers)
ziv@2209 582 end
ziv@2209 583
ziv@2213 584 END OLD *)
ziv@2213 585
ziv@2209 586 end