diff options
| -rw-r--r-- | doc/manual.tex | 2 | ||||
| -rw-r--r-- | src/compiler.sml | 8 | ||||
| -rw-r--r-- | src/especialize.sml | 1 | ||||
| -rw-r--r-- | src/mono_reduce.sml | 24 | ||||
| -rw-r--r-- | src/monoize.sml | 46 | ||||
| -rw-r--r-- | src/reduce.sml | 55 | ||||
| -rw-r--r-- | tests/badInline.ur | 12 |
7 files changed, 109 insertions, 39 deletions
diff --git a/doc/manual.tex b/doc/manual.tex index 8944dcfd..0dd65afb 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -140,6 +140,7 @@ Here is the complete list of directive forms. ``FFI'' stands for ``foreign func \item \texttt{benignEffectful Module.ident} registers an FFI function or transaction as having side effects. The optimizer avoids removing, moving, or duplicating calls to such functions. Every effectful FFI function must be registered, or the optimizer may make invalid transformations. This version of the \texttt{effectful} directive registers that this function only has side effects that remain local to a single page generation. \item \texttt{clientOnly Module.ident} registers an FFI function or transaction that may only be run in client browsers. \item \texttt{clientToServer Module.ident} adds FFI type \texttt{Module.ident} to the list of types that are OK to marshal from clients to servers. Values like XML trees and SQL queries are hard to marshal without introducing expensive validity checks, so it's easier to ensure that the server never trusts clients to send such values. The file \texttt{include/urweb.h} shows examples of the C support functions that are required of any type that may be marshalled. These include \texttt{attrify}, \texttt{urlify}, and \texttt{unurlify} functions. +\item \texttt{coreInline TREESIZE} sets how many nodes the AST of a function definition may have before the optimizer stops trying hard to inline calls to that function. (This is one of two options for one of two intermediate languages within the compiler.) \item \texttt{database DBSTRING} sets the string to pass to libpq to open a database connection. \item \texttt{debug} saves some intermediate C files, which is mostly useful to help in debugging the compiler itself. \item \texttt{effectful Module.ident} registers an FFI function or transaction as having side effects. The optimizer avoids removing, moving, or duplicating calls to such functions. Every effectful FFI function must be registered, or the optimizer may make invalid transformations. (Note that merely assigning a function a \texttt{transaction}-based type does not mark it as effectful in this way!) @@ -167,6 +168,7 @@ Here is the complete list of directive forms. ``FFI'' stands for ``foreign func \item \texttt{link FILENAME} adds \texttt{FILENAME} to the list of files to be passed to the linker at the end of compilation. This is most useful for importing extra libraries needed by new FFI modules. \item \texttt{linker CMD} sets \texttt{CMD} as the command line prefix to use for linking C object files. The command line will be completed with a space-separated list of \texttt{.o} and \texttt{.a} files, \texttt{-L} and \texttt{-l} flags, and finally with a \texttt{-o} flag to set the location where the executable should be written. \item \texttt{minHeap NUMBYTES} sets the initial size for thread-local heaps used in handling requests. These heaps grow automatically as needed (up to any maximum set with \texttt{limit}), but each regrow requires restarting the request handling process. +\item \texttt{monoInline TREESIZE} sets how many nodes the AST of a function definition may have before the optimizer stops trying hard to inline calls to that function. (This is one of two options for one of two intermediate languages within the compiler.) \item \texttt{noXsrfProtection URIPREFIX} turns off automatic cross-site request forgery protection for the page handler identified by the given URI prefix. This will avoid checking cryptographic signatures on cookies, which is generally a reasonable idea for some pages, such as login pages that are going to discard all old cookie values, anyway. \item \texttt{onError Module.var} changes the handling of fatal application errors. Instead of displaying a default, ugly error 500 page, the error page will be generated by calling function \texttt{Module.var} on a piece of XML representing the error message. The error handler should have type $\mt{xbody} \to \mt{transaction} \; \mt{page}$. Note that the error handler \emph{cannot} be in the application's main module, since that would register it as explicitly callable via URLs. \item \texttt{path NAME=VALUE} creates a mapping from \texttt{NAME} to \texttt{VALUE}. This mapping may be used at the beginnings of filesystem paths given to various other configuration directives. A path like \texttt{\$NAME/rest} is expanded to \texttt{VALUE/rest}. There is an initial mapping from the empty name (for paths like \texttt{\$/list}) to the directory where the Ur/Web standard library is installed. If you accept the default \texttt{configure} options, this directory is \texttt{/usr/local/lib/urweb/ur}. diff --git a/src/compiler.sml b/src/compiler.sml index d1d0484a..603dd298 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -853,6 +853,14 @@ fun parseUrp' accLibs fname = (case Int.fromString arg of NONE => ErrorMsg.error ("invalid min heap '" ^ arg ^ "'") | SOME n => minHeap := n) + | "coreInline" => + (case Int.fromString arg of + NONE => ErrorMsg.error ("invalid core inline level '" ^ arg ^ "'") + | SOME n => Settings.setCoreInline n) + | "monoInline" => + (case Int.fromString arg of + NONE => ErrorMsg.error ("invalid mono inline level '" ^ arg ^ "'") + | SOME n => Settings.setMonoInline n) | "alwaysInline" => Settings.addAlwaysInline arg | "noXsrfProtection" => Settings.addNoXsrfProtection arg | "timeFormat" => Settings.setTimeFormat arg diff --git a/src/especialize.sml b/src/especialize.sml index d6bf7eba..a3d59ef9 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -124,6 +124,7 @@ fun default (_, x, st) = (x, st) val functionInside = U.Con.exists {kind = fn _ => false, con = fn TFun _ => true + | TCFun _ => true | CFfi ("Basis", "transaction") => true | CFfi ("Basis", "eq") => true | CFfi ("Basis", "num") => true diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 88628ac2..af61489c 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -179,12 +179,12 @@ val swapExpVarsPat = bind = fn ((lower, len), U.Exp.RelE _) => (lower+1, len) | (st, _) => st} -datatype result = Yes of exp list | No | Maybe +datatype result = Yes of (string * typ * exp) list | No | Maybe fun match (env, p : pat, e : exp) = case (#1 p, #1 e) of (PWild, _) => Yes env - | (PVar (x, t), _) => Yes (e :: env) + | (PVar (x, t), _) => Yes ((x, t, e) :: env) | (PPrim (Prim.String s), EStrcat ((EPrim (Prim.String s'), _), _)) => if String.isPrefix s' s then @@ -519,6 +519,17 @@ fun reduce file = fun doLet (x, t, e', b) = let + val notValue = U.Exp.exists {typ = fn _ => false, + exp = fn e => + case e of + EPrim _ => false + | ECon _ => false + | ENone _ => false + | ESome _ => false + | ERecord _ => false + | _ => true} + + fun doSub () = let val r = subExpInExp (0, e') b @@ -597,6 +608,8 @@ fun reduce file = else e end + else if countFree 0 0 b > 1 andalso notValue e' then + e else trySub () end @@ -659,8 +672,11 @@ fun reduce file = | Yes subs => let val (body, remaining) = - foldl (fn (e, (body, remaining)) => - (subExpInExp (0, multiLift remaining e) body, remaining - 1)) + foldl (fn ((x, t, e), (body, remaining)) => + (if countFree 0 0 body > 1 then + (ELet (x, t, multiLift remaining e, body), #2 e') + else + subExpInExp (0, multiLift remaining e) body, remaining - 1)) (body, length subs - 1) subs val r = reduceExp (E.patBinds env p) body in diff --git a/src/monoize.sml b/src/monoize.sml index b5e2a5b6..d25e4d1f 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3263,29 +3263,29 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val t = (L'.TFfi ("Basis", "string"), loc) val s = (L'.EPrim (Prim.String (String.concat ["<", tag'])), loc) - val s = (L'.ECase (class, - [((L'.PPrim (Prim.String ""), loc), - s), - ((L'.PVar ("x", t), loc), - (L'.EStrcat (s, - (L'.EStrcat ((L'.EPrim (Prim.String " class=\""), loc), - (L'.EStrcat ((L'.ERel 0, loc), - (L'.EPrim (Prim.String "\""), loc)), - loc)), loc)), loc))], - {disc = t, - result = t}), loc) - - val s = (L'.ECase (style, - [((L'.PPrim (Prim.String ""), loc), - s), - ((L'.PVar ("x", t), loc), - (L'.EStrcat (s, - (L'.EStrcat ((L'.EPrim (Prim.String " style=\""), loc), - (L'.EStrcat ((L'.ERel 0, loc), - (L'.EPrim (Prim.String "\""), loc)), - loc)), loc)), loc))], - {disc = t, - result = t}), loc) + val s = (L'.EStrcat (s, + (L'.ECase (class, + [((L'.PPrim (Prim.String ""), loc), + (L'.EPrim (Prim.String ""), loc)), + ((L'.PVar ("x", t), loc), + (L'.EStrcat ((L'.EPrim (Prim.String " class=\""), loc), + (L'.EStrcat ((L'.ERel 0, loc), + (L'.EPrim (Prim.String "\""), loc)), + loc)), loc))], + {disc = t, + result = t}), loc)), loc) + + val s = (L'.EStrcat (s, + (L'.ECase (style, + [((L'.PPrim (Prim.String ""), loc), + (L'.EPrim (Prim.String ""), loc)), + ((L'.PVar ("x", t), loc), + (L'.EStrcat ((L'.EPrim (Prim.String " style=\""), loc), + (L'.EStrcat ((L'.ERel 0, loc), + (L'.EPrim (Prim.String "\""), loc)), + loc)), loc))], + {disc = t, + result = t}), loc)), loc) val (s, fm) = foldl (fn (("Action", _, _), acc) => acc | (("Source", _, _), acc) => acc diff --git a/src/reduce.sml b/src/reduce.sml index 1fbf526d..c5733b97 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -232,6 +232,21 @@ fun monadRecord m loc = ((CName "Bind", loc), bindType m loc)]), loc), loc) +fun passive (e : exp) = + case #1 e of + EPrim _ => true + | ERel _ => true + | ENamed _ => true + | ECon (_, _, _, NONE) => true + | ECon (_, _, _, SOME e) => passive e + | EFfi _ => true + | EAbs _ => true + | ECAbs _ => true + | EKAbs _ => true + | ERecord xes => List.all (passive o #2) xes + | EField (e, _, _) => passive e + | _ => false + fun kindConAndExp (namedC, namedE) = let fun kind env (all as (k, loc)) = @@ -534,16 +549,30 @@ fun kindConAndExp (namedC, namedE) = val e2 = exp env e2 in case #1 e1 of - EAbs (_, _, _, b) => - let - val r = exp (KnownE e2 :: env') b - in - (*Print.prefaces "eapp" [("b", CorePrint.p_exp CoreEnv.empty b), - ("env", Print.PD.string (e2s env')), - ("e2", CorePrint.p_exp CoreEnv.empty e2), - ("r", CorePrint.p_exp CoreEnv.empty r)];*) - r - end + ELet (x, t, e1', e2') => + (ELet (x, t, e1', exp (UnknownE :: env') (EApp (e2', E.liftExpInExp 0 e2), loc)), loc) + + | EAbs (x, dom, _, b) => + if count b <= 1 orelse passive e2 orelse ESpecialize.functionInside dom then + let + val r = exp (KnownE e2 :: env') b + in + (*Print.prefaces "eapp" [("b", CorePrint.p_exp CoreEnv.empty b), + ("env", Print.PD.string (e2s env')), + ("e2", CorePrint.p_exp CoreEnv.empty e2), + ("r", CorePrint.p_exp CoreEnv.empty r)];*) + r + end + else + let + val dom = con env' dom + val r = exp (UnknownE :: env') b + in + (*Print.prefaces "El skippo" [("x", Print.PD.string x), + ("e2", CorePrint.p_exp CoreEnv.empty e2)];*) + (ELet (x, dom, e2, r), loc) + end + | ECase (e, pes, cc as {disc, result = res as (TFun (_, c2), _)}) => let val pes' = map (fn (p, body) => @@ -760,12 +789,14 @@ fun kindConAndExp (namedC, namedE) = | ELet (x, t, e1, e2) => let + val e1' = exp env e1 + val t = con env t in - if ESpecialize.functionInside t then + if passive e1' orelse count e2 <= 1 orelse ESpecialize.functionInside t then exp (KnownE e1 :: env) e2 else - (ELet (x, t, exp env e1, exp (UnknownE :: env) e2), loc) + (ELet (x, t, e1', exp (UnknownE :: env) e2), loc) end | EServerCall (n, es, t) => (EServerCall (n, map (exp env) es, con env t), loc) diff --git a/tests/badInline.ur b/tests/badInline.ur new file mode 100644 index 00000000..bfbdba79 --- /dev/null +++ b/tests/badInline.ur @@ -0,0 +1,12 @@ +style s1 +style s2 +style s3 + +fun ifClass r cls c = if r then classes cls c else c + +fun main (n : int) : transaction page = return <xml><body> + <p class={ifClass (n = 0) s1 + (ifClass (n = 1) s2 + (ifClass (n = 2) s3 + null))}>Hi</p> +</body></xml> |