summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/mono_env.sig4
-rw-r--r--src/mono_env.sml4
-rw-r--r--src/mono_fooify.sig9
-rw-r--r--src/mono_fooify.sml56
-rw-r--r--src/monoize.sml7
-rw-r--r--src/sqlcache.sml162
6 files changed, 166 insertions, 76 deletions
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