Change handling of returned text blobs, to activate the normal EWrite optimizations

14 files changed, 154 insertions, 32 deletions

diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h
index fb3c83a2..d1fb4d37 100644
--- a/include/urweb/urweb_cpp.h
+++ b/include/urweb/urweb_cpp.h
@@ -209,6 +209,7 @@ uw_Basis_string uw_Basis_requestHeader(struct uw_context *, uw_Basis_string);
 
 void uw_write_header(struct uw_context *, uw_Basis_string);
 void uw_clear_headers(struct uw_context *);
+void uw_Basis_clear_page(struct uw_context *);
 
 uw_Basis_string uw_Basis_get_cookie(struct uw_context *, uw_Basis_string c);
 uw_unit uw_Basis_set_cookie(struct uw_context *, uw_Basis_string prefix, uw_Basis_string c, uw_Basis_string v, uw_Basis_time *expires, uw_Basis_bool secure);
@@ -255,6 +256,7 @@ uw_Basis_postBody uw_getPostBody(struct uw_context *);
 
 void uw_mayReturnIndirectly(struct uw_context *);
 __attribute__((noreturn)) void uw_return_blob(struct uw_context *, uw_Basis_blob, uw_Basis_string mimeType);
+__attribute__((noreturn)) void uw_return_blob_from_page(struct uw_context *, uw_Basis_string mimeType);
 __attribute__((noreturn)) void uw_redirect(struct uw_context *, uw_Basis_string url);
 
 uw_Basis_time uw_Basis_now(struct uw_context *);
diff --git a/src/c/urweb.c b/src/c/urweb.c
index cd724cbf..1201b09b 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -1351,6 +1351,10 @@ void uw_clear_headers(uw_context ctx) {
   uw_buffer_reset(&ctx->outHeaders);
 }
 
+void uw_Basis_clear_page(uw_context ctx) {
+  uw_buffer_reset(&ctx->page);
+}
+
 static void uw_check_script(uw_context ctx, size_t extra) {
   ctx_uw_buffer_check(ctx, "script", &ctx->script, extra);
 }
@@ -3736,6 +3740,36 @@ __attribute__((noreturn)) void uw_return_blob(uw_context ctx, uw_Basis_blob b, u
   longjmp(ctx->jmp_buf, RETURN_INDIRECTLY);
 }
 
+__attribute__((noreturn)) void uw_return_blob_from_page(uw_context ctx, uw_Basis_string mimeType) {
+  cleanup *cl;
+  int len;
+  char *oldh;
+
+  if (!ctx->allowed_to_return_indirectly)
+    uw_error(ctx, FATAL, "Tried to return a blob from an RPC");
+
+  ctx->returning_indirectly = 1;
+  oldh = old_headers(ctx);
+  uw_buffer_reset(&ctx->outHeaders);
+
+  uw_write_header(ctx, on_success);
+  uw_write_header(ctx, "Content-Type: ");
+  uw_write_header(ctx, mimeType);
+  uw_write_header(ctx, "\r\nContent-Length: ");
+  ctx_uw_buffer_check(ctx, "headers", &ctx->outHeaders, INTS_MAX);
+  sprintf(ctx->outHeaders.front, "%lu%n", (unsigned long)uw_buffer_used(&ctx->page), &len);
+  ctx->outHeaders.front += len;
+  uw_write_header(ctx, "\r\n");
+  if (oldh) uw_write_header(ctx, oldh);
+
+  for (cl = ctx->cleanup; cl < ctx->cleanup_front; ++cl)
+    cl->func(cl->arg);
+
+  ctx->cleanup_front = ctx->cleanup;
+
+  longjmp(ctx->jmp_buf, RETURN_INDIRECTLY);
+}
+
 __attribute__((noreturn)) void uw_redirect(uw_context ctx, uw_Basis_string url) {
   cleanup *cl;
   char *s;
diff --git a/src/checknest.sml b/src/checknest.sml
index 05ad8e9a..fa418d89 100644
--- a/src/checknest.sml
+++ b/src/checknest.sml
@@ -56,7 +56,8 @@ fun expUses globals =
               | ECase (e, pes, _) => foldl (fn ((_, e), s) => IS.union (eu e, s)) (eu e) pes
 
               | EError (e, _) => eu e
-              | EReturnBlob {blob, mimeType, ...} => IS.union (eu blob, eu mimeType)
+              | EReturnBlob {blob = NONE, mimeType, ...} => eu mimeType
+              | EReturnBlob {blob = SOME blob, mimeType, ...} => IS.union (eu blob, eu mimeType)
               | ERedirect (e, _) => eu e
 
               | EWrite e => eu e
@@ -118,7 +119,8 @@ fun annotateExp globals =
               | ECase (e, pes, ts) => (ECase (ae e, map (fn (p, e) => (p, ae e)) pes, ts), loc)
 
               | EError (e, t) => (EError (ae e, t), loc)
-              | EReturnBlob {blob, mimeType, t} => (EReturnBlob {blob = ae blob, mimeType = ae mimeType, t = t}, loc)
+              | EReturnBlob {blob = NONE, mimeType, t} => (EReturnBlob {blob = NONE, mimeType = ae mimeType, t = t}, loc)
+              | EReturnBlob {blob = SOME blob, mimeType, t} => (EReturnBlob {blob = SOME (ae blob), mimeType = ae mimeType, t = t}, loc)
               | ERedirect (e, t) => (ERedirect (ae e, t), loc)
 
               | EWrite e => (EWrite (ae e), loc)
diff --git a/src/cjr.sml b/src/cjr.sml
index 3a37b26f..8cbabdcc 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -78,7 +78,7 @@ datatype exp' =
        | ECase of exp * (pat * exp) list * { disc : typ, result : typ }
 
        | EError of exp * typ
-       | EReturnBlob of {blob : exp, mimeType : exp, t : typ}
+       | EReturnBlob of {blob : exp option, mimeType : exp, t : typ}
        | ERedirect of exp * typ
 
        | EWrite of exp
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index e98918e6..dec21eb3 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1628,7 +1628,7 @@ and p_exp' par tail env (e, loc) =
              string "tmp;",
              newline,
              string "})"]
