Re: Fwd: PATCH - Add cooperative REPL server module

[David Thompson <dthompson2@worcester.edu>]

[-- Attachment #1: Type: text/plain, Size: 543 bytes --]

Mark H Weaver <mhw@netris.org> writes:

> Hi David,
>
> Your latest patch looks great to me.  I have only one request:
> please update the docstrings of 'spawn-coop-repl-server' and
> 'poll-coop-repl-server' to match their current descriptions in
> the manual, except without texinfo markup, as usual.

Done.  Updated patch attached.

> Other than that, I think the patch is ready to push, although of course
> MVars have to go in first.  Now it's my turn to write docs, and tests
> :)

Yay! Thanks.

>    Thanks again!
>        Mark

- Dave


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Add-cooperative-REPL-server-module.patch --]
[-- Type: text/x-diff, Size: 12944 bytes --]

From 9ec93726bf96c38ff1a6b704269578f1a1081962 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Sun, 19 Jan 2014 13:16:02 -0500
Subject: [PATCH] Add cooperative REPL server module.

* module/system/repl/coop-server.scm: New module.

* module/system/repl/repl.scm (start-repl): Extract body to start-repl*.
  (start-repl*): New procedure.
  (run-repl): Extract body to run-repl*.
  (run-repl*): New procedure.

* module/system/repl/server.scm (run-server): Extract body to
  run-server*.
  (run-server*): New procedure.

* doc/ref/api-evaluation.texi: Add docs.

* module/Makefile.am: Add system/repl/coop-server.scm to SYSTEM_SOURCES.
---
 doc/ref/api-evaluation.texi        |  45 +++++++++++
 module/Makefile.am                 |   3 +-
 module/system/repl/coop-server.scm | 160 +++++++++++++++++++++++++++++++++++++
 module/system/repl/repl.scm        |  11 ++-
 module/system/repl/server.scm      |   5 +-
 5 files changed, 220 insertions(+), 4 deletions(-)
 create mode 100644 module/system/repl/coop-server.scm

diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi
index 7d67d9a..27585e6 100644
--- a/doc/ref/api-evaluation.texi
+++ b/doc/ref/api-evaluation.texi
@@ -23,6 +23,7 @@ loading, evaluating, and compiling Scheme code at run time.
 * Local Evaluation::            Evaluation in a local lexical environment.
 * Local Inclusion::             Compile-time inclusion of one file in another.
 * REPL Servers::                Serving a REPL over a socket.
+* Cooperative REPL Servers::    REPL server for single-threaded applications.
 @end menu
 
 
@@ -1281,6 +1282,50 @@ with no arguments.
 Closes the connection on all running server sockets.
 @end deffn
 
+@node Cooperative REPL Servers
+@subsection Cooperative REPL Servers
+
+@cindex Cooperative REPL server
+
+The procedures in this section are provided by
+@lisp
+(use-modules (system repl coop-server))
+@end lisp
+
+Whereas ordinary REPL servers run in their own threads (@pxref{REPL
+Servers}), sometimes it is more convenient to provide REPLs that run at
+specified times within an existing thread, for example in programs
+utilizing an event loop or in single-threaded programs.  This allows for
+safe access and mutation of a program's data structures from the REPL,
+without concern for thread synchronization.
+
+Although the REPLs are run in the thread that calls
+@code{spawn-coop-repl-server} and @code{poll-coop-repl-server},
+dedicated threads are spawned so that the calling thread is not blocked.
+The spawned threads read input for the REPLs and to listen for new
+connections.
+
+Cooperative REPL servers must be polled periodically to evaluate any
+pending expressions by calling @code{poll-coop-repl-server} with the
+object returned from @code{spawn-coop-repl-server}.  The thread that
+calls @code{poll-coop-repl-server} will be blocked for as long as the
+expression takes to be evaluated or if the debugger is entered.
+
+@deffn {Scheme Procedure} spawn-coop-repl-server [server-socket]
+Create and return a new cooperative REPL server object, and spawn a new
+thread to listen for connections on @var{server-socket}.  Proper
+functioning of the REPL server requires that
+@code{poll-coop-repl-server} be called periodically on the returned
+server object.
+@end deffn
+
+@deffn {Scheme Procedure} poll-coop-repl-server coop-server
+Poll the cooperative REPL server @var{coop-server} and apply a pending
+operation if there is one, such as evaluating an expression typed at the
+REPL prompt.  This procedure must be called from the same thread that
+called @code{spawn-coop-repl-server}.
+@end deffn
+
 @c Local Variables:
 @c TeX-master: "guile.texi"
 @c End:
