Ur/Web: src/sqlcache.sml comparison

comparison src/sqlcache.sml @ 2278:b7615e0ac4b0

Fix bug in and clean up free path code.

author	Ziv Scully <ziv@mit.edu>
date	Tue, 10 Nov 2015 12:35:00 -0500
parents	c05f9a5e0f0f
children	0bdfec16a01d

comparison

equal deleted inserted replaced

-:6bce459ca581
+:b7615e0ac4b0
-structure Sqlcache (* DEBUG :> SQLCACHE *) = struct
+structure Sqlcache :> SQLCACHE = struct
 open Mono
 structure IK = struct type ord_key = int val compare = Int.compare end
 structure IS = IntBinarySet
 (* 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
-val cache = ref LruCache.cache
+val cacheRef = ref LruCache.cache
-fun setCache c = cache := c
+fun setCache c = cacheRef := c
-fun getCache () = !cache
+fun getCache () = !cacheRef
+val alwaysConsolidateRef = ref true
+fun setAlwaysConsolidate b = alwaysConsolidateRef := b
+fun getAlwaysConsolidate () = !alwaysConsolidateRef
 (* Used to have type context for local variables in MonoUtil functions. *)
 val doBind =
 fn (env, MonoUtil.Exp.RelE (x, t)) => MonoEnv.pushERel env x t NONE
 | (env, MonoUtil.Exp.NamedE (x, n, t, eo, s)) => MonoEnv.pushENamed env x n t eo s
 | (env, MonoUtil.Exp.Datatype (x, n, cs)) => MonoEnv.pushDatatype env x n cs
 val dummyLoc = ErrorMsg.dummySpan
+(* DEBUG *)
+fun printExp msg exp = Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_exp MonoEnv.empty exp)
+fun printExp' msg exp' = printExp msg (exp', dummyLoc)
+fun printTyp msg typ = Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_typ MonoEnv.empty typ)
+fun printTyp' msg typ' = printTyp msg (typ', dummyLoc)
+fun obindDebug printer (x, f) =
+case x of
+NONE => NONE
+| SOME x' => case f x' of
+NONE => (printer (); NONE)
+| y => y
 (*********************)
 (* General Utilities *)
 (*********************)
 | (bound, _) => bound}
 0
 IS.empty
 (* A path is a number of field projections of a variable. *)
+type path = int * string list
 structure PK = PairKeyFn(structure I = IK structure J = ListKeyFn(SK))
 structure PS = BinarySetFn(PK)