-      | EReturnBlob {blob, mimeType, t} =>
+      | EReturnBlob {blob = SOME blob, mimeType, t} =>
         box [string "({",
              newline,
              string "uw_Basis_blob",
@@ -1658,6 +1658,27 @@ and p_exp' par tail env (e, loc) =
              string "tmp;",
              newline,
              string "})"]
+      | EReturnBlob {blob = NONE, mimeType, t} =>
+        box [string "({",
+             newline,
+             string "uw_Basis_string",
+             space,
+             string "mimeType",
+             space,
+             string "=",
+             space,
+             p_exp' false false env mimeType,
+             string ";",
+             newline,
+             p_typ env t,
+             space,
+             string "tmp;",
+             newline,
+             string "uw_return_blob_from_page(ctx, mimeType);",
+             newline,
+             string "tmp;",
+             newline,
+             string "})"]
       | ERedirect (e, t) =>
         box [string "({",
              newline,
@@ -3180,7 +3201,8 @@ fun p_file env (ds, ps) =
               | EField (e, _) => expDb e
               | ECase (e, pes, _) => expDb e orelse List.exists (expDb o #2) pes
               | EError (e, _) => expDb e
-              | EReturnBlob {blob = e1, mimeType = e2, ...} => expDb e1 orelse expDb e2
+              | EReturnBlob {blob = NONE, mimeType = e2, ...} => expDb e2
+              | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => expDb e1 orelse expDb e2
               | ERedirect (e, _) => expDb e
               | EWrite e => expDb e
               | ESeq (e1, e2) => expDb e1 orelse expDb e2
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 0f4bdb42..d153feff 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -372,13 +372,20 @@ fun cifyExp (eAll as (e, loc), sm) =
             in
                 ((L'.EError (e, t), loc), sm)
             end
-          | L.EReturnBlob {blob, mimeType, t} =>
+          | L.EReturnBlob {blob = NONE, mimeType, t} =>
+            let
+                val (mimeType, sm) = cifyExp (mimeType, sm)
+                val (t, sm) = cifyTyp (t, sm)
+            in
+                ((L'.EReturnBlob {blob = NONE, mimeType = mimeType, t = t}, loc), sm)
+            end
+          | L.EReturnBlob {blob = SOME blob, mimeType, t} =>
             let
                 val (blob, sm) = cifyExp (blob, sm)
                 val (mimeType, sm) = cifyExp (mimeType, sm)
                 val (t, sm) = cifyTyp (t, sm)
             in
-                ((L'.EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), sm)
+                ((L'.EReturnBlob {blob = SOME blob, mimeType = mimeType, t = t}, loc), sm)
             end
           | L.ERedirect (e, t) =>
             let
diff --git a/src/iflow.sml b/src/iflow.sml
index 0c94cd47..461dc956 100644
--- a/src/iflow.sml
+++ b/src/iflow.sml
@@ -1587,7 +1587,8 @@ fun evalExp env (e as (_, loc)) k =
                 evalExp env e2 (fn e2 =>
                                    k (Func (Other "cat", [e1, e2]))))
           | EError (e, _) => evalExp env e (fn e => St.send (e, loc))
-          | EReturnBlob {blob = b, mimeType = m, ...} =>
+          | EReturnBlob {blob = NONE, ...} => raise Fail "Iflow doesn't support blob optimization"
+          | EReturnBlob {blob = SOME b, mimeType = m, ...} =>
             evalExp env b (fn b =>
                               (St.send (b, loc);
                                evalExp env m
@@ -2060,8 +2061,10 @@ fun check (file : file) =
                             end
                           | EStrcat (e1, e2) => (EStrcat (doExp env e1, doExp env e2), loc)
                           | EError (e1, t) => (EError (doExp env e1, t), loc)
-                          | EReturnBlob {blob = b, mimeType = m, t} =>
-                            (EReturnBlob {blob = doExp env b, mimeType = doExp env m, t = t}, loc)
+                          | EReturnBlob {blob = NONE, mimeType = m, t} =>
+                            (EReturnBlob {blob = NONE, mimeType = doExp env m, t = t}, loc)
+                          | EReturnBlob {blob = SOME b, mimeType = m, t} =>
+                            (EReturnBlob {blob = SOME (doExp env b), mimeType = doExp env m, t = t}, loc)
                           | ERedirect (e1, t) => (ERedirect (doExp env e1, t), loc)
                           | EWrite e1 => (EWrite (doExp env e1), loc)
                           | ESeq (e1, e2) => (ESeq (doExp env e1, doExp env e2), loc)
diff --git a/src/jscomp.sml b/src/jscomp.sml
index e0d87a8e..4a2c0365 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -1118,12 +1118,18 @@ fun process (file : file) =
                  in
                      ((EError (e, t), loc), st)
                  end
-               | EReturnBlob {blob, mimeType, t} =>
+               | EReturnBlob {blob = NONE, mimeType, t} =>
+                 let
+                     val (mimeType, st) = exp outer (mimeType, st)
+                 in
+                     ((EReturnBlob {blob = NONE, mimeType = mimeType, t = t}, loc), st)
+                 end
+               | EReturnBlob {blob = SOME blob, mimeType, t} =>
                  let
                      val (blob, st) = exp outer (blob, st)
                      val (mimeType, st) = exp outer (mimeType, st)
                  in
-                     ((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), st)
+                     ((EReturnBlob {blob = SOME blob, mimeType = mimeType, t = t}, loc), st)
                  end
                | ERedirect (e, t) =>
                  let
diff --git a/src/mono.sml b/src/mono.sml
index f5260419..78740d70 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -93,7 +93,7 @@ datatype exp' =
        | EStrcat of exp * exp
 
        | EError of exp * typ
-       | EReturnBlob of {blob : exp, mimeType : exp, t : typ}
+       | EReturnBlob of {blob : exp option, mimeType : exp, t : typ}
        | ERedirect of exp * typ
 
        | EWrite of exp
diff --git a/src/mono_print.sml b/src/mono_print.sml
index a5156aca..c81b362a 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -235,18 +235,30 @@ fun p_exp' par env (e, _) =
                               space,
                               p_typ env t,
                               string ")"]
-      | EReturnBlob {blob, mimeType, t} => box [string "(blob",
-                                                space,
-                                                p_exp env blob,
-                                                space,
-                                                string "in",
-                                                space,
-                                                p_exp env mimeType,
-                                                space,
-                                                string ":",
-                                                space,
-                                                p_typ env t,
-                                                string ")"]
+      | EReturnBlob {blob = SOME blob, mimeType, t} => box [string "(blob",
+                                                            space,
+                                                            p_exp env blob,
+                                                            space,
+                                                            string "in",
+                                                            space,
+                                                            p_exp env mimeType,
+                                                            space,
+                                                            string ":",
+                                                            space,
+                                                            p_typ env t,
+                                                            string ")"]
+      | EReturnBlob {blob = NONE, mimeType, t} => box [string "(blob",
+                                                       space,
+                                                       string "<page>",
+                                                       space,
+                                                       string "in",
+                                                       space,
+                                                       p_exp env mimeType,
+                                                       space,
+                                                       string ":",
+                                                       space,
+                                                       p_typ env t,
+                                                       string ")"]
       | ERedirect (e, t) => box [string "(redirect",
                                  space,
                                  p_exp env e,
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 0dfb7558..e96a0e8f 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -101,7 +101,8 @@ fun impure (e, _) =
       | ECase (e, pes, _) => impure e orelse List.exists (fn (_, e) => impure e) pes
 
       | EError _ => true
-      | EReturnBlob {blob = e1, mimeType = e2, ...} => impure e1 orelse impure e2
+      | EReturnBlob {blob = NONE, mimeType = e2, ...} => impure e2
+      | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => impure e1 orelse impure e2
       | ERedirect (e, _) => impure e
 
       | EStrcat (e1, e2) => impure e1 orelse impure e2
@@ -492,7 +493,8 @@ fun reduce (file : file) =
                       | EStrcat (e1, e2) => summarize d e1 @ summarize d e2
 
                       | EError (e, _) => summarize d e @ [Abort]
-                      | EReturnBlob {blob = e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Abort]
+                      | EReturnBlob {blob = NONE, mimeType = e2, ...} => summarize d e2 @ [Abort]
+                      | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Abort]
                       | ERedirect (e, _) => summarize d e @ [Abort]
 
                       | EWrite e => summarize d e @ [WritePage]
diff --git a/src/mono_util.sml b/src/mono_util.sml
index cb871891..cc531625 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -261,14 +261,20 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
                             S.map2 (mft t,
                                     fn t' =>
                                        (EError (e', t'), loc)))
-              | EReturnBlob {blob, mimeType, t} =>
+              | EReturnBlob {blob = NONE, mimeType, t} =>
+                S.bind2 (mfe ctx mimeType,
+                      fn mimeType' =>
+                         S.map2 (mft t,
+                              fn t' =>
+                                 (EReturnBlob {blob = NONE, mimeType = mimeType', t = t'}, loc)))
+              | EReturnBlob {blob = SOME blob, mimeType, t} =>
                 S.bind2 (mfe ctx blob,
                          fn blob' =>
                             S.bind2 (mfe ctx mimeType,
                                   fn mimeType' =>
                                      S.map2 (mft t,
                                           fn t' =>
-                                             (EReturnBlob {blob = blob', mimeType = mimeType', t = t'}, loc))))
+                                             (EReturnBlob {blob = SOME blob', mimeType = mimeType', t = t'}, loc))))
               | ERedirect (e, t) =>
                 S.bind2 (mfe ctx e,
                          fn e' =>
@@ -495,7 +501,8 @@ fun appLoc f =
                | ECase (e1, pes, _) => (appl e1; app (appl o #2) pes)
                | EStrcat (e1, e2) => (appl e1; appl e2)
                | EError (e1, _) => appl e1
-               | EReturnBlob {blob = e1, mimeType = e2, ...} => (appl e1; appl e2)
+               | EReturnBlob {blob = NONE, mimeType = e2, ...} => appl e2
+               | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => (appl e1; appl e2)
                | ERedirect (e1, _) => appl e1
                | EWrite e1 => appl e1
                | ESeq (e1, e2) => (appl e1; appl e2)
diff --git a/src/monoize.sml b/src/monoize.sml
index 2b604325..b1166734 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -4053,6 +4053,24 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                            (L'.EError ((L'.ERel 0, loc), t), loc)), loc),
                  fm)
             end
+          | L.EApp (
+            (L.ECApp ((L.EFfi ("Basis", "returnBlob"), _), t), _),
+            (L.EFfiApp ("Basis", "textBlob", [(e, _)]), _)) =>
+            let
+                val t = monoType env t
+                val un = (L'.TRecord [], loc)
+                val (e, fm) = monoExp (env, st, fm) e
+            in
+                ((L'.EAbs ("mt", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc),
+                           (L'.EAbs ("_", un, t,
+                                     (L'.ESeq ((L'.EFfiApp ("Basis", "clear_page", []), loc),
+                                               (L'.ESeq ((L'.EWrite (liftExpInExp 0 (liftExpInExp 0 e)), loc),
+                                                         (L'.EReturnBlob {blob = NONE,
+                                                                          mimeType = (L'.ERel 1, loc),
+                                                                          t = t}, loc)), loc)), loc)), loc)),
+                  loc),
+                 fm)
+            end
           | L.ECApp ((L.EFfi ("Basis", "returnBlob"), _), t) =>
             let
                 val t = monoType env t
@@ -4062,7 +4080,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                            (L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc)), loc),
                            (L'.EAbs ("mt", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc),
                                      (L'.EAbs ("_", un, t,
-                                               (L'.EReturnBlob {blob = (L'.ERel 2, loc),
+                                               (L'.EReturnBlob {blob = SOME (L'.ERel 2, loc),
                                                                 mimeType = (L'.ERel 1, loc),
                                                                 t = t}, loc)), loc)), loc)), loc),
                  fm)
diff --git a/src/prepare.sml b/src/prepare.sml
index 7f55959c..89cd1b43 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -201,7 +201,14 @@ fun prepExp (e as (_, loc), st) =
 
       | EReturnBlob {blob, mimeType, t} =>
         let
-            val (blob, st) = prepExp (blob, st)
+            val (blob, st) = case blob of
+                                 NONE => (blob, st)
+                               | SOME blob =>
+                                 let
+                                     val (b, st) = prepExp (blob, st)
+                                 in
+                                     (SOME b, st)
+                                 end
             val (mimeType, st) = prepExp (mimeType, st)
         in
             ((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), st)