From 0e1252d5a6330570df698df924a0554b688042e8 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Sat, 8 Mar 2014 05:06:22 -0500 Subject: Identifies tables read or touched by queries. --- src/compiler.sig | 8 ++++-- src/compiler.sml | 19 +++++++++---- src/sql.sml | 85 +++++++++++++++++++++++++++++++++++++++++++++++++++++--- 3 files changed, 99 insertions(+), 13 deletions(-) (limited to 'src') diff --git a/src/compiler.sig b/src/compiler.sig index fa131cf4..df567441 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -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 @@ signature COMPILER = sig 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 @@ signature COMPILER = sig 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 @@ signature COMPILER = sig 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 --git a/src/compiler.sml b/src/compiler.sml index cc4e33c5..36a1b03f 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -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 @@ val parseUr = { | _ => 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 @@ val parse = { ErrorMsg.error ("Rooted module " ^ full ^ " has multiple versions.") else (); - + makeD true "" pieces before ignore (foldl (fn (new, path) => let @@ -1438,12 +1438,19 @@ val sigcheck = { 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 @@ fun compile job = 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 --git a/src/sql.sml b/src/sql.sml index c314eb3d..601b3510 100644 --- a/src/sql.sml +++ b/src/sql.sml @@ -2,7 +2,7 @@ structure Sql = struct open Mono -val debug = ref false +val debug = ref true (*false*) type lvar = int @@ -238,7 +238,7 @@ fun string chs = end else NONE - | _ => NONE + | _ => NONE val prim = altL [wrap (follow (wrapP (follow (keep Char.isDigit) (follow (const ".") (keep Char.isDigit))) @@ -267,7 +267,7 @@ fun sqlify chs = ((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 @@ fun sqexp chs = 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 @@ datatype querydml = 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 -- cgit v1.2.3