[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.9-204-g5ecc581

[Mark H Weaver]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=5ecc58113a0a50d7a5840e9bfccce25b4f8b30ce

The branch, stable-2.0 has been updated
       via  5ecc58113a0a50d7a5840e9bfccce25b4f8b30ce (commit)
      from  b61025ce0f6f14541b23d93f14dfc60022b91ad6 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 5ecc58113a0a50d7a5840e9bfccce25b4f8b30ce
Author: Mark H Weaver <address@hidden>
Date:   Tue Feb 4 12:18:22 2014 -0500

    REPL Server: Fix 'stop-server-and-clients!'.
    
    * module/system/repl/server.scm: Import (ice-9 match) and (srfi srfi-1).
      (*open-sockets*): Add comment.  This is now a list of pairs with a
      'force-close' procedure in the cdr.
      (close-socket!): Add comment noting that it is unsafe to call this
      from another thread.
      (add-open-socket!): Add 'force-close' argument, and put it in the cdr
      of the '*open-sockets*' entry.
      (stop-server-and-clients!): Use 'match'.  Remove the first element
      from *open-sockets* immediately.  Call the 'force-close' procedure
      instead of 'close-socket!'.
      (errs-to-retry): New variable.
      (run-server): Add a pipe, used in the 'force-close' procedure to
      cleanly shut down the server.  Put the server socket into non-blocking
      mode.  Use 'select' to monitor both the server socket and the pipe.
      Don't call 'add-open-socket!' on the client-socket.  Close the pipe
      and the server socket cleanly when we're asked to shut down.
      (serve-client): Call 'add-open-socket!' with a 'force-close' procedure
      that cancels the thread.  Set the thread cleanup handler to call
      'close-socket!', instead of calling it in the main body.
    
    * doc/ref/api-evaluation.texi (REPL Servers): Add a caveat to the manual
      entry for 'stop-servers-and-clients!'.

-----------------------------------------------------------------------

Summary of changes:
 doc/ref/api-evaluation.texi   |    4 ++
 module/system/repl/server.scm |   98 +++++++++++++++++++++++++++++++----------
 2 files changed, 78 insertions(+), 24 deletions(-)

diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi
index 7d67d9a..d3e6c8c 100644
--- a/doc/ref/api-evaluation.texi
+++ b/doc/ref/api-evaluation.texi
@@ -1279,6 +1279,10 @@ with no arguments.
 
 @deffn {Scheme Procedure} stop-server-and-clients!
 Closes the connection on all running server sockets.
+
+Please note that in the current implementation, the REPL threads are
+cancelled without unwinding their stacks.  If any of them are holding
+mutexes or are within a critical section, the results are unspecified.
 @end deffn
 
 @c Local Variables:
diff --git a/module/system/repl/server.scm b/module/system/repl/server.scm
index 4f3391c..5fefa77 100644
--- a/module/system/repl/server.scm
+++ b/module/system/repl/server.scm
@@ -22,34 +22,43 @@
 (define-module (system repl server)
   #:use-module (system repl repl)
   #:use-module (ice-9 threads)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
   #:export (make-tcp-server-socket
             make-unix-domain-server-socket
             run-server
             spawn-server
             stop-server-and-clients!))
 
+;; List of pairs of the form (SOCKET . FORCE-CLOSE), where SOCKET is a
+;; socket port, and FORCE-CLOSE is a thunk that forcefully shuts down
+;; the socket.
 (define *open-sockets* '())
 
 (define sockets-lock (make-mutex))
 
+;; WARNING: it is unsafe to call 'close-socket!' from another thread.
 (define (close-socket! s)
   (with-mutex sockets-lock
-    (set! *open-sockets* (delq! s *open-sockets*)))
+    (set! *open-sockets* (assq-remove! *open-sockets* s)))
   ;; Close-port could block or raise an exception flushing buffered
   ;; output.  Hmm.
   (close-port s))
 