-(* DEBUG *)
-val gunk3 : (PS.set * PS.set) list ref = ref []
-val gunk4 : (PS.set * PS.set) list ref = ref []
 val pathOfExp =
 let
 fun readFields acc exp =
 acc
 | EUnop (_, e) => freePaths' bound e
 | EBinop (_, _, e1, e2) => freePaths' bound e1 o freePaths' bound e2
 | ERecord fields => List.foldl (fn ((_, e, _), acc) => freePaths' bound e o acc) id fields
 | e as EField _ => freePaths'' bound e
 | ECase (e, cases, _) =>
-List.foldl (fn ((p, e), acc) => freePaths' (bound + MonoEnv.patBindsN p) e o acc)
+List.foldl (fn ((p, e), acc) => freePaths' (MonoEnv.patBindsN p + bound) e o acc)
 (freePaths' bound e)
 cases
 | EStrcat (e1, e2) => freePaths' bound e1 o freePaths' bound e2
 | EError (e, _) => freePaths' bound e
 | EReturnBlob {blob, mimeType = e, ...} =>
 freePaths' bound e o (case blob of NONE => id | SOME e => freePaths' bound e)
 | ERedirect (e, _) => freePaths' bound e
 | EWrite e => freePaths' bound e
 | ESeq (e1, e2) => freePaths' bound e1 o freePaths' bound e2
-| ELet (_, _, e1, e2) => freePaths' (bound + 1) e1 o freePaths' bound e2
+| ELet (_, _, e1, e2) => freePaths' bound e1 o freePaths' (bound + 1) e2
 | EClosure (_, es) => List.foldl (fn (e, acc) => freePaths' bound e o acc) id es
 | EQuery {query = e1, body = e2, initial = e3, ...} =>
 freePaths' bound e1 o freePaths' (bound + 2) e2 o freePaths' bound e3
 | EDml (e, _) => freePaths' bound e
 | ENextval e => freePaths' bound e
 datatype unbind = Known of exp | Unknowns of int
 datatype cacheArg = AsIs of exp | Urlify of exp
-structure InvalInfo (* DEBUG :> sig
+structure InvalInfo :> sig
 type t
 type state = {tableToIndices : SIMM.multimap,
 indexToInvalInfo : (t * int) IntBinaryMap.map,
 ffiInfo : {index : int, params : int} list,
 index : int}
 val empty : t
 val singleton : Sql.query -> t
 val query : t -> Sql.query
-val orderArgs : t * IS.set -> cacheArg list
+val orderArgs : t * Mono.exp -> cacheArg list
 val unbind : t * unbind -> t option
 val union : t * t -> t
 val updateState : t * int * state -> state
-end *) = struct
+end = struct
 (* Variable, field projections, possible wrapped sqlification FFI call. *)
-type sqlArg = int * string list * (string * string * typ) option
+type sqlArg = path * (string * string * typ) option
 type subst = sqlArg IM.map
 (* TODO: store free variables as well? *)
 type t = (Sql.query * subst) list
 type state = {tableToIndices : SIMM.multimap,
 indexToInvalInfo : (t * int) IntBinaryMap.map,
 ffiInfo : {index : int, params : int} list,
 index : int}
-structure AK = TripleKeyFn(
+structure AK = PairKeyFn(
-structure I = IK
+structure I = PK
-structure J = ListKeyFn(SK)
+structure J = OptionKeyFn(TripleKeyFn(
-structure K = OptionKeyFn(TripleKeyFn(
 structure I = SK
 structure J = SK
 structure K = struct type ord_key = Mono.typ val compare = MonoUtil.Typ.compare end)))
 structure AM = BinaryMapFn(AK)
 IM.foldli (fn (k, v, acc) => lift2 (fn (acc, w) => IM.insert (acc, k, w)) (acc, f (k,v)))
 (pure IM.empty)
 fun traverseSubst (ops as (_, pure', lift, _, _, _, lift2')) f =
 let
-fun mp (n, fields, sqlify) =
+fun mp ((n, fields), sqlify) =
-lift (fn (n', fields', sqlify') =>
+lift (fn ((n', fields'), sqlify') =>
 let
-fun wrap sq = (n', fields' @ fields, sq)
+fun wrap sq = ((n', fields' @ fields), sq)
 in
 case (fields', sqlify', fields, sqlify) of
 (_, NONE, _, NONE) => wrap NONE
 | (_, NONE, _, sq as SOME _) => wrap sq
 (* Last case should suffice because we don't
 (* Signature Implementation *)
 val empty = []
-fun singleton q = [(q, IS.foldl (fn (n, acc) => IM.insert (acc, n, (n, [], NONE)))
+fun singleton q = [(q, IS.foldl (fn (n, acc) => IM.insert (acc, n, ((n, []), NONE)))
 IM.empty
 (varsOfQuery q))]
 val union = op@
 in
 (* Maps each arg to a different consecutive integer, starting from 0. *)
 AM.map count args
 end
-fun expOfArg (n, fields, sqlify) =
+fun expOfArg (path, sqlify) =
 let
-val exp = List.foldl (fn (field, exp) => (EField (exp, field), dummyLoc))
+val exp = expOfPath path
-(ERel n, dummyLoc)
-fields
 in
 case sqlify of
 NONE => exp
 | SOME (m, x, typ) => (EFfiApp (m, x, [(exp, typ)]), dummyLoc)
 end
-fun orderArgs (qs : t, paths) =
+fun orderArgs (qs : t, exp) =
 let
+val paths = freePaths exp
 fun erel n = (ERel n, dummyLoc)
 val argsMap = sqlArgsMap qs
 val args = map (expOfArg o #1) (AM.listItemsi argsMap)
 val invalPaths = List.foldl PS.union PS.empty (map freePaths args)
-(* DEBUG *)
-val () = gunk3 := (paths, invalPaths) :: !gunk3
 in
 (* Put arguments we might invalidate by first. *)
 map AsIs args
 (* TODO: make sure these variables are okay to remove from the argument list. *)
 @ map (Urlify o expOfPath) (PS.listItems (PS.difference (paths, invalPaths)))
 | EField (exp, f) => doFields (SOME (f::fs, sqlify)) exp
 | _ => NONE)
 in
 fn (EFfiApp ("Basis", x, [(exp, typ)]), _) =>
 if String.isPrefix "sqlify" x
-then doFields (SOME ([], SOME ("Basis", x, typ))) exp
+then omap (fn path => (path, SOME ("Basis", x, typ))) (pathOfExp exp)
 else NONE
-| exp => doFields (SOME ([], NONE)) exp
+| exp => omap (fn path => (path, NONE)) (pathOfExp exp)
 end
 val unbind1 =
 fn Known e =>
 let
 val replacement = argOfExp e
 in
 omapSubst (fn 0 => replacement
-| n => SOME (n-1, [], NONE))
+| n => SOME ((n-1, []), NONE))
 end
-| Unknowns k => omapSubst (fn n => if n < k then NONE else SOME (n-k, [], NONE))
+| Unknowns k => omapSubst (fn n => if n < k then NONE else SOME ((n-k, []), NONE))
 fun unbind (qs, ub) =
 case ub of
 (* Shortcut if nothing's changing. *)
 Unknowns 0 => SOME qs
 indexToInvalInfo = IM.insert (#indexToInvalInfo state, index, (qs, numArgs)),
 ffiInfo = {index = index, params = numArgs} :: #ffiInfo state,
 index = index + 1}
 end
-(* DEBUG *)
-val gunk0 : ((Sql.cmp * Sql.sqexp * Sql.sqexp) formula
-* (Sql.cmp * Sql.sqexp * Sql.sqexp) formula) list ref = ref []
-val gunk1 : (Sql.cmp * atomExp option * atomExp option) list list list ref = ref []
-val gunk2 : exp list ref = ref []
 structure UF = UnionFindFn(AtomExpKey)
 val rec sqexpToFormula =
 fn Sql.SqTrue => Combo (Conj, [])
 normalize simplify normalizeAtom Disj (Combo (Conj, [markQuery fQuery, markDml fDml]))
 val conflictMaps =
 List.mapPartial (mergeEqs o map eqsOfClass)
 o List.mapPartial equivClasses
-o (fn x => (gunk1 := x :: !gunk1; x))
 o dnf
-o (fn x => (gunk0 := x :: !gunk0; x))
 end
 val conflictMaps = ConflictMaps.conflictMaps
 end
 val expSize = MonoUtil.Exp.fold {typ = #2, exp = fn (_, n) => n+1} 0
 (* TODO: pick a number. *)
-val sizeWorthCaching = ~1
+val sizeWorthCaching = 5
 val worthCaching =
 fn EQuery _ => true
 | exp' => expSize (exp', dummyLoc) > sizeWorthCaching
+fun shouldConsolidate args =
+let
+val isAsIs = fn AsIs _ => true | Urlify _ => false
+in
+getAlwaysConsolidate ()
+orelse not (List.exists isAsIs args andalso List.exists (not o isAsIs) args)
+end
 fun cacheExp (env, exp', invalInfo, state : state) =
 case worthCaching exp' <\oguard\> typOfExp' env exp' of
 NONE => NONE
 | SOME (TFun _, _) => NONE
 | SOME typ =>
 let
-val args = InvalInfo.orderArgs (invalInfo, freePaths (exp', dummyLoc))
+val args = InvalInfo.orderArgs (invalInfo, (exp', dummyLoc))
-val numArgs = length args
+in
-in (List.foldr (fn (arg, acc) =>
+shouldConsolidate args
-acc
+<\oguard\>
-<\obind\>
+List.foldr (fn (arg, acc) =>
-(fn args' =>
+acc
-(case arg of
+<\obind\>
-AsIs exp => SOME exp
+(fn args' =>
-| Urlify exp =>
+(case arg of
-typOfExp env exp
+AsIs exp => SOME exp
-<\obind\>
+| Urlify exp =>
-(fn typ =>
+typOfExp env exp
-(MonoFooify.urlify env (exp, typ))))
+<\obind\>
-<\obind\>
+(fn typ => (MonoFooify.urlify env (exp, typ))))
-(fn arg' => SOME (arg' :: args'))))
+<\obind\>
-(SOME [])
+(fn arg' => SOME (arg' :: args'))))
-args)
+(SOME [])
-<\obind\>
+args
-(fn args' =>
+<\obind\>
-cacheWrap (env, (exp', dummyLoc), typ, args', #index state)
+(fn args' =>
-<\obind\>
+cacheWrap (env, (exp', dummyLoc), typ, args', #index state)
-(fn cachedExp =>
+<\obind\>
-SOME (cachedExp, InvalInfo.updateState (invalInfo, numArgs, state))))
+(fn cachedExp =>
+SOME (cachedExp, InvalInfo.updateState (invalInfo, length args', state))))
 end
 fun cacheQuery (effs, env, q) : subexp =
 let
 (* We use dummyTyp here. I think this is okay because databases don't
 o effectful effs
 (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE)
 bound
 env)
 val {query = queryText, initial, body, ...} = q
-(* DEBUG *)
-(* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *)
 val attempt =
 (* Ziv misses Haskell's do notation.... *)
 (safe 0 queryText andalso safe 0 initial andalso safe 2 body)
 <\oguard\>
 Sql.parse Sql.query queryText
 case attempt of
 NONE => Impure (EQuery q, dummyLoc)
 | SOME subexp => subexp
 end
-(* DEBUG *)
+fun cacheTree (effs : IS.set) ((env, exp as (exp', loc)), state) =
-(* fun cacheTree (effs : IS.set) ((env, exp as (exp', loc)), state) = *)
-(*     (Print.preface ("cacheTree> ", MonoPrint.p_exp MonoEnv.empty exp); *)
-(*      cacheTree' effs ((env, exp), state)) *)
-and cacheTree (effs : IS.set) ((env, exp as (exp', loc)), state) =
 let
 fun wrapBindN (f : exp list -> exp')
 (args : ((MonoEnv.env * exp) * unbind) list) =
 let
 val (subexps, state) =
 val flushes = List.concat
 o map (fn (i, argss) => map (fn args => flush (i, args)) argss)
 val doExp =
 fn dmlExp as EDml (dmlText, failureMode) =>
 let
-(* DEBUG *)
-(* val () = gunk2 := dmlText :: !gunk2 *)
-(* 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 (indexToInvalInfo, i) of
 SOME invalInfo =>

Mercurial > urweb

comparison src/sqlcache.sml @ 2278:b7615e0ac4b0