PATCH - Add cooperative REPL server module

[David Thompson <dthompson2@worcester.edu>]

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


Hey all,

Attached is a patch to add a "cooperative" REPL server to Guile.  This
new type of REPL server allows programs that run an event loop (like a
game or a simulation) to make use of a REPL server that doesn't present
a common pitfall of multithreaded programs: Crashing when 2 threads
write to the same resource at the same time.  The cooperative REPL
ensures that evaluation only happens within the context of a single
thread, and the user can control when evaluation is allowed to happen.

By cooperative, I mean that the client REPL's are run as coroutines
using prompts.  All of the REPL's run within the same thread, the thread
that calls (spawn-coop-server) and later (poll-coop-server).  Reading
user input is passed off to another thread and the REPL prompt is
aborted.  To actually evaluate code, the user must call
(poll-coop-server) periodically.  Only one REPL can evaluate code at a
time.

Things seem to be working well.  I did basic tests by connecting to the
server via telnet and later (when I was confident that I wouldn't crash
Emacs) via Geiser.

This patch is built on top of Mark Weaver's patch to add the (ice-9
mvars) module.

What do you think?

- Dave Thompson


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

From 6c23c19610c1ab884d0a8ba2f3d1a94d72022303 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.

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

* doc/ref/api-evaluation.texi: Add docs.
---
 doc/ref/api-evaluation.texi        |  46 +++++++++++--
 module/system/repl/coop-server.scm | 133 +++++++++++++++++++++++++++++++++++++
 module/system/repl/repl.scm        |   9 ++-
 module/system/repl/server.scm      |   3 +
 4 files changed, 183 insertions(+), 8 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 63b1d60..2fa3e62 100644
--- a/doc/ref/api-evaluation.texi
+++ b/doc/ref/api-evaluation.texi
@@ -1234,11 +1234,6 @@ to evaluate an installed file from source, instead of relying on the
 
 @cindex REPL server
 
-The procedures in this section are provided by
-@lisp
-(use-modules (system repl server))
-@end lisp
-
 When an application is written in Guile, it is often convenient to
 allow the user to be able to interact with it by evaluating Scheme
 expressions in a REPL.
@@ -1248,6 +1243,11 @@ which permits interaction over a local or TCP connection.  Guile itself
 uses them internally to implement the @option{--listen} switch,
 @ref{Command-line Options}.
 
