From a08075494d9c16a349215fbcaefa3e1d14d2e0f9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 20 Dec 2008 14:19:21 -0500 Subject: Start of JsComp --- src/mono_env.sig | 1 + 1 file changed, 1 insertion(+) (limited to 'src/mono_env.sig') diff --git a/src/mono_env.sig b/src/mono_env.sig index cb6f2352..c59596ae 100644 --- a/src/mono_env.sig +++ b/src/mono_env.sig @@ -47,5 +47,6 @@ signature MONO_ENV = sig val declBinds : env -> Mono.decl -> env val patBinds : env -> Mono.pat -> env + val patBindsN : Mono.pat -> int end -- cgit v1.2.3 From 5765efc372a628ede62d8b27c799708f530a3456 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 6 Oct 2009 15:39:27 -0400 Subject: SELECT DISTINCT; eta expansion during Cjrization --- demo/more/versioned.ur | 114 +++++++++++++++++++++++++++++++++++++++++++++++ demo/more/versioned.urp | 4 ++ demo/more/versioned.urs | 19 ++++++++ demo/more/versioned1.ur | 62 ++++++++++++++++++++++++++ demo/more/versioned1.urp | 6 +++ demo/more/versioned1.urs | 1 + lib/ur/basis.urs | 3 +- lib/ur/top.ur | 6 +++ lib/ur/top.urs | 3 ++ src/cjrize.sml | 11 +++-- src/elisp/urweb-mode.el | 2 +- src/mono_env.sig | 2 + src/monoize.sml | 20 ++++++++- src/urweb.grm | 17 ++++--- src/urweb.lex | 1 + 15 files changed, 260 insertions(+), 11 deletions(-) create mode 100644 demo/more/versioned.ur create mode 100644 demo/more/versioned.urp create mode 100644 demo/more/versioned.urs create mode 100644 demo/more/versioned1.ur create mode 100644 demo/more/versioned1.urp create mode 100644 demo/more/versioned1.urs (limited to 'src/mono_env.sig') diff --git a/demo/more/versioned.ur b/demo/more/versioned.ur new file mode 100644 index 00000000..cb93ef6c --- /dev/null +++ b/demo/more/versioned.ur @@ -0,0 +1,114 @@ +functor Make(M : sig + con key :: {Type} + con data :: {Type} + constraint key ~ data + constraint [When] ~ (key ++ data) + + val key : $(map sql_injectable key) + val data : $(map (fn t => {Inj : sql_injectable_prim t, + Eq : eq t}) data) + + val keyFolder : folder key + val dataFolder : folder data + end) = struct + con all = [When = time] ++ M.key ++ map option M.data + table t : all + + val keys = List.mapQuery (SELECT DISTINCT t.{{M.key}} FROM t) (fn r => r.T) + + con dmeta = fn t => {Inj : sql_injectable_prim t, + Eq : eq t} + + fun keyRecd (r : $(M.key ++ M.data)) = + map2 [sql_injectable] [id] [sql_exp [] [] []] + (fn [t] => @sql_inject) + [_] M.keyFolder M.key (r --- M.data) + + fun insert r = dml (Basis.insert t + ({When = (SQL CURRENT_TIMESTAMP)} + ++ keyRecd r + ++ map2 [dmeta] [id] + [fn t => sql_exp [] [] [] (option t)] + (fn [t] x v => @sql_inject (@sql_option_prim x.Inj) + (Some v)) + [_] M.dataFolder M.data (r --- M.key))) + + fun keyExp (r : $M.key) : sql_exp [T = all] [] [] bool = + foldR2 [sql_injectable] [id] [fn before => after :: {Type} -> [before ~ after] + => sql_exp [T = before ++ after] [] [] bool] + (fn [nm :: Name] [t :: Type] [before :: {Type}] [[nm] ~ before] + (inj : sql_injectable t) (v : t) + (e : after :: {Type} -> [before ~ after] + => sql_exp [T = before ++ after] [] [] bool) + [after :: {Type}] [[nm = t] ++ before ~ after] => + (SQL t.{nm} = {[v]} AND {e [[nm = t] ++ after] !})) + (fn [after :: {Type}] [[] ~ after] => (SQL TRUE)) + [_] M.keyFolder M.key r + [_] ! + + fun current k = + let + fun current' timeOpt r = + let + val complete = foldR [option] [fn ts => option $ts] + (fn [nm :: Name] [v :: Type] [r :: {Type}] [[nm] ~ r] + v r => + case (v, r) of + (Some v, Some r) => Some ({nm = v} ++ r) + | _ => None) + (Some {}) [_] M.dataFolder r + in + case complete of + Some r => return (Some r) + | None => + let + val filter = case timeOpt of + None => (WHERE TRUE) + | Some time => (WHERE t.When < {[time]}) + in + ro <- oneOrNoRows (SELECT t.When, t.{{map option M.data}} + FROM t + WHERE {filter} + AND {keyExp k} + ORDER BY t.When DESC + LIMIT 1); + case ro of + None => return None + | Some r' => + let + val r = map2 [option] [option] [option] + (fn [t ::: Type] old new => + case old of + None => new + | Some _ => old) + [_] M.dataFolder r (r'.T -- #When) + in + current' (Some r'.T.When) r + end + end + end + in + current' None (map0 [option] (fn [t :: Type] => None : option t) [_] M.dataFolder) + end + + fun update r = + cur <- current (r --- M.data); + case cur of + None => error Tried to update nonexistent key + | Some cur => + let + val r' = map3 [dmeta] [id] [id] [fn t => sql_exp [] [] [] (option t)] + (fn [t] (meta : dmeta t) old new => + @sql_inject (@sql_option_prim meta.Inj) + (if @@eq [_] meta.Eq old new then + None + else + Some new)) + [_] M.dataFolder M.data cur (r --- M.key) + val r' = {When = (SQL CURRENT_TIMESTAMP)} + ++ keyRecd r + ++ r' + in + dml (Basis.insert t r') + end +end diff --git a/demo/more/versioned.urp b/demo/more/versioned.urp new file mode 100644 index 00000000..a75d6c6a --- /dev/null +++ b/demo/more/versioned.urp @@ -0,0 +1,4 @@ + +$/option +$/list +versioned diff --git a/demo/more/versioned.urs b/demo/more/versioned.urs new file mode 100644 index 00000000..eb0a485e --- /dev/null +++ b/demo/more/versioned.urs @@ -0,0 +1,19 @@ +functor Make(M : sig + con key :: {Type} + con data :: {Type} + constraint key ~ data + constraint [When] ~ (key ++ data) + + val key : $(map sql_injectable key) + val data : $(map (fn t => {Inj : sql_injectable_prim t, + Eq : eq t}) data) + + val keyFolder : folder key + val dataFolder : folder data + end) : sig + val insert : $(M.key ++ M.data) -> transaction unit + val update : $(M.key ++ M.data) -> transaction unit + + val keys : transaction (list $M.key) + val current : $M.key -> transaction (option $M.data) +end diff --git a/demo/more/versioned1.ur b/demo/more/versioned1.ur new file mode 100644 index 00000000..506d2778 --- /dev/null +++ b/demo/more/versioned1.ur @@ -0,0 +1,62 @@ +open Versioned.Make(struct + con key = [Id = int] + con data = [Nam = string, ShoeSize = int] + + val key = {Id = _} + val data = {Nam = {Inj = _, + Eq = _}, + ShoeSize = {Inj = _, + Eq = _}} + end) + +fun expandKey k = + name <- source ""; + shoeSize <- source ""; + return {Key = k, Nam = name, ShoeSize = shoeSize} + +fun main () = + ks0 <- keys; + ks0 <- List.mapM (fn r => expandKey r.Id) ks0; + ks <- source ks0; + + id <- source ""; + name <- source ""; + shoeSize <- source ""; + + return +
+ {[kr.Key]}: + + +
) ks)}/> + +

Add one:

