# HG changeset patch # User Ziv Scully # Date 1443587632 14400 # Node ID f81f1930c5d6786e61258c8cfc5c4d9e357e67e7 # Parent 03b10c7fab9a724373e40c6b87159d8e10dce947 Fix SQL-parsing and declaration-ordering bugs. diff -r 03b10c7fab9a -r f81f1930c5d6 src/mono_fooify.sig --- a/src/mono_fooify.sig Mon Sep 28 22:16:51 2015 -0400 +++ b/src/mono_fooify.sig Wed Sep 30 00:33:52 2015 -0400 @@ -16,6 +16,7 @@ val lookup : t -> foo_kind -> int -> (int -> t -> vr * t) -> t * int val lookupList : t -> foo_kind -> Mono.typ -> (int -> t -> vr * t) -> t * int val enter : t -> t + (* This list should be reversed before adding to list of file declarations. *) val decls : t -> Mono.decl list val freshName : t -> int * t @@ -32,6 +33,7 @@ (* Easy-to-use interface in [Sqlcache]. Uses [Fm.canonical]. *) val canonicalFm : Fm.t ref (* Set at the end of [Monoize]. *) val urlify : MonoEnv.env -> Mono.exp * Mono.typ -> Mono.exp option +(* This list should be reversed before adding to list of file declarations. *) val getNewFmDecls : unit -> Mono.decl list end diff -r 03b10c7fab9a -r f81f1930c5d6 src/mono_fooify.sml --- a/src/mono_fooify.sml Mon Sep 28 22:16:51 2015 -0400 +++ b/src/mono_fooify.sml Wed Sep 30 00:33:52 2015 -0400 @@ -328,7 +328,7 @@ let val fm = !canonicalFm in - (* canonicalFm := Fm.enter fm; *) + canonicalFm := Fm.enter fm; Fm.decls fm end diff -r 03b10c7fab9a -r f81f1930c5d6 src/monoize.sml --- a/src/monoize.sml Mon Sep 28 22:16:51 2015 -0400 +++ b/src/monoize.sml Wed Sep 30 00:33:52 2015 -0400 @@ -4344,12 +4344,14 @@ val (nullable, notNullable) = calcClientish xts fun cond (x, v) = - (L'.EStrcat (str (Settings.mangleSql x - ^ (case v of - Client => "" - | Channel => " >> 32") - ^ " = "), - target), loc) + (L'.EStrcat ((L'.EStrcat (str ("((" + ^ Settings.mangleSql x + ^ (case v of + Client => "" + | Channel => " >> 32") + ^ ") = "), + target), loc), + str ")"), loc) val e = foldl (fn ((x, v), e) => @@ -4490,7 +4492,7 @@ pvars := RM.empty; pvarDefs := []; pvarOldDefs := []; - MonoFooify.canonicalFm := Fm.empty (MonoUtil.File.maxName monoFile); + MonoFooify.canonicalFm := Fm.empty (MonoUtil.File.maxName monoFile + 1); monoFile end diff -r 03b10c7fab9a -r f81f1930c5d6 src/sql.sml --- a/src/sql.sml Mon Sep 28 22:16:51 2015 -0400 +++ b/src/sql.sml Wed Sep 30 00:33:52 2015 -0400 @@ -321,7 +321,7 @@ fun arithmetic pExp = follow (const "(") (follow pExp - (follow (altL (map const [" + ", " - ", " * ", " / "])) + (follow (altL (map const [" + ", " - ", " * ", " / ", " >> ", " << "])) (follow pExp (const ")")))) val unmodeled = altL [const "COUNT(*)", @@ -445,9 +445,11 @@ val delete = log "delete" (wrap (follow (const "DELETE FROM ") (follow uw_ident - (follow (follow (opt (const " AS T_T")) (const " WHERE ")) - sqexp))) - (fn ((), (tab, (_, es))) => (tab, es))) + (follow (opt (const " AS T_T")) + (opt (follow (const " WHERE ") sqexp))))) + (fn ((), (tab, (_, wher))) => (tab, case wher of + SOME (_, es) => es + | NONE => SqTrue))) val setting = log "setting" (wrap (follow uw_ident (follow (const " = ") sqexp)) diff -r 03b10c7fab9a -r f81f1930c5d6 src/sqlcache.sml --- 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