diff --git a/module/Makefile.am b/module/Makefile.am
index 8a7befd..b7960dc 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -360,7 +360,8 @@ SYSTEM_SOURCES =				\
   system/repl/common.scm			\
   system/repl/command.scm			\
   system/repl/repl.scm				\
-  system/repl/server.scm
+  system/repl/server.scm			\
+  system/repl/coop-server.scm
 
 LIB_SOURCES =					\
   statprof.scm					\
diff --git a/module/system/repl/coop-server.scm b/module/system/repl/coop-server.scm
new file mode 100644
index 0000000..41759c9
--- /dev/null
+++ b/module/system/repl/coop-server.scm
@@ -0,0 +1,160 @@
+;;; Cooperative REPL server
+
+;; Copyright (C)  2014 Free Software Foundation, Inc.
+
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+;; 02110-1301 USA
+
+;;; Code:
+
+(define-module (system repl coop-server)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 mvars)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 threads)
+  #:use-module (srfi srfi-9)
+  #:use-module ((system repl repl)
+                #:select (start-repl* prompting-meta-read))
+  #:use-module ((system repl server)
+                #:select (run-server* make-tcp-server-socket close-socket!))
+  #:export (spawn-coop-repl-server
+            poll-coop-repl-server))
+
+(define-record-type <coop-repl-server>
+  (%make-coop-repl-server eval-mvar)
+  coop-repl-server?
+  (eval-mvar coop-repl-server-eval-mvar))
+
+(define (make-coop-repl-server)
+  (%make-coop-repl-server (new-empty-mvar)))
+
+(define (coop-repl-server-eval coop-server opcode . args)
+  "Put a new instruction with the symbolic name OPCODE and an arbitrary
+number of arguments into the evaluation mvar of COOP-SERVER."
+  (put-mvar (coop-repl-server-eval-mvar coop-server)
+            (cons opcode args)))
+
+(define-record-type <coop-repl>
+  (%make-coop-repl read-mvar cont)
+  coop-repl?
+  (read-mvar coop-repl-read-mvar)
+  (cont coop-repl-cont set-coop-repl-cont!))
+
+(define (make-coop-repl)
+  (%make-coop-repl (new-empty-mvar) #f))
+
+(define (coop-repl-read coop-repl)
+  "Read an expression via the thunk stored in COOP-REPL."
+  ((take-mvar (coop-repl-read-mvar coop-repl))))
+
+(define (store-repl-cont cont coop-repl)
+  "Save the partial continuation CONT within COOP-REPL."
+  (set-coop-repl-cont! coop-repl
+                       (lambda (exp)
+                         (coop-repl-prompt
+                          (lambda () (cont exp))))))
+
+(define (coop-repl-prompt thunk)
+  "Apply THUNK within a prompt for cooperative REPLs."
+  (call-with-prompt 'coop-repl-prompt thunk store-repl-cont))
+
+(define (make-coop-reader coop-repl)
+  "Return a new procedure for reading user input from COOP-REPL.  The
+generated procedure passes the responsibility of reading input to
+another thread via an mvar and aborts the cooperative REPL prompt."
+  (lambda (repl)
+    (put-mvar (coop-repl-read-mvar coop-repl)
+              ;; Need to preserve the REPL stack and current module across
+              ;; threads.
+              (let ((stack (fluid-ref *repl-stack*))
+                    (module (current-module)))
+                (lambda ()
+                  (with-fluids ((*repl-stack* stack))
+                    (set-current-module module)
+                    (prompting-meta-read repl)))))
+    (abort-to-prompt 'coop-repl-prompt coop-repl)))
+
+(define (reader-loop coop-server coop-repl)
+  "Run an unbounded loop that reads an expression for COOP-REPL and
+stores the expression within COOP-SERVER for later evaluation."
+  (coop-repl-server-eval coop-server 'eval coop-repl
+                         (coop-repl-read coop-repl))
+  (reader-loop coop-server coop-repl))
+
+(define (poll-coop-repl-server coop-server)
+  "Poll the cooperative REPL server COOP-SERVER and apply a pending
+operation if there is one, such as evaluating an expression typed at the
+REPL prompt.  This procedure must be called from the same thread that
+called spawn-coop-repl-server."
+  (receive (op success?)
+      (try-take-mvar (coop-repl-server-eval-mvar coop-server))
+    (when success?
+      (match op
+        (('new-repl client)
+         (start-repl-client coop-server client))
+        (('eval coop-repl exp)
+         ((coop-repl-cont coop-repl) exp))))))
+
+(define (start-coop-repl coop-server)
+  "Start a new cooperative REPL process for COOP-SERVER."
+  ;; Calling stop-server-and-clients! from a REPL will cause an
+  ;; exception to be thrown when trying to read from the socket that has
+  ;; been closed, so we catch that here.
+  (false-if-exception
+   (let ((coop-repl (make-coop-repl)))
+     (make-thread reader-loop coop-server coop-repl)
+     (start-repl* (current-language) #f (make-coop-reader coop-repl)))))
+
+(define (run-coop-repl-server coop-server server-socket)
+  "Start the cooperative REPL server for COOP-SERVER using the socket
+SERVER-SOCKET."
+  (run-server* server-socket (make-coop-client-proc coop-server)))
+
+(define* (spawn-coop-repl-server
+          #:optional (server-socket (make-tcp-server-socket)))
+  "Create and return a new cooperative REPL server object, and spawn a
+new thread to listen for connections on SERVER-SOCKET.  Proper
+functioning of the REPL server requires that poll-coop-repl-server be
+called periodically on the returned server object."
+  (let ((coop-server (make-coop-repl-server)))
+    (make-thread run-coop-repl-server
+                 coop-server
+                 server-socket)
+    coop-server))
+
+(define (make-coop-client-proc coop-server)
+  "Return a new procedure that is used to schedule the creation of a new
+cooperative REPL for COOP-SERVER."
+  (lambda (client addr)
+    (coop-repl-server-eval coop-server 'new-repl client)))
+
+(define (start-repl-client coop-server client)
+  "Run a cooperative REPL for COOP-SERVER within a prompt.  All input
+and output is sent over the socket CLIENT."
+  (with-continuation-barrier
+   (lambda ()
+     (coop-repl-prompt
+      (lambda ()
+        (with-input-from-port client
+          (lambda ()
+            (with-output-to-port client
+              (lambda ()
+                (with-error-to-port client
+                  (lambda ()
+                    (with-fluids ((*repl-stack* '()))
+                      (save-module-excursion
+                       (lambda ()
+                         (start-coop-repl coop-server))))))))))
+        (close-socket! client))))))
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 1649556..20309e3 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -1,6 +1,7 @@
 ;;; Read-Eval-Print Loop
 
-;; Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011, 2013,
+;;   2014 Free Software Foundation, Inc.
 
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -129,10 +130,13 @@
 ;;;
 
 (define* (start-repl #:optional (lang (current-language)) #:key debug)
+  (start-repl* lang debug prompting-meta-read))
+
+(define (start-repl* lang debug prompting-meta-read)
   ;; ,language at the REPL will update the current-language.  Make
   ;; sure that it does so in a new dynamic scope.
   (parameterize ((current-language lang))
-    (run-repl (make-repl lang debug))))
+    (run-repl* (make-repl lang debug) prompting-meta-read)))
 
 ;; (put 'abort-on-error 'scheme-indent-function 1)
 (define-syntax-rule (abort-on-error string exp)
@@ -144,6 +148,9 @@
       (abort))))
 
 (define (run-repl repl)
+  (run-repl* repl prompting-meta-read))
+
+(define (run-repl* repl prompting-meta-read)
   (define (with-stack-and-prompt thunk)
     (call-with-prompt (default-prompt-tag)
                       (lambda () (start-stack #t (thunk)))
diff --git a/module/system/repl/server.scm b/module/system/repl/server.scm
index 2df7564..cfa1261 100644
--- a/module/system/repl/server.scm
+++ b/module/system/repl/server.scm
@@ -1,6 +1,6 @@
 ;;; Repl server
 
-;; Copyright (C)  2003, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C)  2003, 2010, 2011, 2014 Free Software Foundation, Inc.
 
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -68,6 +68,9 @@
     sock))
 
 (define* (run-server #:optional (server-socket (make-tcp-server-socket)))
+  (run-server* server-socket serve-client))
+
+(define (run-server* server-socket serve-client)
   (define (accept-new-client)
     (catch #t
       (lambda () (accept server-socket))
-- 
1.8.5.2