# HG changeset patch # User Ziv Scully # Date 1394273182 18000 # Node ID 606af2c9b8286635c5b28ba500577729f9e0ffcd # Parent 94529780bbcfbef70135f98d4c68aa541d1f1e4f Identifies tables read or touched by queries. diff -r 94529780bbcf -r 606af2c9b828 sqlcache-tests/test.ur --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/sqlcache-tests/test.ur Sat Mar 08 05:06:22 2014 -0500 @@ -0,0 +1,22 @@ +table foo : {Id : int, Bar : string} PRIMARY KEY Id + +(* val query = (SELECT * FROM foo WHERE foo.Bar = "baz") *) +(* val insert = (INSERT INTO foo (Id, Bar) VALUES (42, "baz")) *) + +fun main () : transaction page = + dml (INSERT INTO foo (Id, Bar) VALUES (42, "baz")); + res <- oneOrNoRows (SELECT foo.Id, foo.Bar + FROM foo + WHERE foo.Bar = "baz" + UNION + SELECT * + FROM foo + WHERE foo.Bar = "qux"); + return + + + {case res of + None => + | Some row => {[row.Foo.Bar]}} + + diff -r 94529780bbcf -r 606af2c9b828 sqlcache-tests/test.urp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/sqlcache-tests/test.urp Sat Mar 08 05:06:22 2014 -0500 @@ -0,0 +1,4 @@ +database dbname=test +safeGet Test/main + +test diff -r 94529780bbcf -r 606af2c9b828 sqlcache-tests/test.urs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/sqlcache-tests/test.urs Sat Mar 08 05:06:22 2014 -0500 @@ -0,0 +1,1 @@ +val main : unit -> transaction page diff -r 94529780bbcf -r 606af2c9b828 src/compiler.sig --- a/src/compiler.sig Fri Mar 07 11:50:45 2014 -0500 +++ b/src/compiler.sig Sat Mar 08 05:06:22 2014 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -122,6 +122,7 @@ val pathcheck : (Mono.file, Mono.file) phase val sidecheck : (Mono.file, Mono.file) phase val sigcheck : (Mono.file, Mono.file) phase + val sqlcache : (Mono.file, Mono.file) phase val cjrize : (Mono.file, Cjr.file) phase val prepare : (Cjr.file, Cjr.file) phase val checknest : (Cjr.file, Cjr.file) phase @@ -137,12 +138,12 @@ val toCorify : (string, Core.file) transform val toCore_untangle : (string, Core.file) transform val toShake1 : (string, Core.file) transform - val toEspecialize1' : (string, Core.file) transform + val toEspecialize1' : (string, Core.file) transform val toShake1' : (string, Core.file) transform val toRpcify : (string, Core.file) transform val toCore_untangle2 : (string, Core.file) transform val toShake2 : (string, Core.file) transform - val toEspecialize1 : (string, Core.file) transform + val toEspecialize1 : (string, Core.file) transform val toCore_untangle3 : (string, Core.file) transform val toShake3 : (string, Core.file) transform val toTag : (string, Core.file) transform @@ -186,6 +187,7 @@ val toPathcheck : (string, Mono.file) transform val toSidecheck : (string, Mono.file) transform val toSigcheck : (string, Mono.file) transform + val toSqlcache : (string, Mono.file) transform val toCjrize : (string, Cjr.file) transform val toPrepare : (string, Cjr.file) transform val toChecknest : (string, Cjr.file) transform diff -r 94529780bbcf -r 606af2c9b828 src/compiler.sml --- a/src/compiler.sml Fri Mar 07 11:50:45 2014 -0500 +++ b/src/compiler.sml Sat Mar 08 05:06:22 2014 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -25,7 +25,7 @@ * POSSIBILITY OF SUCH DAMAGE. *) -structure Compiler :> COMPILER = struct +structure Compiler :> COMPILER = struct structure UrwebLrVals = UrwebLrValsFn(structure Token = LrParser.Token) structure Lex = UrwebLexFn(structure Tokens = UrwebLrVals.Tokens) @@ -268,7 +268,7 @@ | _ => absyn end handle LrParser.ParseError => [], - print = SourcePrint.p_file} + print = SourcePrint.p_file} fun p_job ({prefix, database, exe, sql, sources, debug, profile, timeout, ffi, link, headers, scripts, @@ -1090,7 +1090,7 @@ ErrorMsg.error ("Rooted module " ^ full ^ " has multiple versions.") else (); - + makeD true "" pieces before ignore (foldl (fn (new, path) => let @@ -1438,12 +1438,19 @@ val toSigcheck = transform sigcheck "sigcheck" o toSidecheck +val sqlcache = { + func = (fn file => (Sql.go file; file)), + print = MonoPrint.p_file MonoEnv.empty +} + +val toSqlcache = transform sqlcache "sqlcache" o toSigcheck + val cjrize = { func = Cjrize.cjrize, print = CjrPrint.p_file CjrEnv.empty } -val toCjrize = transform cjrize "cjrize" o toSigcheck +val toCjrize = transform cjrize "cjrize" o toSqlcache val prepare = { func = Prepare.prepare, @@ -1596,7 +1603,7 @@ compileC {cname = cname, oname = oname, ename = ename, libs = libs, profile = #profile job, debug = #debug job, linker = #linker job, link = #link job} - + before cleanup ()) end handle ex => (((cleanup ()) handle _ => ()); raise ex) diff -r 94529780bbcf -r 606af2c9b828 src/sql.sml --- a/src/sql.sml Fri Mar 07 11:50:45 2014 -0500 +++ b/src/sql.sml Sat Mar 08 05:06:22 2014 -0500 @@ -2,7 +2,7 @@ open Mono -val debug = ref false +val debug = ref true (*false*) type lvar = int @@ -238,7 +238,7 @@ end else NONE - | _ => NONE + | _ => NONE val prim = altL [wrap (follow (wrapP (follow (keep Char.isDigit) (follow (const ".") (keep Char.isDigit))) @@ -267,7 +267,7 @@ ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _), (EPrim (Prim.String "FALSE"), _))], _), _) :: chs => SOME (e, chs) - + | _ => NONE fun constK s = wrap (const s) (fn () => s) @@ -317,7 +317,7 @@ and known chs = wrap (follow known' (follow (const "(") (follow sqexp (const ")")))) (fn ((), ((), (e, ()))) => e) chs - + and func chs = wrap (follow funcName (follow (const "(") (follow sqexp (const ")")))) (fn (f, ((), (e, ()))) => (f, e)) chs @@ -425,4 +425,81 @@ val querydml = log "querydml" (altL [wrap dml Dml, wrap query Query]) +(* New stuff. *) + +fun subExps' (exp' : Mono.exp') = + case exp' of + ECon (_,_,SOME exp) => [exp] + | ESome (_,exp) => [exp] + | EFfiApp (_,_,xs) => map #1 xs + | EApp (exp1,exp2) => [exp1, exp2] + | EAbs (_,_,_,exp) => [exp] + | EUnop (_,exp) => [exp] + | EBinop (_,_,exp1,exp2) => [exp1, exp2] + | ERecord xs => map #2 xs + | EField (exp,_) => [exp] + | ECase (exp,xs,_) => exp :: map #2 xs + | EStrcat (exp1,exp2) => [exp1,exp2] + | EError (exp,_) => [exp] + | EReturnBlob {blob=NONE, mimeType, ...} => [mimeType] + | EReturnBlob {blob=SOME exp, mimeType, ...} => [exp, mimeType] + | ERedirect (exp,_) => [exp] + | EWrite exp => [exp] + | ESeq (exp1,exp2) => [exp1, exp2] + | ELet (_,_,exp1,exp2) => [exp1, exp2] + | EClosure (_,xs) => xs + | EQuery {query, body, initial, ...} => [query, body, initial] + | EDml (exp,_) => [exp] + | ENextval exp => [exp] + | ESetval (exp1,exp2) => [exp1, exp2] + | EUnurlify (exp,_,_) => [exp] + | EJavaScript (_,exp) => [exp] + | ESignalReturn exp => [exp] + | ESignalBind (exp1,exp2) => [exp1, exp2] + | ESignalSource exp => [exp] + | EServerCall (exp,_,_,_) => [exp] + | ERecv (exp,_) => [exp] + | ESleep exp => [exp] + | ESpawn exp => [exp] + | _ => [] + +val subExps : Mono.exp -> Mono.exp list = subExps' o #1 + +fun println str = print (str ^ "\n") +fun printlnExp exp = (Print.print (MonoPrint.p_exp MonoEnv.empty exp); println "") + +fun tablesRead (Query1 {From=tablePairs, ...}) = map #1 tablePairs + | tablesRead (Union (q1,q2)) = tablesRead q1 @ tablesRead q2 + +fun tableTouched (Insert (tab,_)) = tab + | tableTouched (Delete (tab,_)) = tab + | tableTouched (Update (tab,_,_)) = tab + +fun goExp (exp : Mono.exp) = + case #1 exp of + EQuery {query=e, ...} => ( + case parse query e of + SOME q => println ("Query reads from " ^ String.concatWith ", " (tablesRead q)) + | NONE => println "Couldn't parse query"; + printlnExp exp; println "") + | EDml (e,_) => ( + case parse dml e of + SOME d => println ("DML touches " ^ tableTouched d) + | NONE => println "Couldn't parse DML"; + printlnExp exp; println "") + | ENextval _ => (printlnExp exp; println "") + | ESetval _ => (printlnExp exp; println "") + (* Recurse down the syntax tree. *) + | _ => app goExp (subExps exp) + +fun goDecl (decl : decl) = + case #1 decl of + DVal (_,_,_,exp,_) => goExp exp + | DValRec xs => app (goExp o #4) xs + | _ => () + +fun goFile (file : file) = app goDecl (#1 file) + +fun go file = (println "Doing SQL analysis.\n"; goFile file; ()) + end