-(define (add-open-socket! s)
+(define (add-open-socket! s force-close)
   (with-mutex sockets-lock
-    (set! *open-sockets* (cons s *open-sockets*))))
+    (set! *open-sockets* (acons s force-close *open-sockets*))))
 
 (define (stop-server-and-clients!)
   (cond
    ((with-mutex sockets-lock
-      (and (pair? *open-sockets*)
-           (car *open-sockets*)))
-    => (lambda (s)
-         (close-socket! s)
+      (match *open-sockets*
+        (() #f)
+        (((s . force-close) . rest)
+         (set! *open-sockets* rest)
+         force-close)))
+    => (lambda (force-close)
+         (force-close)
          (stop-server-and-clients!)))))
 
 (define* (make-tcp-server-socket #:key
@@ -67,37 +76,79 @@
     (bind sock AF_UNIX path)
     sock))
 
+;; List of errno values from 'select' or 'accept' that should lead to a
+;; retry in 'run-server'.
+(define errs-to-retry
+  (delete-duplicates
+   (filter-map (lambda (name)
+                 (and=> (module-variable the-root-module name)
+                        variable-ref))
+               '(EINTR EAGAIN EWOULDBLOCK))))
+
 (define* (run-server #:optional (server-socket (make-tcp-server-socket)))
+
+  ;; We use a pipe to notify the server when it should shut down.
+  (define shutdown-pipes      (pipe))
+  (define shutdown-read-pipe  (car shutdown-pipes))
+  (define shutdown-write-pipe (cdr shutdown-pipes))
+
+  ;; 'shutdown-server' is called by 'stop-server-and-clients!'.
+  (define (shutdown-server)
+    (display #\!  shutdown-write-pipe)
+    (force-output shutdown-write-pipe))
+
+  (define monitored-ports
+    (list server-socket
+          shutdown-read-pipe))
+
   (define (accept-new-client)
     (catch #t
-      (lambda () (accept server-socket))
-      (lambda (k . args)
-        (cond
-         ((port-closed? server-socket)
-          ;; Shutting down.
-          #f)
-         (else
-          (warn "Error accepting client" k args)
-          ;; Retry after a timeout.
-          (sleep 1)
-          (accept-new-client))))))
-  
+      (lambda ()
+        (let ((ready-ports (car (select monitored-ports '() '()))))
+          ;; If we've been asked to shut down, return #f.
+          (and (not (memq shutdown-read-pipe ready-ports))
+               (accept server-socket))))
+      (lambda k-args
+        (let ((err (system-error-errno k-args)))
+          (cond
+           ((memv err errs-to-retry)
+            (accept-new-client))
+           (else
+            (warn "Error accepting client" k-args)
+            ;; Retry after a timeout.
+            (sleep 1)
+            (accept-new-client)))))))
+
+  ;; Put the socket into non-blocking mode.
+  (fcntl server-socket F_SETFL
+         (logior O_NONBLOCK
+                 (fcntl server-socket F_GETFL)))
+
   (sigaction SIGPIPE SIG_IGN)
-  (add-open-socket! server-socket)
+  (add-open-socket! server-socket shutdown-server)
   (listen server-socket 5)
   (let lp ((client (accept-new-client)))
     ;; If client is false, we are shutting down.
     (if client
         (let ((client-socket (car client))
               (client-addr (cdr client)))
-          (add-open-socket! client-socket)
           (make-thread serve-client client-socket client-addr)
-          (lp (accept-new-client))))))
+          (lp (accept-new-client)))
+        (begin (close shutdown-write-pipe)
+               (close shutdown-read-pipe)
+               (close server-socket)))))
 
 (define* (spawn-server #:optional (server-socket (make-tcp-server-socket)))
   (make-thread run-server server-socket))
 
 (define (serve-client client addr)
+
+  (let ((thread (current-thread)))
+    ;; Close the socket when this thread exits, even if canceled.
+    (set-thread-cleanup! thread (lambda () (close-socket! client)))
+    ;; Arrange to cancel this thread to forcefully shut down the socket.
+    (add-open-socket! client (lambda () (cancel-thread thread))))
+
   (with-continuation-barrier
    (lambda ()
      (parameterize ((current-input-port client)
@@ -105,5 +156,4 @@
                     (current-error-port client)
                     (current-warning-port client))
        (with-fluids ((*repl-stack* '()))
-         (start-repl)))))
-  (close-socket! client))
+         (start-repl))))))


hooks/post-receive
-- 
GNU Guile