Add cooperative REPL server module.coop-repl-servers

Modified-by: Mark H Weaver <mhw@netris.org>

* 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 (Cooperative REPL Servers): New node.

* module/Makefile.am (SYSTEM_SOURCES): Add system/repl/coop-server.scm.

5 files changed, 257 insertions, 3 deletions

diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi
index 7d67d9a21..27585e6cc 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 cbdbbc9a2..5f777b6f6 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -366,7 +366,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 000000000..c19dda191
--- /dev/null
+++ b/module/system/repl/coop-server.scm
@@ -0,0 +1,193 @@
+;;; 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 receive)
+  #:use-module (ice-9 threads)
+  #:use-module (ice-9 q)
+  #: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
+                                      add-open-socket! close-socket!))
+  #:export (spawn-coop-repl-server
+            poll-coop-repl-server))
+
+(define-record-type <coop-repl-server>
+  (%make-coop-repl-server mutex queue)
+  coop-repl-server?
+  (mutex coop-repl-server-mutex)
+  (queue coop-repl-server-queue))
+
+(define (make-coop-repl-server)
+  (%make-coop-repl-server (make-mutex) (make-q)))
+
+(define (coop-repl-server-eval coop-server opcode . args)
+  "Queue a new instruction with the symbolic name OPCODE and an arbitrary
+number of arguments, to be processed the next time COOP-SERVER is polled."
+  (with-mutex (coop-repl-server-mutex coop-server)
+    (enq! (coop-repl-server-queue coop-server)
+          (cons opcode args))))
+
+(define-record-type <coop-repl>
+  (%make-coop-repl mutex condvar thunk cont)
+  coop-repl?
+  (mutex coop-repl-mutex)
+  (condvar coop-repl-condvar)  ; signaled when thunk becomes non-#f
+  (thunk coop-repl-read-thunk set-coop-repl-read-thunk!)
+  (cont coop-repl-cont set-coop-repl-cont!))
+
+(define (make-coop-repl)
+  (%make-coop-repl (make-mutex) (make-condition-variable) #f #f))
+
+(define (coop-repl-read coop-repl)
+  "Read an expression via the thunk stored in COOP-REPL."
+  (let ((thunk
+         (with-mutex (coop-repl-mutex coop-repl)
+           (unless (coop-repl-read-thunk coop-repl)
+             (wait-condition-variable (coop-repl-condvar coop-repl)
+                                      (coop-repl-mutex coop-repl)))
+           (let ((thunk (coop-repl-read-thunk coop-repl)))
+             (unless thunk
+               (error "coop-repl-read: condvar signaled, but thunk is #f!"))
+             (set-coop-repl-read-thunk! coop-repl #f)
+             thunk))))
+    (thunk)))
+
+(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 and aborts the cooperative REPL prompt."
+  (lambda (repl)
+    (let ((read-thunk
+           ;; 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))))))
+      (with-mutex (coop-repl-mutex coop-repl)
+        (when (coop-repl-read-thunk coop-repl)
+          (error "coop-reader: read-thunk is not #f!"))
+        (set-coop-repl-read-thunk! coop-repl read-thunk)
+        (signal-condition-variable (coop-repl-condvar coop-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."
+  (let ((op (with-mutex (coop-repl-server-mutex coop-server)
+              (let ((queue (coop-repl-server-queue coop-server)))
+                (and (not (q-empty? queue))
+                     (deq! queue))))))
+    (when op
+      (match op
+        (('new-repl client)
+         (start-repl-client coop-server client))
+        (('eval coop-repl exp)
+         ((coop-repl-cont coop-repl) exp))))
+    *unspecified*))
+
+(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."
+
+  ;; Add the client to the list of open sockets, with a 'force-close'
+  ;; procedure that closes the underlying file descriptor.  We do it
+  ;; this way because we cannot close the port itself safely from
+  ;; another thread.
+  (add-open-socket! client (lambda () (close-fdes (fileno client))))
+
+  (with-continuation-barrier
+   (lambda ()
+     (coop-repl-prompt
+      (lambda ()
+        (parameterize ((current-input-port client)
+                       (current-output-port client)
+                       (current-error-port client)
+                       (current-warning-port client))
+          (with-fluids ((*repl-stack* '()))
+            (save-module-excursion
+             (lambda ()
+               (start-coop-repl coop-server)))))
+
+        ;; This may fail if 'stop-server-and-clients!' is called,
+        ;; because the 'force-close' procedure above closes the
+        ;; underlying file descriptor instead of the port itself.
+        (false-if-exception
+         (close-socket! client)))))))
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 16495560c..5b27125f1 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
@@ -107,6 +108,8 @@
 ;; to be able to re-use the existing readline machinery.
 ;;
 ;; Catches read errors, returning *unspecified* in that case.
+;;
+;; Note: although not exported, this is used by (system repl coop-server)
 (define (prompting-meta-read repl)
   (catch #t
     (lambda ()
@@ -129,10 +132,14 @@
 ;;;
 
 (define* (start-repl #:optional (lang (current-language)) #:key debug)
+  (start-repl* lang debug prompting-meta-read))
+
+;; Note: although not exported, this is used by (system repl coop-server)
+(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 +151,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 5fefa77ab..ff9ee5cbc 100644
--- a/module/system/repl/server.scm
+++ b/module/system/repl/server.scm
@@ -38,6 +38,7 @@
 (define sockets-lock (make-mutex))
 
 ;; WARNING: it is unsafe to call 'close-socket!' from another thread.
+;; Note: although not exported, this is used by (system repl coop-server)
 (define (close-socket! s)
   (with-mutex sockets-lock
     (set! *open-sockets* (assq-remove! *open-sockets* s)))
@@ -45,6 +46,7 @@
   ;; output.  Hmm.
   (close-port s))
 
+;; Note: although not exported, this is used by (system repl coop-server)
 (define (add-open-socket! s force-close)
   (with-mutex sockets-lock
     (set! *open-sockets* (acons s force-close *open-sockets*))))
@@ -86,7 +88,10 @@
                '(EINTR EAGAIN EWOULDBLOCK))))
 
 (define* (run-server #:optional (server-socket (make-tcp-server-socket)))
+  (run-server* server-socket serve-client))
 
+;; Note: although not exported, this is used by (system repl coop-server)
+(define (run-server* server-socket serve-client)
   ;; We use a pipe to notify the server when it should shut down.
   (define shutdown-pipes      (pipe))
   (define shutdown-read-pipe  (car shutdown-pipes))