+To use the REPL server, include the following module:
+@lisp
+(use-modules (system repl server))
+@end lisp
+
 @deffn {Scheme Procedure} make-tcp-server-socket [#:host=#f] @
                           [#:addr] [#:port=37146]
 Return a stream socket bound to a given address @var{addr} and port
@@ -1275,6 +1275,42 @@ with no arguments.
 Closes the connection on all running server sockets.
 @end deffn
 
+For some programs, the regular REPL server may be inadequate.  For
+example, the main thread of a realtime simulation runs a loop that
+processes user input and integrates the simulation.  Using the regular
+REPL server, the main thread and a REPL client thread could attempt to
+write to the same resource at the same time, causing the program to
+crash.  Additionally, some programs rely on thread-specific context, so
+evaluating code in another thread does not have the desired effect.  The
+cooperative REPL server solves this problem by running all of the client
+REPLs within the same thread.  In order to prevent blocking, the
+responsibility of reading user input is passed to another thread.  To
+integrate this server within a loop, the loop must poll the server
+periodically to evaluate any pending expressions.
+
+The interface is essentially the same as the regular REPL server module,
+but with slightly different procedure names.
+
+To use the cooperative REPL server, include the following module:
+@lisp
+(use-modules (system repl coop-server))
+@end lisp
+
+@deffn {Scheme Procedure} run-coop-server [server-socket]
+@deffnx {Scheme Procedure} spawn-coop-server [server-socket]
+Create and run a cooperative REPL server, making it available over the
+given @var{server-socket}.  If @var{server-socket} is not provided, it
+defaults to the socket created by calling @code{make-tcp-server-socket}
+with no arguments.
+
+@code{run-coop-server} runs the server in the current thread, whereas
+@code{spawn-coop-server} runs the server in a new thread.
+@end deffn
+
+@deffn {Scheme Procedure} poll-coop-server
+Poll the server and evaluate a pending expression if there is one.
+@end deffn
+
 @c Local Variables:
 @c TeX-master: "guile.texi"
 @c End:
diff --git a/module/system/repl/coop-server.scm b/module/system/repl/coop-server.scm
new file mode 100644
index 0000000..63dda7e
--- /dev/null
+++ b/module/system/repl/coop-server.scm
@@ -0,0 +1,133 @@
+;;; Cooperative REPL server
+
+;; Copyright (C)  2013 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!))
+  #:use-module (system repl error-handling)
+  #:export (run-coop-server
+            spawn-coop-server
+            poll-coop-server))
+
+(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 (set-coop-repl-cont! cont coop-repl)
+  "Set the partial continuation CONT for 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 the cooperative REPL."
+  (call-with-prompt 'coop-coop-repl-prompt thunk set-coop-repl-cont!))
+
+(define current-coop-repl (make-parameter #f))
+
+(define coop-repl-eval-mvar (new-empty-mvar))
+
+(define (coop-repl-eval opcode . args)
+  "Put a new instruction into the evaluation mvar."
+  (put-mvar coop-repl-eval-mvar (cons opcode args)))
+
+(define (coop-reader repl)
+  (put-mvar (coop-repl-read-mvar (current-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-coop-repl-prompt (current-coop-repl)))
+
+(define (reader-loop coop-repl)
+  "Run an unbounded loop that reads an expression for COOP-REPL and
+stores the expression for later evaluation."
+  (coop-repl-eval 'eval coop-repl (coop-repl-read coop-repl))
+  (reader-loop coop-repl))
+
+(define (poll-coop-server)
+  "Test if there is an cooperative REPL expression waiting to be
+evaluated if so, apply it."
+  (receive (op success?)
+      (try-take-mvar coop-repl-eval-mvar)
+    (when success?
+      (match op
+        (('new-repl client)
+         (start-repl-client client))
+        (('eval coop-repl exp)
+         ((coop-repl-cont coop-repl) exp))))))
+
+(define* (start-coop-repl #:optional (lang (current-language)) #:key debug)
+  (let ((coop-repl (make-coop-repl)))
+    (call-with-new-thread
+     (lambda ()
+       (reader-loop coop-repl)))
+    (parameterize ((current-coop-repl coop-repl))
+      (start-repl* lang debug coop-reader))))
+
+(define* (run-coop-server #:optional (server-socket (make-tcp-server-socket)))
+  (run-server* server-socket serve-coop-client))
+
+(define* (spawn-coop-server #:optional (server-socket (make-tcp-server-socket)))
+  (make-thread run-coop-server server-socket))
+
+(define (serve-coop-client client addr)
+  "Schedule the creation of a new cooperative REPL for CLIENT.
+ADDR is unused."
+  (coop-repl-eval 'new-repl client))
+
+(define (start-repl-client client)
+  "Create a new prompt and run the cooperative REPL within it.  All
+input and output happens 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 start-coop-repl))))))))
+        (close-socket! client))))))
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 1649556..1565f2a 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -129,10 +129,13 @@
 ;;;
 
 (define* (start-repl #:optional (lang (current-language)) #:key debug)
+  (start-repl* lang debug prompting-meta-read))
+
+(define (start-repl* lang debug reader)
   ;; ,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) reader)))
 
 ;; (put 'abort-on-error 'scheme-indent-function 1)
 (define-syntax-rule (abort-on-error string exp)
@@ -143,7 +146,7 @@
       (print-exception (current-output-port) #f key args)
       (abort))))
 
-(define (run-repl repl)
+(define (run-repl repl reader)
   (define (with-stack-and-prompt thunk)
     (call-with-prompt (default-prompt-tag)
                       (lambda () (start-stack #t (thunk)))
@@ -155,7 +158,7 @@
        (if (null? (cdr (fluid-ref *repl-stack*)))
            (repl-welcome repl))
        (let prompt-loop ()
-         (let ((exp (prompting-meta-read repl)))
+         (let ((exp (reader repl)))
            (cond
             ((eqv? exp *unspecified*))  ; read error or comment, pass
             ((eq? exp meta-command-token)
diff --git a/module/system/repl/server.scm b/module/system/repl/server.scm
index ec90677..469226d 100644
--- a/module/system/repl/server.scm
+++ b/module/system/repl/server.scm
@@ -85,6 +85,9 @@
                   (sigaction SIGINT #f))))))))
 
 (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 () (call-with-sigint (lambda () (accept server-socket))))
-- 
1.8.5.2