From dbe46c1ff2c382530429078ea7a41a31b6c1896c Mon Sep 17 00:00:00 2001 From: David Thompson Date: Sun, 19 Jan 2014 13:16:02 -0500 Subject: Add cooperative REPL server module. Modified-by: Mark H Weaver * 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. --- doc/ref/api-evaluation.texi | 45 +++++++++ module/Makefile.am | 3 +- module/system/repl/coop-server.scm | 193 +++++++++++++++++++++++++++++++++++++ module/system/repl/repl.scm | 14 ++- module/system/repl/server.scm | 5 + 5 files changed, 257 insertions(+), 3 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 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 + (%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 + (%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)) -- cgit v1.2.1