Ur/Web: src/sqlcache.sml comparison

comparison src/sqlcache.sml @ 2261:f81f1930c5d6

Fix SQL-parsing and declaration-ordering bugs.

author	Ziv Scully <ziv@mit.edu>
date	Wed, 30 Sep 2015 00:33:52 -0400
parents	03b10c7fab9a
children	34ad83d9b729

comparison

equal deleted inserted replaced

-:03b10c7fab9a
+:f81f1930c5d6
 fun cacheWrap (env, exp, resultTyp, args, i) =
 let
 val loc = dummyLoc
 val rel0 = (ERel 0, loc)
+(* DEBUG *)
+val () = print (Int.toString i ^ "\n")
 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
 IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)),
 index + 1)))))
 in
 case attempt of
 SOME pair => pair
-| NONE => (e', queryInfo)
+(* We have to increment index conservatively. *)
+(* TODO: just use a reference for current index.... *)
+| NONE => (e', (tableToIndices, indexToQueryNumArgs, index + 1))
 end
 | e' => (e', queryInfo)
 in
 (fileMapfoldB (fn env => fn exp => fn state => doExp env state exp)
 file
 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 dmlText)) *)
+val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty origDmlText))
-val invs =
+val inval =
 case Sql.parse Sql.dml dmlText of
 SOME dmlParsed =>
-map (fn i => (case IM.find (indexToQueryNumArgs, i) of
+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))
+(SIMM.findList (tableToIndices, tableDml dmlParsed)))
-(* TODO: fail more gracefully. *)
+| NONE => NONE
-| NONE => raise Match
 in
-wrapLets (sequence (flushes invs @ [dmlExp]))
+case inval of
+(* TODO: fail more gracefully. *)
+NONE => raise Match
+| SOME invs => wrapLets (sequence (flushes invs @ [dmlExp]))
 end
 | e' => e'
 in
 (* DEBUG *)
 gunk := [];
 val expSize = MonoUtil.Exp.fold {typ = #2, exp = fn (_, n) => n+1} 0
 structure InvalidationInfo :> sig
 type t
+val empty : t
 val fromList : int list -> t
 val toList : t -> int list
 val union : t * t -> t
 val unbind : t * int -> t option
 end = struct
 List.foldl
 (fn (n, NONE) => SOME (n, IS.singleton n)
 | (n', SOME (n, ns)) => SOME (Int.min (n, n'), IS.add (ns, n')))
 NONE
+val empty = fromList []
 val toList =
 fn NONE => []
 | SOME (_, ns) => IS.listItems ns
 val union =
 fn (SOME (n1, ns1), SOME (n2, ns2)) => SOME (Int.min (n1, n2), IS.union (ns1, ns2))
-| (NONE, x) => x
+| (NONE, info) => info
-| (x, NONE) => x
+| (info, NONE) => info
 val unbind =
 fn (SOME (n, ns), unbound) =>
 let
 val n = n - unbound
 else SOME (SOME (n, IS.map (fn n => n - unbound) ns))
 end
 | _ => SOME NONE
 end
+val unionUnbind =
+List.foldl
+(fn (_, NONE) => NONE
+| ((info, unbound), SOME infoAcc) =>
+case InvalidationInfo.unbind (info, unbound) of
+NONE => NONE
+| SOME info => SOME (InvalidationInfo.union (info, infoAcc)))
+(SOME InvalidationInfo.empty)
 datatype subexp = Pure of unit -> exp | Impure of exp
 val isImpure =
 fn Pure _ => false
 | SOME e' => e',
 loc)),
 index + 1)
 end
-fun addPure ((decls, sideInfo), index, effs) =
+fun addPure ((decls, sideInfo), indexStart, effs) =
 let
-fun doVal ((x, n, t, exp, s), index) =
+fun doVal env ((x, n, t, exp, s), index) =
 let
-val (subexp, index) = pureCache effs ((MonoEnv.empty, exp), index)
+val (subexp, index) = pureCache effs ((env, exp), index)
 in
 ((x, n, t, expOfSubexp subexp, s), index)
 end
-fun doDecl' (decl', index) =
+fun doDecl' env (decl', index) =
 case decl' of
 DVal v =>
 let
-val (v, index) = (doVal (v, index))
+val (v, index) = doVal env (v, index)
 in
 (DVal v, index)
 end
 | DValRec vs =>
 let
-val (vs, index) = ListUtil.foldlMap doVal index vs
+val (vs, index) = ListUtil.foldlMap (doVal env) index vs
 in
 (DValRec vs, index)
 end
 | _ => (decl', index)
-fun doDecl ((decl', loc), index) =
+fun doDecl (decl as (decl', loc), (revDecls, env, index)) =
 let
-val (decl', index) = doDecl' (decl', index)
+val env = MonoEnv.declBinds env decl
+val (decl', index) = doDecl' env (decl', index)
+(* Important that this happens after [MonoFooify.urlify] calls! *)
+val fmDecls = MonoFooify.getNewFmDecls ()
 in
-((decl', loc), index)
+((decl', loc) :: (fmDecls @ revDecls), env, index)
 end
-val decls = #1 (ListUtil.foldlMap doDecl index decls)
+in
-(* Important that this happens after the MonoFooify.urlify calls! *)
+(rev (#1 (List.foldl doDecl ([], MonoEnv.empty, indexStart) decls)), sideInfo)
-val fmDecls = MonoFooify.getNewFmDecls ()
+end
-in
-(* ASK: fmDecls before or after? *)
+val go' = addPure o addFlushing o addChecking (* DEBUG: add back [o inlineSql]. *)
-(fmDecls @ decls, sideInfo)
-end
-val go' = addPure o addFlushing o addChecking o inlineSql
 fun go file =
 let
 (* TODO: do something nicer than [Sql] being in one of two modes. *)
 val () = (resetFfiInfo (); Sql.sqlcacheMode := true)

Mercurial > urweb

comparison src/sqlcache.sml @ 2261:f81f1930c5d6