123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200 |
- ;;; Cooperative REPL server
- ;; Copyright (C) 2014, 2016 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 threads)
- #:use-module (ice-9 q)
- #:use-module (srfi srfi-9)
- #:export (spawn-coop-repl-server
- poll-coop-repl-server))
- ;; Hack to import private bindings from (system repl repl).
- (define-syntax-rule (import-private module sym ...)
- (begin
- (define sym (@@ module sym))
- ...))
- (import-private (system repl repl) start-repl* prompting-meta-read)
- (import-private (system repl server)
- run-server* add-open-socket! close-socket!
- make-tcp-server-socket guard-against-http-request)
- (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))))
- (guard-against-http-request 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)))))))
|