summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Ziv Scully <ziv@mit.edu>2015-10-14 00:07:00 -0400
committerGravatar Ziv Scully <ziv@mit.edu>2015-10-14 00:07:00 -0400
commite86ed0717e35bea1ad6127d193e5979aec4841b9 (patch)
tree4cad5b76d4d1e760994253144d13e4c3e4a5bd8e /src
parent51117ba9333e00cdd8c4c31307effbe93601d328 (diff)
Hard-code Sqlcache module (in Ur/Web) as effectful and reorder sqlcache.sml.
Diffstat (limited to 'src')
-rw-r--r--src/lru_cache.sml8
-rw-r--r--src/mono_fooify.sml2
-rw-r--r--src/settings.sml3
-rw-r--r--src/sqlcache.sml478
-rw-r--r--src/toy_cache.sml8
5 files changed, 250 insertions, 249 deletions
diff --git a/src/lru_cache.sml b/src/lru_cache.sml
index 275c3061..e69624d8 100644
--- a/src/lru_cache.sml
+++ b/src/lru_cache.sml
@@ -13,13 +13,7 @@ val optionStringTyp = (TOption stringTyp, dummyLoc)
fun withTyp typ = map (fn exp => (exp, typ))
fun ffiAppCache' (func, index, argTyps) =
- let
- val m = "Sqlcache"
- val f = func ^ Int.toString index
- in
- Settings.addEffectful (m, f);
- EFfiApp (m, f, argTyps)
- end
+ EFfiApp ("Sqlcache", func ^ Int.toString index, argTyps)
fun check (index, keys) =
ffiAppCache' ("check", index, withTyp stringTyp keys)
diff --git a/src/mono_fooify.sml b/src/mono_fooify.sml
index bbd34b15..e64207cd 100644
--- a/src/mono_fooify.sml
+++ b/src/mono_fooify.sml
@@ -167,7 +167,6 @@ fun fooifyExpWithExceptions fk lookupENamed lookupDatatype =
case t of
TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm)
| TFfi (m, x) => (if Settings.mayClientToServer (m, x)
- (* TODO: better error message. (Then again, user should never see this.) *)
then ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm)
else raise CantPass (fm, tAll))
@@ -311,7 +310,6 @@ fun fooifyExp fk lookupENamed lookupDatatype fm exp =
Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty typ)];
(dummyExp, fm))
-
(* Has to be set at the end of [Monoize]. *)
val canonicalFm = ref (Fm.empty 0 : Fm.t)
diff --git a/src/settings.sml b/src/settings.sml
index ff99bf13..ecf353cd 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -151,7 +151,8 @@ val effectfulBase = basis ["dml",
val effectful = ref effectfulBase
fun setEffectful ls = effectful := S.addList (effectfulBase, ls)
-fun isEffectful x = S.member (!effectful, x)
+fun isEffectful ("Sqlcache", _) = true
+ | isEffectful x = S.member (!effectful, x)
fun addEffectful x = effectful := S.add (!effectful, x)
val benignBase = basis ["get_cookie",
diff --git a/src/sqlcache.sml b/src/sqlcache.sml
index f3db5795..1a4d4e97 100644
--- a/src/sqlcache.sml
+++ b/src/sqlcache.sml
@@ -15,7 +15,7 @@ fun iterate f n x = if n < 0
then x
else iterate f (n-1) (f x)
-(* Filled in by [cacheWrap] during [Sqlcache]. *)
+(* Filled in by [cacheWrap]. *)
val ffiInfo : {index : int, params : int} list ref = ref []
fun resetFfiInfo () = ffiInfo := []
@@ -41,8 +41,7 @@ val ffiEffectful =
"urlifyBool_w",
"urlifyChannel_w"]
in
- (* ASK: nicer way than using [Settings.addEffectful] for each Sqlcache
- function? Right now they're all always effectful. *)
+ (* ASK: is it okay to hardcode Sqlcache functions as effectful? *)
fn (m, f) => Settings.isEffectful (m, f)
andalso not (m = "Basis" andalso SS.member (okayWrites, f))
end
@@ -456,9 +455,9 @@ val tableDml =
| Sql.Update (tab, _, _) => tab
-(***************************)
-(* Program Instrumentation *)
-(***************************)
+(*************************************)
+(* Program Instrumentation Utilities *)
+(*************************************)
val varName =
let
@@ -496,33 +495,6 @@ fun incRels inc =
bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound}
0
-fun cacheWrap (env, exp, resultTyp, args, i) =
- let
- val loc = dummyLoc
- val rel0 = (ERel 0, loc)
- in
- case MonoFooify.urlify env (rel0, resultTyp) of
- NONE => NONE
- | SOME urlified =>
- let
- val () = ffiInfo := {index = i, params = length args} :: !ffiInfo
- (* We ensure before this step that all arguments aren't effectful.
- by turning them into local variables as needed. *)
- val argsInc = map (incRels 1) args
- val check = (check (i, args), loc)
- val store = (store (i, argsInc, urlified), loc)
- in
- SOME (ECase
- (check,
- [((PNone stringTyp, loc),
- (ELet (varName "q", resultTyp, exp, (ESeq (store, rel0), loc)), loc)),
- ((PSome (stringTyp, (PVar (varName "hit", stringTyp), loc)), loc),
- (* Boolean is false because we're not unurlifying from a cookie. *)
- (EUnurlify (rel0, resultTyp, false), loc))],
- {disc = (TOption stringTyp, loc), result = resultTyp}))
- end
- end
-
fun fileTopLevelMapfoldB doTopLevelExp (decls, sideInfo) state =
let
fun doVal env ((x, n, t, exp, s), state) =
@@ -570,205 +542,6 @@ fun fileAllMapfoldB doExp file start =
fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ())
-fun factorOutNontrivial text =
- let
- val loc = dummyLoc
- fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
- val chunks = Sql.chunkify text
- val (newText, newVariables) =
- (* Important that this is foldr (to oppose foldl below). *)
- List.foldr
- (fn (chunk, (qText, newVars)) =>
- (* Variable bound to the head of newBs will have the lowest index. *)
- case chunk of
- Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars)
- | Sql.Exp e =>
- let
- val n = length newVars
- in
- (* This is the (n+1)th new variable, so there are
- already n new variables bound, so we increment
- indices by n. *)
- (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars)
- end
- | Sql.String s => (strcat (stringExp s, qText), newVars))
- (stringExp "", [])
- chunks
- fun wrapLets e' =
- (* Important that this is foldl (to oppose foldr above). *)
- List.foldl (fn (v, e') => ELet (varName "sqlArg", stringTyp, v, (e', loc)))
- e'
- newVariables
- val numArgs = length newVariables
- in
- (newText, wrapLets, numArgs)
- end
-
-fun cacheQuery effs env (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) =
- fn e' as EQuery {query = origQueryText,
- state = resultTyp,
- initial, body, tables, exps} =>
- let
- val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText
- (* Increment once for each new variable just made. *)
- val queryExp = incRels numArgs
- (EQuery {query = newQueryText,
- state = resultTyp,
- initial = initial,
- body = body,
- tables = tables,
- exps = exps},
- dummyLoc)
- (* DEBUG *)
- (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *)
- val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc))
- fun bind x f = Option.mapPartial f x
- fun guard b x = if b then x else NONE
- (* We use dummyTyp here. I think this is okay because databases don't
- store (effectful) functions, but perhaps there's some pathalogical
- corner case missing.... *)
- fun safe bound =
- not
- o effectful effs
- (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE)
- bound
- env)
- val textOfQuery = fn (EQuery {query, ...}, _) => SOME query | _ => NONE
- val attempt =
- (* Ziv misses Haskell's do notation.... *)
- bind (textOfQuery queryExp) (fn queryText =>
- guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) (
- bind (Sql.parse Sql.query queryText) (fn queryParsed =>
- bind (cacheWrap (env, queryExp, resultTyp, args, index)) (fn cachedExp =>
- SOME (wrapLets cachedExp,
- (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index))
- tableToIndices
- (tablesQuery queryParsed),
- IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)),
- index + 1))))))
- in
- case attempt of
- SOME pair => pair
- (* We have to increment index conservatively. *)
- (* TODO: just use a reference for current index.... *)
- | NONE => (e', (tableToIndices, indexToQueryNumArgs, index + 1))
- end
- | e' => (e', queryInfo)
-
-fun addChecking file =
- let
- val effs = effectfulDecls file
- in
- (fileAllMapfoldB (fn env => fn exp => fn state => cacheQuery effs env state exp)
- file
- (SIMM.empty, IM.empty, 0),
- effs)
- end
-
-structure Invalidations = struct
-
- val loc = dummyLoc
-
- val optionAtomExpToExp =
- fn NONE => (ENone stringTyp, loc)
- | SOME e => (ESome (stringTyp,
- (case e of
- DmlRel n => ERel n
- | Prim p => EPrim p
- (* TODO: make new type containing only these two. *)
- | _ => raise Match,
- loc)),
- loc)
-
- fun eqsToInvalidation numArgs eqs =
- let
- fun inv n = if n < 0 then [] else IM.find (eqs, n) :: inv (n - 1)
- in
- inv (numArgs - 1)
- end
-
- (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here
- represents unknown, which means a wider invalidation. *)
- val rec madeRedundantBy : atomExp option list * atomExp option list -> bool =
- fn ([], []) => true
- | (_ :: xs, NONE :: ys) => madeRedundantBy (xs, ys)
- | (SOME x :: xs, SOME y :: ys) => (case AtomExpKey.compare (x, y) of
- EQUAL => madeRedundantBy (xs, ys)
- | _ => false)
- | _ => false
-
- fun eqss (query, dml) = conflictMaps (queryToFormula query, dmlToFormula dml)
-
- fun invalidations ((query, numArgs), dml) =
- (map (map optionAtomExpToExp)
- o removeRedundant madeRedundantBy
- o map (eqsToInvalidation numArgs)
- o eqss)
- (query, dml)
-
-end
-
-val invalidations = Invalidations.invalidations
-
-(* DEBUG *)
-(* val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] *)
-(* val gunk' : exp list ref = ref [] *)
-
-fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) =
- let
- val flushes = List.concat
- o map (fn (i, argss) => map (fn args => flush (i, args)) argss)
- val doExp =
- fn EDml (origDmlText, failureMode) =>
- let
- (* DEBUG *)
- (* val () = gunk' := origDmlText :: !gunk' *)
- val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText
- val dmlText = incRels numArgs newDmlText
- val dmlExp = EDml (dmlText, failureMode)
- (* DEBUG *)
- val () = Print.preface ("SQLCACHE: ", (MonoPrint.p_exp MonoEnv.empty origDmlText))
- val inval =
- case Sql.parse Sql.dml dmlText of
- SOME dmlParsed =>
- SOME (map (fn i => (case IM.find (indexToQueryNumArgs, i) of
- SOME queryNumArgs =>
- (* DEBUG *)
- ((* gunk := (queryNumArgs, dmlParsed) :: !gunk; *)
- (i, invalidations (queryNumArgs, dmlParsed)))
- (* TODO: fail more gracefully. *)
- | NONE => raise Match))
- (SIMM.findList (tableToIndices, tableDml dmlParsed)))
- | NONE => NONE
- in
- case inval of
- (* TODO: fail more gracefully. *)
- NONE => raise Match
- | SOME invs => wrapLets (sequence (flushes invs @ [dmlExp]))
- end
- | e' => e'
- in
- (* DEBUG *)
- (* gunk := []; *)
- (fileMap doExp file, index, effs)
- end
-
-val inlineSql =
- let
- val doExp =
- (* TODO: EQuery, too? *)
- (* ASK: should this live in [MonoOpt]? *)
- fn EDml ((ECase (disc, cases, {disc = dTyp, ...}), loc), failureMode) =>
- let
- val newCases = map (fn (p, e) => (p, (EDml (e, failureMode), loc))) cases
- in
- ECase (disc, newCases, {disc = dTyp, result = (TRecord [], loc)})
- end
- | e => e
- in
- fileMap doExp
- end
-
(**********************)
(* Mono Type Checking *)
@@ -830,6 +603,33 @@ and typOfExp env (e', loc) = typOfExp' env e'
(* Caching Pure Subexpressions *)
(*******************************)
+fun cacheWrap (env, exp, resultTyp, args, i) =
+ let
+ val loc = dummyLoc
+ val rel0 = (ERel 0, loc)
+ in
+ case MonoFooify.urlify env (rel0, resultTyp) of
+ NONE => NONE
+ | SOME urlified =>
+ let
+ val () = ffiInfo := {index = i, params = length args} :: !ffiInfo
+ (* We ensure before this step that all arguments aren't effectful.
+ by turning them into local variables as needed. *)
+ val argsInc = map (incRels 1) args
+ val check = (check (i, args), loc)
+ val store = (store (i, argsInc, urlified), loc)
+ in
+ SOME (ECase
+ (check,
+ [((PNone stringTyp, loc),
+ (ELet (varName "q", resultTyp, exp, (ESeq (store, rel0), loc)), loc)),
+ ((PSome (stringTyp, (PVar (varName "hit", stringTyp), loc)), loc),
+ (* Boolean is false because we're not unurlifying from a cookie. *)
+ (EUnurlify (rel0, resultTyp, false), loc))],
+ {disc = (TOption stringTyp, loc), result = resultTyp}))
+ end
+ end
+
val freeVars =
IS.listItems
o MonoUtil.Exp.foldB
@@ -1005,6 +805,220 @@ fun addPure (file, indexStart, effs) =
#1 (fileTopLevelMapfoldB doTopLevelExp file indexStart)
end
+
+(***********************)
+(* Caching SQL Queries *)
+(***********************)
+
+fun factorOutNontrivial text =
+ let
+ val loc = dummyLoc
+ fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
+ val chunks = Sql.chunkify text
+ val (newText, newVariables) =
+ (* Important that this is foldr (to oppose foldl below). *)
+ List.foldr
+ (fn (chunk, (qText, newVars)) =>
+ (* Variable bound to the head of newBs will have the lowest index. *)
+ case chunk of
+ Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars)
+ | Sql.Exp e =>
+ let
+ val n = length newVars
+ in
+ (* This is the (n+1)th new variable, so there are
+ already n new variables bound, so we increment
+ indices by n. *)
+ (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars)
+ end
+ | Sql.String s => (strcat (stringExp s, qText), newVars))
+ (stringExp "", [])
+ chunks
+ fun wrapLets e' =
+ (* Important that this is foldl (to oppose foldr above). *)
+ List.foldl (fn (v, e') => ELet (varName "sqlArg", stringTyp, v, (e', loc)))
+ e'
+ newVariables
+ val numArgs = length newVariables
+ in
+ (newText, wrapLets, numArgs)
+ end
+
+fun cacheQuery effs env (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) =
+ fn e' as EQuery {query = origQueryText,
+ state = resultTyp,
+ initial, body, tables, exps} =>
+ let
+ val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText
+ (* Increment once for each new variable just made. *)
+ val queryExp = incRels numArgs
+ (EQuery {query = newQueryText,
+ state = resultTyp,
+ initial = initial,
+ body = body,
+ tables = tables,
+ exps = exps},
+ dummyLoc)
+ (* DEBUG *)
+ (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *)
+ val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc))
+ fun bind x f = Option.mapPartial f x
+ fun guard b x = if b then x else NONE
+ (* We use dummyTyp here. I think this is okay because databases don't
+ store (effectful) functions, but perhaps there's some pathalogical
+ corner case missing.... *)
+ fun safe bound =
+ not
+ o effectful effs
+ (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE)
+ bound
+ env)
+ val textOfQuery = fn (EQuery {query, ...}, _) => SOME query | _ => NONE
+ val attempt =
+ (* Ziv misses Haskell's do notation.... *)
+ bind (textOfQuery queryExp) (fn queryText =>
+ guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) (
+ bind (Sql.parse Sql.query queryText) (fn queryParsed =>
+ bind (cacheWrap (env, queryExp, resultTyp, args, index)) (fn cachedExp =>
+ SOME (wrapLets cachedExp,
+ (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index))
+ tableToIndices
+ (tablesQuery queryParsed),
+ IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)),
+ index + 1))))))
+ in
+ case attempt of
+ SOME pair => pair
+ (* We have to increment index conservatively. *)
+ (* TODO: just use a reference for current index.... *)
+ | NONE => (e', (tableToIndices, indexToQueryNumArgs, index + 1))
+ end
+ | e' => (e', queryInfo)
+
+fun addChecking file =
+ let
+ val effs = effectfulDecls file
+ in
+ (fileAllMapfoldB (fn env => fn exp => fn state => cacheQuery effs env state exp)
+ file
+ (SIMM.empty, IM.empty, 0),
+ effs)
+ end
+
+
+(************)
+(* Flushing *)
+(************)
+
+structure Invalidations = struct
+
+ val loc = dummyLoc
+
+ val optionAtomExpToExp =
+ fn NONE => (ENone stringTyp, loc)
+ | SOME e => (ESome (stringTyp,
+ (case e of
+ DmlRel n => ERel n
+ | Prim p => EPrim p
+ (* TODO: make new type containing only these two. *)
+ | _ => raise Match,
+ loc)),
+ loc)
+
+ fun eqsToInvalidation numArgs eqs =
+ let
+ fun inv n = if n < 0 then [] else IM.find (eqs, n) :: inv (n - 1)
+ in
+ inv (numArgs - 1)
+ end
+
+ (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here
+ represents unknown, which means a wider invalidation. *)
+ val rec madeRedundantBy : atomExp option list * atomExp option list -> bool =
+ fn ([], []) => true
+ | (_ :: xs, NONE :: ys) => madeRedundantBy (xs, ys)
+ | (SOME x :: xs, SOME y :: ys) => (case AtomExpKey.compare (x, y) of
+ EQUAL => madeRedundantBy (xs, ys)
+ | _ => false)
+ | _ => false
+
+ fun eqss (query, dml) = conflictMaps (queryToFormula query, dmlToFormula dml)
+
+ fun invalidations ((query, numArgs), dml) =
+ (map (map optionAtomExpToExp)
+ o removeRedundant madeRedundantBy
+ o map (eqsToInvalidation numArgs)
+ o eqss)
+ (query, dml)
+
+end
+
+val invalidations = Invalidations.invalidations
+
+(* DEBUG *)
+(* val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] *)
+(* val gunk' : exp list ref = ref [] *)
+
+fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) =
+ let
+ val flushes = List.concat
+ o map (fn (i, argss) => map (fn args => flush (i, args)) argss)
+ val doExp =
+ fn EDml (origDmlText, failureMode) =>
+ let
+ (* DEBUG *)
+ (* val () = gunk' := origDmlText :: !gunk' *)
+ val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText
+ val dmlText = incRels numArgs newDmlText
+ val dmlExp = EDml (dmlText, failureMode)
+ (* DEBUG *)
+ (* val () = Print.preface ("SQLCACHE: ", (MonoPrint.p_exp MonoEnv.empty origDmlText)) *)
+ val inval =
+ case Sql.parse Sql.dml dmlText of
+ SOME dmlParsed =>
+ SOME (map (fn i => (case IM.find (indexToQueryNumArgs, i) of
+ SOME queryNumArgs =>
+ (* DEBUG *)
+ ((* gunk := (queryNumArgs, dmlParsed) :: !gunk; *)
+ (i, invalidations (queryNumArgs, dmlParsed)))
+ (* TODO: fail more gracefully. *)
+ | NONE => raise Match))
+ (SIMM.findList (tableToIndices, tableDml dmlParsed)))
+ | NONE => NONE
+ in
+ case inval of
+ (* TODO: fail more gracefully. *)
+ NONE => raise Match
+ | SOME invs => wrapLets (sequence (flushes invs @ [dmlExp]))
+ end
+ | e' => e'
+ in
+ (* DEBUG *)
+ (* gunk := []; *)
+ (fileMap doExp file, index, effs)
+ end
+
+
+(***************)
+(* Entry point *)
+(***************)
+
+val inlineSql =
+ let
+ val doExp =
+ (* TODO: EQuery, too? *)
+ (* ASK: should this live in [MonoOpt]? *)
+ fn EDml ((ECase (disc, cases, {disc = dTyp, ...}), loc), failureMode) =>
+ let
+ val newCases = map (fn (p, e) => (p, (EDml (e, failureMode), loc))) cases
+ in
+ ECase (disc, newCases, {disc = dTyp, result = (TRecord [], loc)})
+ end
+ | e => e
+ in
+ fileMap doExp
+ end
+
fun insertAfterDatatypes ((decls, sideInfo), newDecls) =
let
val (datatypes, others) = List.partition (fn (DDatatype _, _) => true | _ => false) decls
diff --git a/src/toy_cache.sml b/src/toy_cache.sml
index cfde027b..377cae01 100644
--- a/src/toy_cache.sml
+++ b/src/toy_cache.sml
@@ -13,13 +13,7 @@ val optionStringTyp = (TOption stringTyp, dummyLoc)
fun withTyp typ = map (fn exp => (exp, typ))
fun ffiAppCache' (func, index, argTyps) =
- let
- val m = "Sqlcache"
- val f = func ^ Int.toString index
- in
- Settings.addEffectful (m, f);
- EFfiApp (m, f, argTyps)
- end
+ EFfiApp ("Sqlcache", func ^ Int.toString index, argTyps)
fun check (index, keys) =
ffiAppCache' ("check", index, withTyp stringTyp keys)