From 7e183c5316ab997041cf6ec83192e7a32e49e0fa 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 | 47 +++++++++++ module/Makefile.am | 3 +- module/system/repl/coop-server.scm | 163 +++++++++++++++++++++++++++++++++++++ module/system/repl/repl.scm | 11 ++- module/system/repl/server.scm | 5 +- 5 files changed, 223 insertions(+), 6 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..d366aa1 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 @@ -1275,6 +1276,52 @@ with no arguments. Closes the connection on all running server sockets. @end deffn address@hidden Cooperative REPL Servers address@hidden Cooperative REPL Servers + address@hidden Cooperative REPL server + +The procedures in this section are provided by address@hidden +(use-modules (system repl coop-server)) address@hidden lisp + +Whereas REPL servers run in their own threads, 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. The server must be polled periodically to evaluate any +pending expressions. + address@hidden {Scheme Procedure} make-coop-repl-server +Return a newly allocated cooperative REPL server. address@hidden deffn + address@hidden {Scheme Procedure} coop-repl-server? obj +Return @code{#t} if @var{obj} is a cooperative REPL server, otherwise +return @code{#f}. address@hidden deffn + address@hidden {Scheme Procedure} run-coop-repl-server coop-server [server-socket] +Run the given cooperative REPL server @var{coop-server} in the current +thread, making it available over the given @var{server-socket}. If address@hidden is not provided, it defaults to the socket created +by calling @code{make-tcp-server-socket} with no arguments. address@hidden deffn + address@hidden {Scheme Procedure} spawn-coop-repl-server [server-socket] +Return a newly allocated cooperative REPL server and run the server in a +new thread, making it available over the given @var{server-socket}. If address@hidden is not provided, it defaults to the socket created +by calling @code{make-tcp-server-socket} with no arguments. address@hidden deffn + address@hidden {Scheme Procedure} poll-coop-repl-server coop-server +Poll the cooperative REPL server COOP-SERVER and evaluate a pending +expression if there is one. address@hidden 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..466b8ae --- /dev/null +++ b/module/system/repl/coop-server.scm @@ -0,0 +1,163 @@ +;;; 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!)) + #:use-module (system repl error-handling) + #:export (make-coop-repl-server + coop-repl-server? + run-coop-repl-server + spawn-coop-repl-server + poll-coop-repl-server)) + +(define-record-type + (%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 + (%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) + "Test if there is an expression waiting to be evaluated within +COOP-SERVER and evaluate it if so." + (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 #:optional + (lang (current-language)) #:key debug) + "Start a new cooperative REPL process for COOP-SERVER using the +language LANG." + ;; 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* lang debug (make-coop-reader coop-repl))))) + +(define* (run-coop-repl-server coop-server #:optional + (server-socket (make-tcp-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))) + "Return a newly allocated cooperative REPL server and run the server +in a new thread, making it available over SERVER-SOCKET." + (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..50a14a7 100644 --- a/module/system/repl/repl.scm +++ b/module/system/repl/repl.scm @@ -1,6 +1,6 @@ ;;; 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 +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..9b16c9f 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 @@ -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