Mercurial > urweb
diff 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 |
line wrap: on
line diff
--- a/src/sqlcache.sml Mon Sep 28 22:16:51 2015 -0400 +++ b/src/sqlcache.sml Wed Sep 30 00:33:52 2015 -0400 @@ -499,6 +499,8 @@ 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 @@ -506,7 +508,7 @@ 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. *) + 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) @@ -615,7 +617,9 @@ 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 @@ -672,6 +676,7 @@ (* 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 @@ -680,26 +685,30 @@ 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 invs = + val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty origDmlText)) + val inval = case Sql.parse Sql.dml dmlText of SOME dmlParsed => - 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)) - (* TODO: fail more gracefully. *) - | NONE => raise Match + 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 - 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 @@ -801,6 +810,7 @@ structure InvalidationInfo :> sig type t + val empty : t val fromList : int list -> t val toList : t -> int list val union : t * t -> t @@ -816,14 +826,16 @@ | (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 - | (x, NONE) => x + | (NONE, info) => info + | (info, NONE) => info val unbind = fn (SOME (n, ns), unbound) => @@ -838,6 +850,15 @@ 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 = @@ -936,44 +957,43 @@ 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) - (* Important that this happens after the MonoFooify.urlify calls! *) - val fmDecls = MonoFooify.getNewFmDecls () in - (* ASK: fmDecls before or after? *) - (fmDecls @ decls, sideInfo) + (rev (#1 (List.foldl doDecl ([], MonoEnv.empty, indexStart) decls)), sideInfo) end -val go' = addPure o addFlushing o addChecking o inlineSql +val go' = addPure o addFlushing o addChecking (* DEBUG: add back [o inlineSql]. *) fun go file = let