From 18b7332e738d4b97bf3bb9dfa6600277222aab33 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Sun, 5 Apr 2009 10:48:11 -0400
Subject: Threads demo

---
 demo/buffer.ur      | 25 +++++++++++++++++++++++++
 demo/buffer.urs     |  5 +++++
 demo/prose          | 12 ++++++++++++
 demo/threads.ur     | 17 +++++++++++++++++
 demo/threads.urp    |  3 +++
 demo/threads.urs    |  1 +
 src/mono_reduce.sml |  2 --
 src/monoize.sml     |  6 +++++-
 8 files changed, 68 insertions(+), 3 deletions(-)
 create mode 100644 demo/buffer.ur
 create mode 100644 demo/buffer.urs
 create mode 100644 demo/threads.ur
 create mode 100644 demo/threads.urp
 create mode 100644 demo/threads.urs

diff --git a/demo/buffer.ur b/demo/buffer.ur
new file mode 100644
index 00000000..27e2b805
--- /dev/null
+++ b/demo/buffer.ur
@@ -0,0 +1,25 @@
+datatype lines = End | Line of string * source lines
+
+type t = { Head : source lines, Tail : source (source lines) }
+
+val create =
+    head <- source End;
+    tail <- source head;
+    return {Head = head, Tail = tail}
+
+fun renderL lines =
+    case lines of
+        End => <xml/>
+      | Line (line, linesS) => <xml>{[line]}<br/><dyn signal={renderS linesS}/></xml>
+
+and renderS linesS =
+    lines <- signal linesS;
+    return (renderL lines)
+
+fun render t = renderS t.Head
+
+fun write t s =
+    oldTail <- get t.Tail;
+    newTail <- source End;
+    set oldTail (Line (s, newTail));
+    set t.Tail newTail
diff --git a/demo/buffer.urs b/demo/buffer.urs
new file mode 100644
index 00000000..58312bbd
--- /dev/null
+++ b/demo/buffer.urs
@@ -0,0 +1,5 @@
+type t
+
+val create : transaction t
+val render : t -> signal xbody
+val write : t -> string -> transaction unit
diff --git a/demo/prose b/demo/prose
index 11f8c2d9..80113c3e 100644
--- a/demo/prose
+++ b/demo/prose
@@ -234,3 +234,15 @@ batchG.urp
 <p><tt>BatchFun.Make</tt> handles the plumbing of allocating the local state, using it to create widgets, and reading the state values when the user clicks "Batch it."</p>
 
 <p><tt>batchG.ur</tt> contains an example instantiation, which is just as easy to write as in the <tt>Crud1</tt> example.</p>
+
+threads.urp
+
+<p>Ur/Web makes it easy to write multi-threaded client-side code.  This example demonstrates two threads writing to a page at once.</p>
+
+<p>First, we define a useful component for sections of pages that can have lines of text added to them dynamically.  This is the <tt>Buffer</tt> module.  It contains an abstract type of writable regions, along with functions to create a region, retrieve a signal representing its HTML rendering, and add a new line to it.</p>
+
+<p>The entry point to the main module <tt>Threads</tt> begins by creating a buffer.  The function <tt>loop</tt> implements writing to that buffer periodically, incrementing a counter each time.  The arguments to <tt>loop</tt> specify a prefix for the messages and the number of milliseconds to wait between writes.</p>
+
+<p>We specify some client-side code to run on page load using the <tt>onload</tt> attribute of <tt>&lt;body&gt;</tt>.  The <tt>onload</tt> code in this example spawns two separate threads running the <tt>loop</tt> code with different prefixes, update intervals, and starting counters.</p>
+
+<p>Old hands at concurrent programming may be worried at the lack of synchronization in this program.  Ur/Web uses <i>cooperative multi-threading</i>, not the more common <i>preemptive</i> multi-threading.  Only one thread runs at a time, and only particular function calls can trigger context switches.  In this example, <tt>sleep</tt> is the only such function that appears.</p>
diff --git a/demo/threads.ur b/demo/threads.ur
new file mode 100644
index 00000000..ac6d8cee
--- /dev/null
+++ b/demo/threads.ur
@@ -0,0 +1,17 @@
+fun main () =
+    buf <- Buffer.create;
+    let
+        fun loop prefix delay =
+            let
+                fun loop' n =
+                    Buffer.write buf (prefix ^ ": Message #" ^ show n);
+                    sleep delay;
+                    loop' (n + 1)
+            in
+                loop'
+            end
+    in
+        return <xml><body onload={spawn (loop "A" 5000 0); spawn (loop "B" 3000 100)}>
+          <dyn signal={Buffer.render buf}/>
+        </body></xml>
+    end
diff --git a/demo/threads.urp b/demo/threads.urp
new file mode 100644
index 00000000..153e09a9
--- /dev/null
+++ b/demo/threads.urp
@@ -0,0 +1,3 @@
+
+buffer
+threads
diff --git a/demo/threads.urs b/demo/threads.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/demo/threads.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 2f60b26e..dafc6ded 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -61,7 +61,6 @@ fun impure (e, _) =
       | EFfiApp ("Basis", "new_channel", _) => true
       | EFfiApp ("Basis", "subscribe", _) => true
       | EFfiApp ("Basis", "send", _) => true
-      | EFfiApp ("Basis", "recv", _) => true
       | EFfiApp _ => false
       | EApp ((EFfi _, _), _) => false
       | EApp _ => true
@@ -283,7 +282,6 @@ fun reduce file =
                       | EFfiApp ("Basis", "new_channel", es) => ffi es
                       | EFfiApp ("Basis", "subscribe", es) => ffi es
                       | EFfiApp ("Basis", "send", es) => ffi es
-                      | EFfiApp ("Basis", "recv", es) => ffi es
                       | EFfiApp (_, _, es) => List.concat (map (summarize d) es)
                       | EApp ((EFfi _, _), e) => summarize d e
                       | EApp _ =>
diff --git a/src/monoize.sml b/src/monoize.sml
index d974e373..620e43a5 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -984,6 +984,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                                           loc)), loc)), loc)), loc)), loc),
                  fm)
             end
+
           | L.EApp ((L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), _), _), _), _), t2), _),
                              (L.EFfi ("Basis", "transaction_monad"), _)), _),
                     (L.EApp ((L.ECApp ((L.EFfi ("Basis", "recv"), _), t1), _),
@@ -1002,6 +1003,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                                 t1), loc)), loc)), loc),
                  fm)
             end
+          | L.EFfiApp ("Basis", "recv", _) => poly ()
+
           | L.EApp ((L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), _), _), _), _), t2), _),
                              (L.EFfi ("Basis", "transaction_monad"), _)), _),
                     (L.EAbs (_, _, _,
@@ -1014,11 +1017,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             in
                 ((L'.EAbs ("m2", (L'.TFun (un, mt2), loc), (L'.TFun (un, un), loc),
                            (L'.EAbs ("_", un, un,
-                                     (L'.ESleep (n, (L'.EApp ((L'.ERel 1, loc),
+                                     (L'.ESleep (liftExpInExp 0 n, (L'.EApp ((L'.ERel 1, loc),
                                                               (L'.ERecord [], loc)), loc)),
                                       loc)), loc)), loc),
                  fm)
             end
+          | L.EFfiApp ("Basis", "sleep", _) => poly ()
 
           | L.ECApp ((L.EFfi ("Basis", "source"), _), t) =>
             let
-- 
cgit v1.2.3