+ + + + + + +
Id:
Name:
Shoe size:
+ diff --git a/demo/more/versioned1.urp b/demo/more/versioned1.urp new file mode 100644 index 00000000..c24b3531 --- /dev/null +++ b/demo/more/versioned1.urp @@ -0,0 +1,6 @@ +debug +library versioned +database dbname=test +sql versioned1.sql + +versioned1 diff --git a/demo/more/versioned1.urs b/demo/more/versioned1.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/demo/more/versioned1.urs @@ -0,0 +1 @@ +val main : unit -> transaction page diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index b7468d2f..9ddae8fe 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -291,7 +291,8 @@ val sql_query1 : tables ::: {{Type}} -> grouped ::: {{Type}} -> selectedFields ::: {{Type}} -> selectedExps ::: {Type} - -> {From : sql_from_items tables, + -> {Distinct : bool, + From : sql_from_items tables, Where : sql_exp tables [] [] bool, GroupBy : sql_subset tables grouped, Having : sql_exp grouped tables [] bool, diff --git a/lib/ur/top.ur b/lib/ur/top.ur index 67e75573..a2395d4f 100644 --- a/lib/ur/top.ur +++ b/lib/ur/top.ur @@ -92,6 +92,12 @@ fun read_option [t ::: Type] (_ : read t) = fun txt [t] [ctx ::: {Unit}] [use ::: {Type}] (_ : show t) (v : t) = cdata (show v) +fun map0 [K] [tf :: K -> Type] (f : t :: K -> tf t) [r :: {K}] (fl : folder r) = + fl [fn r :: {K} => $(map tf r)] + (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] acc => + acc ++ {nm = f [t]}) + {} + fun mp [K] [tf1 :: K -> Type] [tf2 :: K -> Type] (f : t ::: K -> tf1 t -> tf2 t) [r :: {K}] (fl : folder r) = fl [fn r :: {K} => $(map tf1 r) -> $(map tf2 r)] (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] acc r => diff --git a/lib/ur/top.urs b/lib/ur/top.urs index 637c4e5d..ef907760 100644 --- a/lib/ur/top.urs +++ b/lib/ur/top.urs @@ -45,6 +45,9 @@ val read_option : t ::: Type -> read t -> read (option t) val txt : t ::: Type -> ctx ::: {Unit} -> use ::: {Type} -> show t -> t -> xml ctx use [] +val map0 : K --> tf :: (K -> Type) + -> (t :: K -> tf t) + -> r :: {K} -> folder r -> $(map tf r) val mp : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> (t ::: K -> tf1 t -> tf2 t) -> r :: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r) diff --git a/src/cjrize.sml b/src/cjrize.sml index 6a79b4e6..bf814266 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -520,9 +520,14 @@ fun cifyDecl ((d, loc), sm) = in ((ax, dom) :: args, t, e) end - | (L'.TFun _, _) => - (ErrorMsg.errorAt loc "Function isn't explicit at code generation"; - ([], tAll, eAll)) + | (L'.TFun (dom, ran), _) => + let + val e = MonoEnv.liftExpInExp 0 eAll + val e = (L.EApp (e, (L.ERel 0, loc)), loc) + val (args, t, e) = unravel (ran, e) + in + (("x", dom) :: args, t, e) + end | _ => ([], tAll, eAll) val (args, ran, e) = unravel (t, e) diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el index 7f4b0dee..42846e6c 100644 --- a/src/elisp/urweb-mode.el +++ b/src/elisp/urweb-mode.el @@ -144,7 +144,7 @@ See doc for the variable `urweb-mode-info'." "A regexp that matches any non-SQL keywords of Ur/Web.") (defconst urweb-sql-keywords-regexp - (urweb-syms-re "SELECT" "FROM" "AS" "WHERE" "SQL" "GROUP" "ORDER" "BY" + (urweb-syms-re "SELECT" "DISTINCT" "FROM" "AS" "WHERE" "SQL" "GROUP" "ORDER" "BY" "HAVING" "LIMIT" "OFFSET" "ALL" "UNION" "INTERSECT" "EXCEPT" "TRUE" "FALSE" "AND" "OR" "NOT" "COUNT" "AVG" "SUM" "MIN" "MAX" "ASC" "DESC" "INSERT" "INTO" "VALUES" "UPDATE" "SET" "DELETE" diff --git a/src/mono_env.sig b/src/mono_env.sig index c59596ae..c5ca7c0b 100644 --- a/src/mono_env.sig +++ b/src/mono_env.sig @@ -48,5 +48,7 @@ signature MONO_ENV = sig val declBinds : env -> Mono.decl -> env val patBinds : env -> Mono.pat -> env val patBindsN : Mono.pat -> int + + val liftExpInExp : int -> Mono.exp -> Mono.exp end diff --git a/src/monoize.sml b/src/monoize.sml index b80b4a65..a01f953f 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1771,6 +1771,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = let fun sc s = (L'.EPrim (Prim.String s), loc) val s = (L'.TFfi ("Basis", "string"), loc) + val b = (L'.TFfi ("Basis", "bool"), loc) val un = (L'.TRecord [], loc) fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc) @@ -1806,7 +1807,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) sexps in ((L'.EAbs ("r", - (L'.TRecord [("From", s), + (L'.TRecord [("Distinct", b), + ("From", s), ("Where", s), ("GroupBy", un), ("Having", s), @@ -1815,6 +1817,22 @@ fun monoExp (env, st, fm) (all as (e, loc)) = loc), s, strcat [sc "SELECT ", + (L'.ECase (gf "Distinct", + [((L'.PCon (L'.Enum, + L'.PConFfi {mod = "Basis", + datatyp = "bool", + con = "True", + arg = NONE}, + NONE), loc), + (L'.EPrim (Prim.String "DISTINCT "), loc)), + ((L'.PCon (L'.Enum, + L'.PConFfi {mod = "Basis", + datatyp = "bool", + con = "False", + arg = NONE}, + NONE), loc), + (L'.EPrim (Prim.String ""), loc))], + {disc = b, result = s}), loc), strcatComma (map (fn (x, t) => strcat [ (L'.EField (gf "SelectExps", x), loc), diff --git a/src/urweb.grm b/src/urweb.grm index 111b1854..edd93d96 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -208,7 +208,7 @@ fun patType loc (p : pat) = | NOTAGS of string | BEGIN_TAG of string | END_TAG of string - | SELECT | FROM | AS | CWHERE | GROUP | ORDER | BY | HAVING + | SELECT | DISTINCT | FROM | AS | CWHERE | GROUP | ORDER | BY | HAVING | UNION | INTERSECT | EXCEPT | LIMIT | OFFSET | ALL | TRUE | FALSE | CAND | OR | NOT @@ -314,6 +314,7 @@ fun patType loc (p : pat) = | query of exp | query1 of exp + | dopt of exp | tables of con list * exp | fitem of con list * exp | tname of con @@ -625,7 +626,7 @@ pmodes : ([]) commaOpt: () | COMMA () -pkopt : (EVar (["Basis"], "no_primary_key", Infer), ErrorMsg.dummySpan) +pkopt : (EVar (["Basis"], "no_primary_key", Infer), dummy) | PRIMARY KEY tnames (let val loc = s (PRIMARYleft, tnamesright) @@ -1410,8 +1411,12 @@ query : query1 obopt lopt ofopt (let in (EApp ((EVar (["Basis"], "sql_query", Infer), loc), re), loc) end) - -query1 : SELECT select FROM tables wopt gopt hopt + +dopt : (EVar (["Basis"], "False", Infer), dummy) + | DISTINCT (EVar (["Basis"], "True", Infer), + s (DISTINCTleft, DISTINCTright)) + +query1 : SELECT dopt select FROM tables wopt gopt hopt (let val loc = s (SELECTleft, tablesright) @@ -1460,7 +1465,9 @@ query1 : SELECT select FROM tables wopt gopt hopt end val e = (EVar (["Basis"], "sql_query1", Infer), loc) - val re = (ERecord [((CName "From", loc), + val re = (ERecord [((CName "Distinct", loc), + dopt), + ((CName "From", loc), #2 tables), ((CName "Where", loc), wopt), diff --git a/src/urweb.lex b/src/urweb.lex index 38816a3c..4e572009 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -408,6 +408,7 @@ notags = [^<{\n]+; "Unit" => (Tokens.KUNIT (pos yypos, pos yypos + size yytext)); "SELECT" => (Tokens.SELECT (pos yypos, pos yypos + size yytext)); + "DISTINCT" => (Tokens.DISTINCT (pos yypos, pos yypos + size yytext)); "FROM" => (Tokens.FROM (pos yypos, pos yypos + size yytext)); "AS" => (Tokens.AS (pos yypos, pos yypos + size yytext)); "WHERE" => (Tokens.CWHERE (pos yypos, pos yypos + size yytext)); -- cgit v1.2.3 From 5ec949e910342f6212c85c8df75283d091817408 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 15 Jan 2011 14:53:13 -0500 Subject: Allow subqueries to reference aggregate-only columns of free tables; treat non-COUNT aggregate functions as possibly returning NULL --- lib/ur/basis.urs | 54 ++++++++++++++++++++++++--------------------- lib/ur/list.ur | 6 ++--- lib/ur/list.urs | 6 ++--- lib/ur/top.ur | 36 +++++++++++++++--------------- lib/ur/top.urs | 36 +++++++++++++++--------------- src/compiler.sml | 10 +++++++-- src/mono_env.sig | 3 ++- src/mono_env.sml | 13 +++++++++++ src/mono_reduce.sml | 39 +++++++++++++++++++++------------ src/monoize.sml | 63 ++++++++++++++++++++++------------------------------- 10 files changed, 145 insertions(+), 121 deletions(-) (limited to 'src/mono_env.sig') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index a91fd498..8ca2e81c 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -291,8 +291,8 @@ val check : fs ::: {Type} (*** Queries *) -con sql_query :: {{Type}} -> {{Type}} -> {Type} -> Type -con sql_query1 :: {{Type}} -> {{Type}} -> {{Type}} -> {Type} -> Type +con sql_query :: {{Type}} -> {{Type}} -> {{Type}} -> {Type} -> Type +con sql_query1 :: {{Type}} -> {{Type}} -> {{Type}} -> {{Type}} -> {Type} -> Type con sql_subset :: {{Type}} -> {{Type}} -> Type val sql_subset : keep_drop :: {({Type} * {Type})} @@ -314,7 +314,7 @@ val sql_from_table : free ::: {{Type}} -> t ::: Type -> fs ::: {Type} -> fieldsOf t fs -> name :: Name -> t -> sql_from_items free [name = fs] val sql_from_query : free ::: {{Type}} -> fs ::: {Type} -> name :: Name - -> sql_query free [] fs + -> sql_query free [] [] fs -> sql_from_items free [name = fs] val sql_from_comma : free ::: {{Type}} -> tabs1 ::: {{Type}} -> tabs2 ::: {{Type}} -> [tabs1 ~ tabs2] @@ -353,6 +353,7 @@ val sql_full_join : free ::: {{Type}} -> tabs1 ::: {{(Type * Type)}} -> tabs2 :: -> sql_from_items free (map (map (fn p :: (Type * Type) => p.2)) (tabs1 ++ tabs2)) val sql_query1 : free ::: {{Type}} + -> afree ::: {{Type}} -> tables ::: {{Type}} -> grouped ::: {{Type}} -> selectedFields ::: {{Type}} @@ -360,33 +361,35 @@ val sql_query1 : free ::: {{Type}} -> empties :: {Unit} -> [free ~ tables] => [free ~ grouped] + => [afree ~ tables] => [empties ~ selectedFields] => {Distinct : bool, From : sql_from_items free tables, - Where : sql_exp (free ++ tables) [] [] bool, + Where : sql_exp (free ++ tables) afree [] bool, GroupBy : sql_subset tables grouped, - Having : sql_exp (free ++ grouped) tables [] bool, + Having : sql_exp (free ++ grouped) (afree ++ tables) [] bool, SelectFields : sql_subset grouped (map (fn _ => []) empties ++ selectedFields), - SelectExps : $(map (sql_exp (free ++ grouped) tables []) + SelectExps : $(map (sql_exp (free ++ grouped) (afree ++ tables) []) selectedExps) } - -> sql_query1 free tables selectedFields selectedExps + -> sql_query1 free afree tables selectedFields selectedExps type sql_relop val sql_union : sql_relop val sql_intersect : sql_relop val sql_except : sql_relop val sql_relop : free ::: {{Type}} + -> afree ::: {{Type}} -> tables1 ::: {{Type}} -> tables2 ::: {{Type}} -> selectedFields ::: {{Type}} -> selectedExps ::: {Type} -> sql_relop - -> sql_query1 free tables1 selectedFields selectedExps - -> sql_query1 free tables2 selectedFields selectedExps - -> sql_query1 free [] selectedFields selectedExps -val sql_forget_tables : free ::: {{Type}} -> tables ::: {{Type}} -> selectedFields ::: {{Type}} -> selectedExps ::: {Type} - -> sql_query1 free tables selectedFields selectedExps - -> sql_query1 free [] selectedFields selectedExps + -> sql_query1 free afree tables1 selectedFields selectedExps + -> sql_query1 free afree tables2 selectedFields selectedExps + -> sql_query1 free afree [] selectedFields selectedExps +val sql_forget_tables : free ::: {{Type}} -> afree ::: {{Type}} -> tables ::: {{Type}} -> selectedFields ::: {{Type}} -> selectedExps ::: {Type} + -> sql_query1 free afree tables selectedFields selectedExps + -> sql_query1 free afree [] selectedFields selectedExps type sql_direction val sql_asc : sql_direction @@ -408,15 +411,16 @@ val sql_no_offset : sql_offset val sql_offset : int -> sql_offset val sql_query : free ::: {{Type}} + -> afree ::: {{Type}} -> tables ::: {{Type}} -> selectedFields ::: {{Type}} -> selectedExps ::: {Type} -> [free ~ tables] - => {Rows : sql_query1 free tables selectedFields selectedExps, + => {Rows : sql_query1 free afree tables selectedFields selectedExps, OrderBy : sql_order_by (free ++ tables) selectedExps, Limit : sql_limit, Offset : sql_offset} - -> sql_query free selectedFields selectedExps + -> sql_query free afree selectedFields selectedExps val sql_field : otherTabs ::: {{Type}} -> otherFields ::: {Type} -> fieldType ::: Type -> agg ::: {{Type}} @@ -493,8 +497,8 @@ class sql_summable val sql_summable_int : sql_summable int val sql_summable_float : sql_summable float val sql_summable_option : t ::: Type -> sql_summable t -> sql_summable (option t) -val sql_avg : t ::: Type -> sql_summable t -> sql_aggregate t t -val sql_sum : t ::: Type -> sql_summable t -> sql_aggregate t t +val sql_avg : t ::: Type -> nt ::: Type -> sql_summable t -> nullify t nt -> sql_aggregate t nt +val sql_sum : t ::: Type -> nt ::: Type -> sql_summable t -> nullify t nt -> sql_aggregate t nt class sql_maxable val sql_maxable_int : sql_maxable int @@ -502,8 +506,8 @@ val sql_maxable_float : sql_maxable float val sql_maxable_string : sql_maxable string val sql_maxable_time : sql_maxable time val sql_maxable_option : t ::: Type -> sql_maxable t -> sql_maxable (option t) -val sql_max : t ::: Type -> sql_maxable t -> sql_aggregate t t -val sql_min : t ::: Type -> sql_maxable t -> sql_aggregate t t +val sql_max : t ::: Type -> nt ::: Type -> sql_maxable t -> nullify t nt -> sql_aggregate t nt +val sql_min : t ::: Type -> nt ::: Type -> sql_maxable t -> nullify t nt -> sql_aggregate t nt con sql_nfunc :: Type -> Type val sql_nfunc : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} @@ -526,7 +530,7 @@ val sql_nullable : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> -> sql_exp tables agg exps (option t) val sql_subquery : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> nm ::: Name -> t ::: Type - -> sql_query tables [] [nm = t] + -> sql_query tables agg [] [nm = t] -> sql_exp tables agg exps t (*** Executing queries *) @@ -534,7 +538,7 @@ val sql_subquery : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> val query : tables ::: {{Type}} -> exps ::: {Type} -> [tables ~ exps] => state ::: Type - -> sql_query [] tables exps + -> sql_query [] [] tables exps -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) -> state -> transaction state) @@ -838,21 +842,21 @@ val periodic : int -> task_kind unit type sql_policy val sendClient : tables ::: {{Type}} -> exps ::: {Type} - -> [tables ~ exps] => sql_query [] tables exps + -> [tables ~ exps] => sql_query [] [] tables exps -> sql_policy val sendOwnIds : sql_sequence -> sql_policy val mayInsert : fs ::: {Type} -> tables ::: {{Type}} -> [[New] ~ tables] - => sql_query [] ([New = fs] ++ tables) [] + => sql_query [] [] ([New = fs] ++ tables) [] -> sql_policy val mayDelete : fs ::: {Type} -> tables ::: {{Type}} -> [[Old] ~ tables] - => sql_query [] ([Old = fs] ++ tables) [] + => sql_query [] [] ([Old = fs] ++ tables) [] -> sql_policy val mayUpdate : fs ::: {Type} -> tables ::: {{Type}} -> [[Old, New] ~ tables] - => sql_query [] ([Old = fs, New = fs] ++ tables) [] + => sql_query [] [] ([Old = fs, New = fs] ++ tables) [] -> sql_policy val also : sql_policy -> sql_policy -> sql_policy diff --git a/lib/ur/list.ur b/lib/ur/list.ur index 3153cc32..d0c2e7a1 100644 --- a/lib/ur/list.ur +++ b/lib/ur/list.ur @@ -254,7 +254,7 @@ fun app [m] (_ : monad m) [a] f = end fun mapQuery [tables ::: {{Type}}] [exps ::: {Type}] [t ::: Type] - [tables ~ exps] (q : sql_query [] tables exps) + [tables ~ exps] (q : sql_query [] [] tables exps) (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) -> t) = ls <- query q (fn fs acc => return (f fs :: acc)) @@ -262,7 +262,7 @@ fun mapQuery [tables ::: {{Type}}] [exps ::: {Type}] [t ::: Type] return (rev ls) fun mapQueryM [tables ::: {{Type}}] [exps ::: {Type}] [t ::: Type] - [tables ~ exps] (q : sql_query [] tables exps) + [tables ~ exps] (q : sql_query [] [] tables exps) (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) -> transaction t) = ls <- query q (fn fs acc => v <- f fs; return (v :: acc)) @@ -270,7 +270,7 @@ fun mapQueryM [tables ::: {{Type}}] [exps ::: {Type}] [t ::: Type] return (rev ls) fun mapQueryPartialM [tables ::: {{Type}}] [exps ::: {Type}] [t ::: Type] - [tables ~ exps] (q : sql_query [] tables exps) + [tables ~ exps] (q : sql_query [] [] tables exps) (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) -> transaction (option t)) = ls <- query q (fn fs acc => v <- f fs; diff --git a/lib/ur/list.urs b/lib/ur/list.urs index 9ad738f1..8284510d 100644 --- a/lib/ur/list.urs +++ b/lib/ur/list.urs @@ -53,19 +53,19 @@ val app : m ::: (Type -> Type) -> monad m -> a ::: Type val mapQuery : tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type -> [tables ~ exps] => - sql_query [] tables exps + sql_query [] [] tables exps -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) -> t) -> transaction (list t) val mapQueryM : tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type -> [tables ~ exps] => - sql_query [] tables exps + sql_query [] [] tables exps -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) -> transaction t) -> transaction (list t) val mapQueryPartialM : tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type -> [tables ~ exps] => - sql_query [] tables exps + sql_query [] [] tables exps -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) -> transaction (option t)) -> transaction (list t) diff --git a/lib/ur/top.ur b/lib/ur/top.ur index 83d5b6af..0fdbae7a 100644 --- a/lib/ur/top.ur +++ b/lib/ur/top.ur @@ -215,40 +215,40 @@ fun mapX3 [K] [tf1 :: K -> Type] [tf2 :: K -> Type] [tf3 :: K -> Type] [ctx :: { {f [nm] [t] [rest] ! r1 r2 r3}{acc}) -fun query1 [t ::: Name] [fs ::: {Type}] [state ::: Type] (q : sql_query [] [t = fs] []) +fun query1 [t ::: Name] [fs ::: {Type}] [state ::: Type] (q : sql_query [] [] [t = fs] []) (f : $fs -> state -> transaction state) (i : state) = query q (fn r => f r.t) i -fun query1' [t ::: Name] [fs ::: {Type}] [state ::: Type] (q : sql_query [] [t = fs] []) +fun query1' [t ::: Name] [fs ::: {Type}] [state ::: Type] (q : sql_query [] [] [t = fs] []) (f : $fs -> state -> state) (i : state) = query q (fn r s => return (f r.t s)) i -fun queryL [tables] [exps] [tables ~ exps] (q : sql_query [] tables exps) = +fun queryL [tables] [exps] [tables ~ exps] (q : sql_query [] [] tables exps) = query q (fn r ls => return (r :: ls)) [] -fun queryL1 [t ::: Name] [fs ::: {Type}] (q : sql_query [] [t = fs] []) = +fun queryL1 [t ::: Name] [fs ::: {Type}] (q : sql_query [] [] [t = fs] []) = query q (fn r ls => return (r.t :: ls)) [] fun queryI [tables ::: {{Type}}] [exps ::: {Type}] - [tables ~ exps] (q : sql_query [] tables exps) + [tables ~ exps] (q : sql_query [] [] tables exps) (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) -> transaction unit) = query q (fn fs _ => f fs) () -fun queryI1 [nm ::: Name] [fs ::: {Type}] (q : sql_query [] [nm = fs] []) +fun queryI1 [nm ::: Name] [fs ::: {Type}] (q : sql_query [] [] [nm = fs] []) (f : $fs -> transaction unit) = query q (fn fs _ => f fs.nm) () fun queryX [tables ::: {{Type}}] [exps ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}] - [tables ~ exps] (q : sql_query [] tables exps) + [tables ~ exps] (q : sql_query [] [] tables exps) (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) -> xml ctx inp []) = query q @@ -256,14 +256,14 @@ fun queryX [tables ::: {{Type}}] [exps ::: {Type}] [ctx ::: {Unit}] [inp ::: {Ty fun queryX1 [nm ::: Name] [fs ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}] - (q : sql_query [] [nm = fs] []) + (q : sql_query [] [] [nm = fs] []) (f : $fs -> xml ctx inp []) = query q (fn fs acc => return {acc}{f fs.nm}) fun queryX' [tables ::: {{Type}}] [exps ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}] - [tables ~ exps] (q : sql_query [] tables exps) + [tables ~ exps] (q : sql_query [] [] tables exps) (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) -> transaction (xml ctx inp [])) = query q @@ -273,7 +273,7 @@ fun queryX' [tables ::: {{Type}}] [exps ::: {Type}] [ctx ::: {Unit}] [inp ::: {T fun queryX1' [nm ::: Name] [fs ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}] - (q : sql_query [] [nm = fs] []) + (q : sql_query [] [] [nm = fs] []) (f : $fs -> transaction (xml ctx inp [])) = query q (fn fs acc => @@ -282,7 +282,7 @@ fun queryX1' [nm ::: Name] [fs ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}] fun queryXE' [exps ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}] - (q : sql_query [] [] exps) + (q : sql_query [] [] [] exps) (f : $exps -> transaction (xml ctx inp [])) = query q (fn fs acc => @@ -292,42 +292,42 @@ fun queryXE' [exps ::: {Type}] [ctx ::: {Unit}] [inp ::: {Type}] fun hasRows [tables ::: {{Type}}] [exps ::: {Type}] [tables ~ exps] - (q : sql_query [] tables exps) = + (q : sql_query [] [] tables exps) = query q (fn _ _ => return True) False fun oneOrNoRows [tables ::: {{Type}}] [exps ::: {Type}] [tables ~ exps] - (q : sql_query [] tables exps) = + (q : sql_query [] [] tables exps) = query q (fn fs _ => return (Some fs)) None -fun oneOrNoRows1 [nm ::: Name] [fs ::: {Type}] (q : sql_query [] [nm = fs] []) = +fun oneOrNoRows1 [nm ::: Name] [fs ::: {Type}] (q : sql_query [] [] [nm = fs] []) = query q (fn fs _ => return (Some fs.nm)) None -fun oneOrNoRowsE1 [tabs ::: {Unit}] [nm ::: Name] [t ::: Type] [tabs ~ [nm]] (q : sql_query [] (mapU [] tabs) [nm = t]) = +fun oneOrNoRowsE1 [tabs ::: {Unit}] [nm ::: Name] [t ::: Type] [tabs ~ [nm]] (q : sql_query [] [] (mapU [] tabs) [nm = t]) = query q (fn fs _ => return (Some fs.nm)) None fun oneRow [tables ::: {{Type}}] [exps ::: {Type}] - [tables ~ exps] (q : sql_query [] tables exps) = + [tables ~ exps] (q : sql_query [] [] tables exps) = o <- oneOrNoRows q; return (case o of None => error Query returned no rows | Some r => r) -fun oneRow1 [nm ::: Name] [fs ::: {Type}] (q : sql_query [] [nm = fs] []) = +fun oneRow1 [nm ::: Name] [fs ::: {Type}] (q : sql_query [] [] [nm = fs] []) = o <- oneOrNoRows q; return (case o of None => error Query returned no rows | Some r => r.nm) -fun oneRowE1 [tabs ::: {Unit}] [nm ::: Name] [t ::: Type] [tabs ~ [nm]] (q : sql_query [] (mapU [] tabs) [nm = t]) = +fun oneRowE1 [tabs ::: {Unit}] [nm ::: Name] [t ::: Type] [tabs ~ [nm]] (q : sql_query [] [] (mapU [] tabs) [nm = t]) = o <- oneOrNoRows q; return (case o of None => error Query returned no rows diff --git a/lib/ur/top.urs b/lib/ur/top.urs index d86ae553..ed3b4c14 100644 --- a/lib/ur/top.urs +++ b/lib/ur/top.urs @@ -126,100 +126,100 @@ val mapX3 : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> tf3 :: (K -> Type) val queryL : tables ::: {{Type}} -> exps ::: {Type} -> [tables ~ exps] => - sql_query [] tables exps + sql_query [] [] tables exps -> transaction (list $(exps ++ map (fn fields :: {Type} => $fields) tables)) val queryL1 : t ::: Name -> fs ::: {Type} - -> sql_query [] [t = fs] [] + -> sql_query [] [] [t = fs] [] -> transaction (list $fs) val query1 : t ::: Name -> fs ::: {Type} -> state ::: Type - -> sql_query [] [t = fs] [] + -> sql_query [] [] [t = fs] [] -> ($fs -> state -> transaction state) -> state -> transaction state val query1' : t ::: Name -> fs ::: {Type} -> state ::: Type - -> sql_query [] [t = fs] [] + -> sql_query [] [] [t = fs] [] -> ($fs -> state -> state) -> state -> transaction state val queryI : tables ::: {{Type}} -> exps ::: {Type} -> [tables ~ exps] => - sql_query [] tables exps + sql_query [] [] tables exps -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) -> transaction unit) -> transaction unit val queryI1 : nm ::: Name -> fs ::: {Type} - -> sql_query [] [nm = fs] [] + -> sql_query [] [] [nm = fs] [] -> ($fs -> transaction unit) -> transaction unit val queryX : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit} -> inp ::: {Type} -> [tables ~ exps] => - sql_query [] tables exps + sql_query [] [] tables exps -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) -> xml ctx inp []) -> transaction (xml ctx inp []) val queryX1 : nm ::: Name -> fs ::: {Type} -> ctx ::: {Unit} -> inp ::: {Type} - -> sql_query [] [nm = fs] [] + -> sql_query [] [] [nm = fs] [] -> ($fs -> xml ctx inp []) -> transaction (xml ctx inp []) val queryX' : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit} -> inp ::: {Type} -> [tables ~ exps] => - sql_query [] tables exps + sql_query [] [] tables exps -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) -> transaction (xml ctx inp [])) -> transaction (xml ctx inp []) val queryX1' : nm ::: Name -> fs ::: {Type} -> ctx ::: {Unit} -> inp ::: {Type} - -> sql_query [] [nm = fs] [] + -> sql_query [] [] [nm = fs] [] -> ($fs -> transaction (xml ctx inp [])) -> transaction (xml ctx inp []) val queryXE' : exps ::: {Type} -> ctx ::: {Unit} -> inp ::: {Type} - -> sql_query [] [] exps + -> sql_query [] [] [] exps -> ($exps -> transaction (xml ctx inp [])) -> transaction (xml ctx inp []) val hasRows : tables ::: {{Type}} -> exps ::: {Type} -> [tables ~ exps] => - sql_query [] tables exps + sql_query [] [] tables exps -> transaction bool val oneOrNoRows : tables ::: {{Type}} -> exps ::: {Type} -> [tables ~ exps] => - sql_query [] tables exps + sql_query [] [] tables exps -> transaction (option $(exps ++ map (fn fields :: {Type} => $fields) tables)) val oneOrNoRows1 : nm ::: Name -> fs ::: {Type} - -> sql_query [] [nm = fs] [] + -> sql_query [] [] [nm = fs] [] -> transaction (option $fs) val oneOrNoRowsE1 : tabs ::: {Unit} -> nm ::: Name -> t ::: Type -> [tabs ~ [nm]] => - sql_query [] (mapU [] tabs) [nm = t] + sql_query [] [] (mapU [] tabs) [nm = t] -> transaction (option t) val oneRow : tables ::: {{Type}} -> exps ::: {Type} -> [tables ~ exps] => - sql_query [] tables exps + sql_query [] [] tables exps -> transaction $(exps ++ map (fn fields :: {Type} => $fields) tables) val oneRow1 : nm ::: Name -> fs ::: {Type} - -> sql_query [] [nm = fs] [] + -> sql_query [] [] [nm = fs] [] -> transaction $fs val oneRowE1 : tabs ::: {Unit} -> nm ::: Name -> t ::: Type -> [tabs ~ [nm]] => - sql_query [] (mapU [] tabs) [nm = t] + sql_query [] [] (mapU [] tabs) [nm = t] -> transaction t val nonempty : fs ::: {Type} -> us ::: {{Unit}} -> sql_table fs us diff --git a/src/compiler.sml b/src/compiler.sml index c8bb036a..61fa23b1 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1311,9 +1311,15 @@ fun compileC {cname, oname, ename, libs, profile, debug, link = link'} = (compile, link) val link = foldl (fn (s, link) => link ^ " " ^ s) link link' + + fun system s = + (if debug then + print (s ^ "\n") + else + (); + OS.Process.isSuccess (OS.Process.system s)) in - OS.Process.isSuccess (OS.Process.system compile) - andalso OS.Process.isSuccess (OS.Process.system link) + system compile andalso system link end fun compile job = diff --git a/src/mono_env.sig b/src/mono_env.sig index c5ca7c0b..97d7d9ea 100644 --- a/src/mono_env.sig +++ b/src/mono_env.sig @@ -50,5 +50,6 @@ signature MONO_ENV = sig val patBindsN : Mono.pat -> int val liftExpInExp : int -> Mono.exp -> Mono.exp - + val subExpInExp : (int * Mono.exp) -> Mono.exp -> Mono.exp + end diff --git a/src/mono_env.sml b/src/mono_env.sml index 1df38db3..7f9a6e62 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -85,6 +85,19 @@ val liftExpInExp = bind = fn (bound, U.Exp.RelE _) => bound + 1 | (bound, _) => bound} +val subExpInExp = + U.Exp.mapB {typ = fn t => t, + exp = fn (xn, rep) => fn e => + case e of + ERel xn' => + (case Int.compare (xn', xn) of + EQUAL => #1 rep + | GREATER=> ERel (xn' - 1) + | LESS => e) + | _ => e, + bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep) + | (ctx, _) => ctx} + fun pushERel (env : env) x t eo = {datatypes = #datatypes env, constructors = #constructors env, diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index e61ed237..82d0a63d 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -57,7 +57,6 @@ fun simpleImpure (tsyms, syms) = | ERecv _ => true | ESleep _ => true | ENamed n => IS.member (syms, n) - | EError _ => true | ERel n => let val (_, t, _) = E.lookupERel env n @@ -398,7 +397,10 @@ fun reduce file = summarize d e @ [ReadCookie] | EFfiApp (m, x, es) => if Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x) then - List.concat (map (summarize d) es) @ [Unsure] + List.concat (map (summarize d) es) @ [if m = "Basis" andalso String.isSuffix "_w" x then + WritePage + else + Unsure] else List.concat (map (summarize d) es) | EApp ((EFfi _, _), e) => summarize d e @@ -429,6 +431,7 @@ fun reduce file = | EApp (f, x) => unravel (#1 f, passed + 1, List.revAppend (summarize d x, ls)) + | EError _ => [Abort] | _ => [Unsure] in unravel (e, 0, []) @@ -445,17 +448,25 @@ fun reduce file = | ECase (e, pes, _) => let val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes + + fun splitRel ls acc = + case ls of + [] => (acc, false, ls) + | UseRel :: ls => (acc, true, ls) + | v :: ls => splitRel ls (v :: acc) + + val (pre, used, post) = foldl (fn (ls, (pre, used, post)) => + let + val (pre', used', post') = splitRel ls [] + in + (pre' @ pre, used' orelse used, post' @ post) + end) + ([], false, []) lss in - case lss of - [] => summarize d e - | ls :: lss => - summarize d e - @ (if List.all (fn ls' => ls' = ls) lss then - ls - else if length (List.filter (not o List.null) (ls :: lss)) <= 1 then - valOf (List.find (not o List.null) (ls :: lss)) - else - [Unsure]) + summarize d e + @ pre + @ (if used then [UseRel] else []) + @ post end | EStrcat (e1, e2) => summarize d e1 @ summarize d e2 @@ -534,8 +545,8 @@ fun reduce file = val effs_e' = List.filter (fn x => x <> UseRel) effs_e' val effs_b = summarize 0 b - (*val () = Print.prefaces "Try" - [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)), + (*val () = Print.fprefaces outf "Try" + [(*("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),*) ("e'", MonoPrint.p_exp env e'), ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), ("e'_eff", p_events effs_e'), diff --git a/src/monoize.sml b/src/monoize.sml index 30dfdd46..4295811a 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -236,9 +236,9 @@ fun monoType env = (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "sql_sequence") => (L'.TFfi ("Basis", "string"), loc) - | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query"), _), _), _), _), _), _) => + | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query"), _), _), _), _), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) - | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query1"), _), _), _), _), _), _), _), _) => + | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query1"), _), _), _), _), _), _), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_from_items"), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) @@ -1908,7 +1908,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = end | _ => poly ()) - | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_query"), _), _), _), _), _), _), _), _) => + | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_query"), _), _), _), _), _), _), _), _), _), _) => let fun sc s = (L'.EPrim (Prim.String s), loc) val s = (L'.TFfi ("Basis", "string"), loc) @@ -1934,7 +1934,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.ECApp ( (L.ECApp ( (L.ECApp ( - (L.EFfi ("Basis", "sql_query1"), _), + (L.ECApp ( + (L.EFfi ("Basis", "sql_query1"), _), + _), _), _), _), (L.CRecord (_, tables), _)), _), (L.CRecord (_, grouped), _)), _), @@ -2592,7 +2594,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.ECApp ( (L.ECApp ( (L.ECApp ( - (L.EFfi ("Basis", "sql_forget_tables"), _), + (L.ECApp ( + (L.EFfi ("Basis", "sql_forget_tables"), _), + _), _), _), _), _), _), _), _), @@ -2625,7 +2629,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.EFfi ("Basis", "sql_count"), _), _), _), _), _), - _) => ((L'.EPrim (Prim.String "COALESCE(COUNT(*),0)"), loc), + _) => ((L'.EPrim (Prim.String "COUNT(*)"), loc), fm) | L.ECApp ( @@ -2640,18 +2644,6 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _), _), t) => let - val default = - case #1 t of - L.CFfi ("Basis", s) => - SOME (case s of - "int" => "0" - | "float" => "0.0" - | "string" => "''" - | "time" => "0" - | _ => raise Fail "Illegal type of sql_aggregate [1]") - | L.CApp ((L.CFfi ("Basis", "option"), _), _) => NONE - | _ => raise Fail "Illegal type of sql_aggregate [2]" - val s = (L'.TFfi ("Basis", "string"), loc) fun sc s = (L'.EPrim (Prim.String s), loc) @@ -2659,13 +2651,6 @@ fun monoExp (env, st, fm) (all as (e, loc)) = sc "(", (L'.ERel 0, loc), sc ")"] - - val main = case default of - NONE => main - | SOME default => - strcat [sc "COALESCE(", - main, - sc ("," ^ default ^ ")")] in ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), main), loc)), loc), @@ -2682,13 +2667,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), (L'.ERecord [], loc)), loc), fm) - | L.ECApp ((L.EFfi ("Basis", "sql_avg"), _), _) => - ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "AVG"), loc)), loc), + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_avg"), _), _), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc), + (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EPrim (Prim.String "AVG"), loc)), loc)), loc), fm) - | L.ECApp ((L.EFfi ("Basis", "sql_sum"), _), _) => - ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "SUM"), loc)), loc), + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_sum"), _), _), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc), + (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EPrim (Prim.String "SUM"), loc)), loc)), loc), fm) | L.EFfi ("Basis", "sql_arith_int") => ((L'.ERecord [], loc), fm) @@ -2701,13 +2688,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), (L'.ERecord [], loc)), loc), fm) - | L.ECApp ((L.EFfi ("Basis", "sql_max"), _), _) => - ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "MAX"), loc)), loc), + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_max"), _), _), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc), + (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EPrim (Prim.String "MAX"), loc)), loc)), loc), fm) - | L.ECApp ((L.EFfi ("Basis", "sql_min"), _), _) => - ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "MIN"), loc)), loc), + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_min"), _), _), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc), + (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EPrim (Prim.String "MIN"), loc)), loc)), loc), fm) | L.EFfi ("Basis", "sql_asc") => ((L'.EPrim (Prim.String ""), loc), fm) -- cgit v1.2.3 From f8d7c70d8f52003e14a66144a48bb4f06a1c185f Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Sun, 27 Sep 2015 03:52:14 -0400 Subject: Pure caching sort of works. --- src/mono_env.sig | 4 +- src/mono_env.sml | 4 +- src/mono_fooify.sig | 9 ++- src/mono_fooify.sml | 56 ++++++++++++------ src/monoize.sml | 7 ++- src/sqlcache.sml | 162 +++++++++++++++++++++++++++++++++++++--------------- 6 files changed, 166 insertions(+), 76 deletions(-) (limited to 'src/mono_env.sig') diff --git a/src/mono_env.sig b/src/mono_env.sig index 97d7d9ea..9805c0d1 100644 --- a/src/mono_env.sig +++ b/src/mono_env.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 @@ -42,6 +42,8 @@ signature MONO_ENV = sig val pushERel : env -> string -> Mono.typ -> Mono.exp option -> env val lookupERel : env -> int -> string * Mono.typ * Mono.exp option + val typeContext : env -> Mono.typ list + val pushENamed : env -> string -> int -> Mono.typ -> Mono.exp option -> string -> env val lookupENamed : env -> int -> string * Mono.typ * Mono.exp option * string diff --git a/src/mono_env.sml b/src/mono_env.sml index 7f9a6e62..8617425e 100644 --- a/src/mono_env.sml +++ b/src/mono_env.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 @@ -108,6 +108,8 @@ fun lookupERel (env : env) n = (List.nth (#relE env, n)) handle Subscript => raise UnboundRel n +fun typeContext (env : env) = map #2 (#relE env) + fun pushENamed (env : env) x n t eo s = {datatypes = #datatypes env, constructors = #constructors env, diff --git a/src/mono_fooify.sig b/src/mono_fooify.sig index 9eb8038b..ef8f09c2 100644 --- a/src/mono_fooify.sig +++ b/src/mono_fooify.sig @@ -19,9 +19,6 @@ structure Fm : sig val decls : t -> Mono.decl list val freshName : t -> int * t - - (* Set at the end of [Monoize]. *) - val canonical : t ref end (* General form used in [Monoize]. *) @@ -32,7 +29,9 @@ val fooifyExp : foo_kind -> Mono.exp * Mono.typ -> Mono.exp * Fm.t -(* Easy-to-use special case used in [Sqlcache]. *) -val urlify : MonoEnv.env -> Mono.exp * Mono.typ -> Mono.exp +(* 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 +val getNewFmDecls : unit -> Mono.decl list end diff --git a/src/mono_fooify.sml b/src/mono_fooify.sml index d7cb9f59..2e32b248 100644 --- a/src/mono_fooify.sml +++ b/src/mono_fooify.sml @@ -1,4 +1,4 @@ -structure MonoFooify :> MONO_FOOIFY = struct +structure MonoFooify (* :> MONO_FOOIFY *) = struct open Mono @@ -112,9 +112,6 @@ fun lookupList (t as {count, map, listMap, decls}) k tp thunk = | SOME n' => (t, n') end -(* Has to be set at the end of [Monoize]. *) -val canonical = ref (empty 0 : t) - end fun fk2s fk = @@ -166,7 +163,12 @@ fun fooifyExp fk lookupENamed lookupDatatype = | _ => case t of TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) - | TFfi (m, x) => ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm) + | TFfi (m, x) => (if Settings.mayClientToServer (m, x) + (* TODO: better error message. (Then again, user should never see this.) *) + then () + else (E.errorAt loc "MonoFooify: can't pass type from client to server"; + Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]); + ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm)) | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) | TRecord ((x, t) :: xts) => @@ -296,22 +298,38 @@ fun fooifyExp fk lookupENamed lookupDatatype = fooify end +(* Has to be set at the end of [Monoize]. *) +val canonicalFm = ref (Fm.empty 0 : Fm.t) + fun urlify env expTyp = + if ErrorMsg.anyErrors () + then ((* DEBUG *) print "already error"; NONE) + else + let + val (exp, fm) = + fooifyExp + Url + (fn n => + let + val (_, t, _, s) = MonoEnv.lookupENamed env n + in + (t, s) + end) + (fn n => MonoEnv.lookupDatatype env n) + (!canonicalFm) + expTyp + in + if ErrorMsg.anyErrors () + then ((* DEBUG *) print "why"; (ErrorMsg.resetErrors (); NONE)) + else (canonicalFm := fm; SOME exp) + end + +fun getNewFmDecls () = let - val (exp, fm) = - fooifyExp - Url - (fn n => - let - val (_, t, _, s) = MonoEnv.lookupENamed env n - in - (t, s) - end) - (fn n => MonoEnv.lookupDatatype env n) - (!Fm.canonical) - expTyp + val fm = !canonicalFm in - Fm.canonical := fm; - exp + (* canonicalFm := Fm.enter fm; *) + Fm.decls fm end + end diff --git a/src/monoize.sml b/src/monoize.sml index 8f6b298d..4208f594 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -4484,13 +4484,14 @@ fun monoize env file = (L'.DDatatype (dts @ !pvarDefs), loc) :: Fm.decls fm @ ds | _ => ds' @ Fm.decls fm @ (L'.DDatatype (!pvarDefs), loc) :: ds))) - (env, Fm.empty mname, []) file + (env, Fm.empty mname, []) file + val monoFile = (rev ds, []) in pvars := RM.empty; pvarDefs := []; pvarOldDefs := []; - Fm.canonical := fm; - (rev ds, []) + MonoFooify.canonicalFm := Fm.empty (MonoUtil.File.maxName monoFile); + monoFile end end diff --git a/src/sqlcache.sml b/src/sqlcache.sml index 6b4216ea..eaa94685 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -493,27 +493,34 @@ fun incRels inc = bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound} 0 -fun cacheWrap (env, query, i, resultTyp, args) = +fun cacheWrap (env, exp, resultTyp, args, i) = let - val () = ffiInfo := {index = i, params = length args} :: !ffiInfo val loc = dummyLoc val rel0 = (ERel 0, loc) - (* 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), dummyLoc) - val store = (store (i, argsInc, MonoFooify.urlify env (rel0, resultTyp)), dummyLoc) in - ECase (check, - [((PNone stringTyp, loc), - (ELet (varName "q", resultTyp, query, (ESeq (store, rel0), loc)), loc)), - ((PSome (stringTyp, (PVar (varName "hit", stringTyp), loc)), loc), - (* Boolean is false because we're not unurlifying from a cookie. *) - (EUnurlify (rel0, resultTyp, false), loc))], - {disc = stringTyp, result = resultTyp}) + 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 + (check, + [((PNone stringTyp, loc), + (ELet (varName "q", resultTyp, exp, (ESeq (store, rel0), loc)), loc)), + ((PSome (stringTyp, (PVar (varName "hit", stringTyp), loc)), loc), + (* Boolean is false because we're not unurlifying from a cookie. *) + (EUnurlify (rel0, resultTyp, false), loc))], + {disc = (TOption stringTyp, loc), result = resultTyp})) + end end -fun fileMapfold doExp file start = +fun fileMapfoldB doExp file start = case MonoUtil.File.mapfoldB {typ = Search.return2, exp = fn env => fn e' => fn s => Search.Continue (doExp env e' s), @@ -523,7 +530,7 @@ fun fileMapfold doExp file start = Search.Continue x => x | Search.Return _ => raise Match -fun fileMap doExp file = #1 (fileMapfold (fn _ => fn e => fn _ => (doExp e, ())) file ()) +fun fileMap doExp file = #1 (fileMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ()) fun factorOutNontrivial text = let @@ -561,6 +568,7 @@ fun factorOutNontrivial text = fun addChecking file = let + val effs = effectfulDecls file fun doExp env (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) = fn e' as EQuery {query = origQueryText, state = resultTyp, @@ -582,7 +590,6 @@ fun addChecking file = val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc)) fun bind x f = Option.mapPartial f x fun guard b x = if b then x else NONE - val effs = effectfulDecls file (* We use dummyTyp here. I think this is okay because databases don't store (effectful) functions, but perhaps there's some pathalogical corner case missing.... *) @@ -596,12 +603,13 @@ fun addChecking file = (* Ziv misses Haskell's do notation.... *) guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) ( bind (Sql.parse Sql.query queryText) (fn queryParsed => - SOME (wrapLets (cacheWrap (env, queryExp, index, resultTyp, args)), + bind (cacheWrap (env, queryExp, resultTyp, args, index)) (fn cachedExp => + SOME (wrapLets cachedExp, (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index)) tableToIndices (tablesQuery queryParsed), IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)), - index + 1)))) + index + 1))))) in case attempt of SOME pair => pair @@ -609,9 +617,10 @@ fun addChecking file = end | e' => (e', queryInfo) in - fileMapfold (fn env => fn exp => fn state => doExp env state exp) - file - (SIMM.empty, IM.empty, 0) + (fileMapfoldB (fn env => fn exp => fn state => doExp env state exp) + file + (SIMM.empty, IM.empty, 0), + effs) end structure Invalidations = struct @@ -662,7 +671,7 @@ val invalidations = Invalidations.invalidations (* DEBUG *) val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] -fun addFlushing (file, (tableToIndices, indexToQueryNumArgs, _)) = +fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) = let val flushes = List.concat o map (fn (i, argss) => map (fn args => flush (i, args)) argss) @@ -694,7 +703,7 @@ fun addFlushing (file, (tableToIndices, indexToQueryNumArgs, _)) = in (* DEBUG *) gunk := []; - fileMap doExp file + (fileMap doExp file, index, effs) end val inlineSql = @@ -713,25 +722,11 @@ val inlineSql = fileMap doExp end -fun go file = - let - (* TODO: do something nicer than [Sql] being in one of two modes. *) - val () = (resetFfiInfo (); Sql.sqlcacheMode := true) - val file' = addFlushing (addChecking (inlineSql file)) - val () = Sql.sqlcacheMode := false - in - file' - end - (**********************) (* Mono Type Checking *) (**********************) -val typOfPrim = - fn Prim.Int _ => TFfi ("Basis", "int") - | Prim.Float _ => TFfi ("Basis", "int") - fun typOfExp' (env : MonoEnv.env) : exp' -> typ option = fn EPrim p => SOME (TFfi ("Basis", case p of Prim.Int _ => "int" @@ -779,6 +774,7 @@ fun typOfExp' (env : MonoEnv.env) : exp' -> typ option = | ELet (s, t, e1, e2) => typOfExp (MonoEnv.pushERel env s t (SOME e1)) e2 | EClosure _ => NONE | EUnurlify (_, t, _) => SOME t + | _ => NONE and typOfExp env (e', loc) = typOfExp' env e' @@ -797,17 +793,35 @@ val expOfSubexp = fn Pure f => f () | Impure e => e -val makeCache : MonoEnv.env -> exp' -> exp' = fn _ => fn _ => raise Fail "TODO" - -fun pureCache (effs : IS.set) (env : MonoEnv.env) (exp as (exp', loc)) : subexp = +fun makeCache (env, exp', index) = + case typOfExp' env exp' of + NONE => NONE + | SOME (TFun _, _) => NONE + | SOME typ => + case ListUtil.foldri (fn (_, _, NONE) => NONE + | (n, typ, SOME args) => + case MonoFooify.urlify env ((ERel n, dummyLoc), typ) of + NONE => NONE + | SOME arg => SOME (arg :: args)) + (SOME []) + (MonoEnv.typeContext env) of + NONE => NONE + | SOME args => cacheWrap (env, (exp', dummyLoc), typ, args, index) + +fun pureCache (effs : IS.set) ((env, exp as (exp', loc)), index) : subexp * int = let fun wrapBindN f (args : (MonoEnv.env * exp) list) = let - val subexps = map (fn (env, exp) => pureCache effs env exp) args + val (subexps, index) = ListUtil.foldlMap (pureCache effs) index args + fun mkExp () = (f (map expOfSubexp subexps), loc) in if List.exists isImpure subexps - then Impure (f (map expOfSubexp subexps), loc) - else Pure (fn () => (makeCache env (f (map #2 args)), loc)) + then (Impure (mkExp ()), index) + else (Pure (fn () => case makeCache (env, f (map #2 args), index) of + NONE => mkExp () + | SOME e' => (e', loc)), + (* Conservatively increment index. *) + index + 1) end fun wrapBind1 f arg = wrapBindN (fn [arg] => f arg | _ => raise Match) [arg] @@ -837,7 +851,8 @@ fun pureCache (effs : IS.set) (env : MonoEnv.env) (exp as (exp', loc)) : subexp wrapBindN (fn (e::es) => ECase (e, (ListPair.map (fn (e, (p, _)) => (p, e)) (es, cases)), - {disc = disc, result = result})) + {disc = disc, result = result}) + | _ => raise Match) ((env, e) :: map (fn (p, e) => (MonoEnv.patBinds env p, e)) cases) | EStrcat (e1, e2) => wrap2 EStrcat (e1, e2) (* We record page writes, so they're cachable. *) @@ -849,8 +864,61 @@ fun pureCache (effs : IS.set) (env : MonoEnv.env) (exp as (exp', loc)) : subexp (* ASK: | EClosure (n, es) => ? *) | EUnurlify (e, t, b) => wrap1 (fn e => EUnurlify (e, t, b)) e | _ => if effectful effs env exp - then Impure exp - else Pure (fn () => (makeCache env exp', loc)) + then (Impure exp, index) + else (Pure (fn () => (case makeCache (env, exp', index) of + NONE => exp' + | SOME e' => e', + loc)), + index + 1) + end + +fun addPure ((decls, sideInfo), index, effs) = + let + fun doVal ((x, n, t, exp, s), index) = + let + val (subexp, index) = pureCache effs ((MonoEnv.empty, exp), index) + in + ((x, n, t, expOfSubexp subexp, s), index) + end + fun doDecl' (decl', index) = + case decl' of + DVal v => + let + val (v, index) = (doVal (v, index)) + in + (DVal v, index) + end + | DValRec vs => + let + val (vs, index) = ListUtil.foldlMap doVal index vs + in + (DValRec vs, index) + end + | _ => (decl', index) + fun doDecl ((decl', loc), index) = + let + val (decl', index) = doDecl' (decl', index) + in + ((decl', loc), index) + end + val decls = #1 (ListUtil.foldlMap doDecl index decls) + (* Important that this happens after the MonoFooify.urlify calls! *) + val fmDecls = MonoFooify.getNewFmDecls () + in + print (Int.toString (length fmDecls)); + (decls @ fmDecls, 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) + val file' = go' file + val () = Sql.sqlcacheMode := false + in + file' end end -- cgit v1.2.3 From 067c8cd3b908eb057f6721453a5c3801965d43b8 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Sun, 27 Sep 2015 14:46:12 -0400 Subject: Use referenced (rather than all) free variables as keys for pure caches. --- src/mono_env.sig | 2 -- src/mono_env.sml | 2 -- src/sqlcache.sml | 34 ++++++++++++++++++++++++---------- 3 files changed, 24 insertions(+), 14 deletions(-) (limited to 'src/mono_env.sig') diff --git a/src/mono_env.sig b/src/mono_env.sig index 9805c0d1..db6fdc95 100644 --- a/src/mono_env.sig +++ b/src/mono_env.sig @@ -42,8 +42,6 @@ signature MONO_ENV = sig val pushERel : env -> string -> Mono.typ -> Mono.exp option -> env val lookupERel : env -> int -> string * Mono.typ * Mono.exp option - val typeContext : env -> Mono.typ list - val pushENamed : env -> string -> int -> Mono.typ -> Mono.exp option -> string -> env val lookupENamed : env -> int -> string * Mono.typ * Mono.exp option * string diff --git a/src/mono_env.sml b/src/mono_env.sml index 8617425e..52e07893 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -108,8 +108,6 @@ fun lookupERel (env : env) n = (List.nth (#relE env, n)) handle Subscript => raise UnboundRel n -fun typeContext (env : env) = map #2 (#relE env) - fun pushENamed (env : env) x n t eo s = {datatypes = #datatypes env, constructors = #constructors env, diff --git a/src/sqlcache.sml b/src/sqlcache.sml index eaa94685..fa4a0d22 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -673,8 +673,8 @@ val gunk : ((Sql.query * int) * Sql.dml) 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 flushes = List.concat + o map (fn (i, argss) => map (fn args => flush (i, args)) argss) val doExp = fn EDml (origDmlText, failureMode) => let @@ -783,6 +783,18 @@ and typOfExp env (e', loc) = typOfExp' env e' (* Caching Pure Subexpressions *) (*******************************) +val freeVars = + IS.listItems + o MonoUtil.Exp.foldB + {typ = #2, + exp = fn (bound, ERel n, vars) => if n < bound + then vars + else IS.add (vars, n - bound) + | (_, _, vars) => vars, + bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound} + 0 + IS.empty + datatype subexp = Pure of unit -> exp | Impure of exp val isImpure = @@ -798,13 +810,14 @@ fun makeCache (env, exp', index) = NONE => NONE | SOME (TFun _, _) => NONE | SOME typ => - case ListUtil.foldri (fn (_, _, NONE) => NONE - | (n, typ, SOME args) => - case MonoFooify.urlify env ((ERel n, dummyLoc), typ) of - NONE => NONE - | SOME arg => SOME (arg :: args)) - (SOME []) - (MonoEnv.typeContext env) of + case List.foldr (fn ((_, _), NONE) => NONE + | ((n, typ), SOME args) => + case MonoFooify.urlify env ((ERel n, dummyLoc), typ) of + NONE => NONE + | SOME arg => SOME (arg :: args)) + (SOME []) + (map (fn n => (n, #2 (MonoEnv.lookupERel env n))) + (freeVars (exp', dummyLoc))) of NONE => NONE | SOME args => cacheWrap (env, (exp', dummyLoc), typ, args, index) @@ -906,7 +919,8 @@ fun addPure ((decls, sideInfo), index, effs) = val fmDecls = MonoFooify.getNewFmDecls () in print (Int.toString (length fmDecls)); - (decls @ fmDecls, sideInfo) + (* ASK: fmDecls before or after? *) + (fmDecls @ decls, sideInfo) end val go' = addPure o addFlushing o addChecking o inlineSql -- cgit v1.2.3