changeset 1819:c9c38157d0d3

Merge
author Adam Chlipala <adam@chlipala.net>
date Fri, 14 Sep 2012 06:44:14 -0400
parents e6ff36097cc4 148203744882
children 3c56aa6a0f55
files
diffstat 7 files changed, 109 insertions(+), 39 deletions(-) [+]
line wrap: on
line diff
--- a/doc/manual.tex	Wed Sep 12 19:49:02 2012 +0400
+++ b/doc/manual.tex	Fri Sep 14 06:44:14 2012 -0400
@@ -140,6 +140,7 @@
 \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 @@
 \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}.
--- a/src/compiler.sml	Wed Sep 12 19:49:02 2012 +0400
+++ b/src/compiler.sml	Fri Sep 14 06:44:14 2012 -0400
@@ -853,6 +853,14 @@
                                      (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
--- a/src/especialize.sml	Wed Sep 12 19:49:02 2012 +0400
+++ b/src/especialize.sml	Fri Sep 14 06:44:14 2012 -0400
@@ -124,6 +124,7 @@
 
 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
--- a/src/mono_reduce.sml	Wed Sep 12 19:49:02 2012 +0400
+++ b/src/mono_reduce.sml	Fri Sep 14 06:44:14 2012 -0400
@@ -179,12 +179,12 @@
                 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 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 @@
                                 else
                                     e
                             end
+                        else if countFree 0 0 b > 1 andalso notValue e' then
+                            e
                         else
                             trySub ()
                     end
@@ -659,8 +672,11 @@
                                       | 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
--- a/src/monoize.sml	Wed Sep 12 19:49:02 2012 +0400
+++ b/src/monoize.sml	Fri Sep 14 06:44:14 2012 -0400
@@ -3263,29 +3263,29 @@
                         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
--- a/src/reduce.sml	Wed Sep 12 19:49:02 2012 +0400
+++ b/src/reduce.sml	Fri Sep 14 06:44:14 2012 -0400
@@ -232,6 +232,21 @@
                         ((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 @@
                                 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 @@
 
                           | 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)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/badInline.ur	Fri Sep 14 06:44:14 2012 -0400
@@ -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>