From 6c23c19610c1ab884d0a8ba2f3d1a94d72022303 Mon Sep 17 00:00:00 2001 From: David Thompson 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 + (%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