From sboukarev at common-lisp.net  Mon Jan  2 04:20:53 2012
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Sun, 01 Jan 2012 20:20:53 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RhZOH-00021d-2a@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory tiger.common-lisp.net:/tmp/cvs-serv7764

Modified Files:
	ChangeLog swank-loader.lisp 
Log Message:
* swank-loader.lisp (lisp-version-string): Append -no-threads to
SBCL without threads.


--- /project/slime/cvsroot/slime/ChangeLog	2011/12/24 17:45:23	1.2291
+++ /project/slime/cvsroot/slime/ChangeLog	2012/01/02 04:20:52	1.2292
@@ -1,3 +1,8 @@
+2012-01-02  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-loader.lisp (lisp-version-string): Append -no-threads to
+	SBCL without threads.
+
 2011-12-24  Stas Boukarev  <stassats at gmail.com>
 
 	* slime.el (slime-init-command): Don't call
--- /project/slime/cvsroot/slime/swank-loader.lisp	2011/12/10 12:33:28	1.114
+++ /project/slime/cvsroot/slime/swank-loader.lisp	2012/01/02 04:20:52	1.115
@@ -73,7 +73,11 @@
 (defun lisp-version-string ()
   #+(or clozure cmu) (substitute-if #\_ (lambda (x) (find x " /"))
                                     (lisp-implementation-version))
-  #+(or cormanlisp scl sbcl) (lisp-implementation-version)
+  #+(or cormanlisp scl) (lisp-implementation-version)
+  #+sbcl (format nil "~a~:[~;-no-threads~]"
+                 (lisp-implementation-version)
+                 #+sb-thread nil
+                 #-sb-thread t)
   #+lispworks (lisp-implementation-version)
   #+allegro   (format nil "~A~A~A~A"
                       excl::*common-lisp-version-number*




From heller at common-lisp.net  Fri Jan  6 09:02:43 2012
From: heller at common-lisp.net (CVS User heller)
Date: Fri, 06 Jan 2012 01:02:43 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1Rj5hD-0001VR-Dx@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory tiger.common-lisp.net:/tmp/cvs-serv5770

Modified Files:
	ChangeLog swank-allegro.lisp swank-backend.lisp swank-ccl.lisp 
	swank-lispworks.lisp swank-sbcl.lisp swank.lisp 
Log Message:
Add a "sentinel thread" to protect access to global lists.

* swank.lisp (start-sentinel, sentinel, send-to-sentinel)
(sentinel-serve, sentinel-stop-server, sentinel-maybe-exit): New.
(make-connection, close-connection, setup-server, stop-server):
Use the sentinel.
(close-connection%): Factored out.
* swank-backend.lisp (register-thread, find-registered): New.
* swank-allegro.lisp: Implement it.
* swank-ccl.lisp:
* swank-lispworks.lisp:
* swank-sbcl.lisp:

--- /project/slime/cvsroot/slime/ChangeLog	2012/01/02 04:20:52	1.2292
+++ /project/slime/cvsroot/slime/ChangeLog	2012/01/06 09:02:43	1.2293
@@ -1,3 +1,18 @@
+2012-01-06  Helmut Eller  <heller at common-lisp.net>
+
+	Add a "sentinel thread" to protect access to global lists.
+
+	* swank.lisp (start-sentinel, sentinel, send-to-sentinel)
+	(sentinel-serve, sentinel-stop-server, sentinel-maybe-exit): New.
+	(make-connection, close-connection, setup-server, stop-server):
+	Use the sentinel.
+	(close-connection%): Factored out.
+	* swank-backend.lisp (register-thread, find-registered): New.
+	* swank-allegro.lisp: Implement it.
+	* swank-ccl.lisp:
+	* swank-lispworks.lisp:
+	* swank-sbcl.lisp:
+
 2012-01-02  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-loader.lisp (lisp-version-string): Append -no-threads to
--- /project/slime/cvsroot/slime/swank-allegro.lisp	2011/12/03 12:03:37	1.149
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2012/01/06 09:02:43	1.150
@@ -831,6 +831,25 @@
      (mp:process-wait-with-timeout "receive-if" 0.5
                                    #'mp:gate-open-p (mailbox.gate mbox)))))
 
+(let ((alist '())
+      (lock (mp:make-process-lock :name "register-thread")))
+
+  (defimplementation register-thread (name thread)
+    (declare (type symbol name))
+    (mp:with-process-lock (lock)
+      (etypecase thread
+        (null 
+         (setf alist (delete name alist :key #'car)))
+        (mp:process
+         (let ((probe (assoc name alist)))
+           (cond (probe (setf (cdr probe) thread))
+                 (t (setf alist (acons name thread alist))))))))
+    nil)
+
+  (defimplementation find-registered (name)
+    (mp:with-process-lock (lock)
+      (cdr (assoc name alist)))))
+
 (defimplementation set-default-initial-binding (var form)
   (push (cons var form)
         #+(version>= 9 0)
--- /project/slime/cvsroot/slime/swank-backend.lisp	2011/12/10 12:34:09	1.215
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2012/01/06 09:02:43	1.216
@@ -1340,7 +1340,8 @@
   nil)
 
 (definterface send (thread object)
-  "Send OBJECT to thread THREAD.")
+  "Send OBJECT to thread THREAD."
+  object)
 
 (definterface receive (&optional timeout)
   "Return the next message from current thread's mailbox."
@@ -1349,6 +1350,18 @@
 (definterface receive-if (predicate &optional timeout)
   "Return the first message satisfiying PREDICATE.")
 
+(definterface register-thread (name thread)
+  "Associate the thread THREAD with the symbol NAME.
+The thread can then be retrieved with `find-registered'.
+If THREAD is nil delete the association."
+  (declare (ignore name thread))
+  nil)
+
+(definterface find-registered (name)
+  "Find the thread that was registered for the symbol NAME.
+Return nil if the no thread was registred or if the tread is dead."
+  nil)
+
 (definterface set-default-initial-binding (var form)
   "Initialize special variable VAR by default with FORM.
 
--- /project/slime/cvsroot/slime/swank-ccl.lisp	2011/11/27 21:47:15	1.24
+++ /project/slime/cvsroot/slime/swank-ccl.lisp	2012/01/06 09:02:43	1.25
@@ -760,6 +760,25 @@
      (when (eq timeout t) (return (values nil t)))
      (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 1))))
 
+(let ((alist '())
+      (lock (ccl:make-lock "register-thread")))
+
+  (defimplementation register-thread (name thread)
+    (declare (type symbol name))
+    (ccl:with-lock-grabbed (lock)
+      (etypecase thread
+        (null 
+         (setf alist (delete name alist :key #'car)))
+        (ccl:process
+         (let ((probe (assoc name alist)))
+           (cond (probe (setf (cdr probe) thread))
+                 (t (setf alist (acons name thread alist))))))))
+    nil)
+
+  (defimplementation find-registered (name)
+    (ccl:with-lock-grabbed (lock)
+      (cdr (assoc name alist)))))
+
 (defimplementation set-default-initial-binding (var form)
   (eval `(ccl::def-standard-initial-binding ,var ,form)))
 
--- /project/slime/cvsroot/slime/swank-lispworks.lisp	2011/11/27 21:47:15	1.146
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp	2012/01/06 09:02:43	1.147
@@ -945,6 +945,26 @@
       (setf (mailbox.queue mbox)
             (nconc (mailbox.queue mbox) (list message))))))
 
+(let ((alist '())
+      (lock (mp:make-lock :name "register-thread")))
+
+  (defimplementation register-thread (name thread)
+    (declare (type symbol name))
+    (mp:with-lock (lock)
+      (etypecase thread
+        (null 
+         (setf alist (delete name alist :key #'car)))
+        (mp:process
+         (let ((probe (assoc name alist)))
+           (cond (probe (setf (cdr probe) thread))
+                 (t (setf alist (acons name thread alist))))))))
+    nil)
+
+  (defimplementation find-registered (name)
+    (mp:with-lock (lock)
+      (cdr (assoc name alist)))))
+
+
 (defimplementation set-default-initial-binding (var form)
   (setq mp:*process-initial-bindings* 
         (acons var `(eval (quote ,form))
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2011/12/21 16:19:52	1.300
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2012/01/06 09:02:43	1.301
@@ -1578,6 +1578,26 @@
              (return (car tail))))
          (when (eq timeout t) (return (values nil t)))
          (condition-timed-wait waitq mutex 0.2)))))
+
+  (let ((alist '())
+        (mutex (sb-thread:make-mutex :name "register-thread")))
+
+    (defimplementation register-thread (name thread)
+      (declare (type symbol name))
+      (sb-thread:with-mutex (mutex)
+        (etypecase thread
+          (null 
+           (setf alist (delete name alist :key #'car)))
+          (sb-thread:thread
+           (let ((probe (assoc name alist)))
+             (cond (probe (setf (cdr probe) thread))
+                   (t (setf alist (acons name thread alist))))))))
+      nil)
+
+    (defimplementation find-registered (name)
+      (sb-thread:with-mutex (mutex) 
+        (cdr (assoc name alist)))))
+
   )
 
 (defimplementation quit-lisp ()
--- /project/slime/cvsroot/slime/swank.lisp	2011/12/24 05:01:25	1.781
+++ /project/slime/cvsroot/slime/swank.lisp	2012/01/06 09:02:43	1.782
@@ -259,21 +259,9 @@
   (active-threads '() :type list)
   )
 
-(defvar *connections* '()
-  "List of all active connections, with the most recent at the front.")
-
 (defvar *emacs-connection* nil
   "The connection to Emacs currently in use.")
 
-(defun default-connection ()
-  "Return the 'default' Emacs connection.
-This connection can be used to talk with Emacs when no specific
-connection is in use, i.e. *EMACS-CONNECTION* is NIL.
-
-The default connection is defined (quite arbitrarily) as the most
-recently established one."
-  (first *connections*))
-
 (defun make-connection (socket stream style)
   (let ((conn (funcall (ecase style
                          (:spawn 
@@ -284,7 +272,7 @@
                        :socket-io stream
                        :communication-style style)))
     (run-hook *new-connection-hook* conn)
-    (push conn *connections*)
+    (send-to-sentinel `(:add-connection ,conn))
     conn))
 
 (defslimefun ping (tag)
@@ -581,6 +569,83 @@
     (setf (documentation ',name 'variable) ,doc)))
 
 
+;;;;; Sentinel
+;;;
+;;; The sentinel thread manages some global lists.
+;;; FIXME: Overdesigned?
+
+(defvar *connections* '()
+  "List of all active connections, with the most recent at the front.")
+
+(defvar *servers* '()
+  "A list ((server-socket port thread) ...) describing the listening sockets.
+Used to close sockets on server shutdown or restart.")
+
+;; FIXME: we simply access the global variable here.  We could ask the
+;; sentinel thread instead but then we still have the problem that the
+;; connection could be closed before we use it.  
+(defun default-connection ()
+  "Return the 'default' Emacs connection.
+This connection can be used to talk with Emacs when no specific
+connection is in use, i.e. *EMACS-CONNECTION* is NIL.
+
+The default connection is defined (quite arbitrarily) as the most
+recently established one."
+  (car *connections*))
+
+(defun start-sentinel () 
+  (unless (find-registered 'sentinel)
+    (let ((thread (spawn #'sentinel :name "Swank Sentinel")))
+      (register-thread 'sentinel thread))))
+
+(defun sentinel ()
+  (catch 'exit-sentinel
+    (loop (sentinel-serve (receive)))))
+
+(defun send-to-sentinel (msg)
+  (let ((sentinel (find-registered 'sentinel)))
+    (cond (sentinel (send sentinel msg))
+          (t (sentinel-serve msg)))))
+
+(defun sentinel-serve (msg)
+  (destructure-case msg
+    ((:add-connection conn)
+     (push conn *connections*))
+    ((:close-connection connection condition backtrace)
+     (close-connection% connection condition backtrace)
+     (sentinel-maybe-exit))
+    ((:add-server socket port thread)
+     (push (list socket port thread) *servers*))
+    ((:stop-server key port)
+     (sentinel-stop-server key port)
+     (sentinel-maybe-exit))))
+
+(defun sentinel-stop-server (key value)
+  (let ((probe (find value *servers* :key (ecase key 
+                                            (:socket #'car)
+                                            (:port #'cadr)))))
+    (cond (probe 
+           (setq *servers* (delete probe *servers*))
+           (destructuring-bind (socket _port thread) probe
+             (declare (ignore _port))
+             (ignore-errors (close-socket socket))
+             (when (and thread 
+                        (thread-alive-p thread)
+                        (not (eq thread (current-thread))))
+               (kill-thread thread))))
+          (t
+           (warn "No server for ~s: ~s" key value)))))
+
+(defun sentinel-maybe-exit ()
+  (when (and (null *connections*)
+             (null *servers*)
+             (and (current-thread)
+                  (eq (find-registered 'sentinel)
+                      (current-thread))))
+    (register-thread 'sentinel nil)
+    (throw 'exit-sentinel nil)))
+
+
 ;;;;; Misc
 
 (defun use-threads-p ()
@@ -684,11 +749,6 @@
   "Default value of :dont-close argument to start-server and
   create-server.")
 
-(defvar *listener-sockets* nil
-  "A property list of lists containing style, socket pairs used 
-   by swank server listeners, keyed on socket port number. They 
-   are used to close sockets on server shutdown or restart.")
-
 (defun start-server (port-file &key (style *communication-style*)
                                     (dont-close *dont-close*))
   "Start the server and write the listen port number to PORT-FILE.
@@ -714,48 +774,28 @@
 (defparameter *loopback-interface* "127.0.0.1")
 
 (defun setup-server (port announce-fn style dont-close backlog)
-  (declare (type function announce-fn))
   (init-log-output)
   (let* ((socket (create-socket *loopback-interface* port :backlog backlog))
-         (local-port (local-port socket)))
-    (funcall announce-fn local-port)
-    (flet ((serve ()
-             (accept-connections socket style dont-close)))
+         (port (local-port socket)))
+    (funcall announce-fn port)
+    (labels ((serve () (accept-connections socket style dont-close))
+             (note () (send-to-sentinel `(:add-server ,socket ,port 
+                                                      ,(current-thread))))
+             (serve-loop () (note) (loop do (serve) while dont-close)))
       (ecase style
-        (:spawn
-         (initialize-multiprocessing
-          (lambda ()
-            (spawn (lambda ()
-                     (cond ((not dont-close) (serve))
-                           (t (loop (ignore-errors (serve))))))
-                   :name (cat "Swank " (princ-to-string port))))))
-        ((:fd-handler :sigio)
-         (add-fd-handler socket (lambda () (serve))))
-        ((nil) (loop do (serve) while dont-close)))
-      (setf (getf *listener-sockets* port) (list style socket))
-      local-port)))
+        (:spawn (initialize-multiprocessing 
+                 (lambda ()
+                   (start-sentinel)
+                   (spawn #'serve-loop :name (format nil "Swank ~s" port)))))
+        ((:fd-handler :sigio) 
+         (note) 
+         (add-fd-handler socket #'serve))
+        ((nil) (serve-loop))))
+    port))
 
 (defun stop-server (port)
   "Stop server running on PORT."
-  (let* ((socket-description (getf *listener-sockets* port))
-         (style (first socket-description))
-         (socket (second socket-description)))
-    (ecase style
-      (:spawn
-       (let ((thread-position
-              (position-if 
-               (lambda (x) 
-                 (string-equal (second x)
-                               (cat "Swank " (princ-to-string port))))
-               (list-threads))))
-         (when thread-position
-           (kill-nth-thread (1- thread-position))
-           (close-socket socket)
-           (remf *listener-sockets* port))))
-      ((:fd-handler :sigio)
-       (remove-fd-handlers socket)
-       (close-socket socket)
-       (remf *listener-sockets* port)))))
+  (send-to-sentinel `(:stop-server :port ,port)))
 
 (defun restart-server (&key (port default-server-port)
                        (style *communication-style*)
@@ -775,7 +815,9 @@
                   (unless dont-close
                     (close-socket socket)))))
     (authenticate-client client)
-    (serve-requests (make-connection socket client style))))
+    (serve-requests (make-connection socket client style))
+    (unless dont-close
+      (send-to-sentinel `(:stop-server :socket ,socket)))))
 
 (defun authenticate-client (stream)
   (let ((secret (slime-secret)))
@@ -895,7 +937,10 @@
 (defun current-socket-io ()
   (connection.socket-io *emacs-connection*))
 
-(defun close-connection (c condition backtrace)
+(defun close-connection (connection condition backtrace)
+  (send-to-sentinel `(:close-connection ,connection ,condition ,backtrace)))
+
+(defun close-connection% (c condition backtrace)
   (let ((*debugger-hook* nil))
     (log-event "close-connection: ~a ...~%" condition))
   (format *log-output* "~&;; swank:close-connection: ~A~%"
@@ -1342,6 +1387,7 @@
 (defun clear-user-input  ()
   (clear-input (connection.user-input *emacs-connection*)))
 
+;; FIXME: not thread save.
 (defvar *tag-counter* 0)
 
 (defun make-tag () 




From heller at common-lisp.net  Fri Jan  6 09:57:15 2012
From: heller at common-lisp.net (CVS User heller)
Date: Fri, 06 Jan 2012 01:57:15 -0800
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1Rj6Xz-0003rA-LD@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory tiger.common-lisp.net:/tmp/cvs-serv14824/contrib

Modified Files:
	ChangeLog swank-mrepl.lisp 
Log Message:
* swank-mrepl.lisp (send-prompt): Fix use of OR.
Reported by Mark H. David.

--- /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/30 17:10:13	1.529
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2012/01/06 09:57:15	1.530
@@ -1,3 +1,8 @@
+2012-01-06  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-mrepl.lisp (send-prompt): Fix use of OR.
+	Reported by Mark H. David.
+
 2011-12-30  Nikodemus Siivola  <nikodemus at random-state.net>
 
 	* slime-cl-indent.el (common-lisp-looking-at-keyword): New function. Looks
--- /project/slime/cvsroot/slime/contrib/swank-mrepl.lisp	2011/12/03 12:03:43	1.2
+++ /project/slime/cvsroot/slime/contrib/swank-mrepl.lisp	2012/01/06 09:57:15	1.3
@@ -28,7 +28,7 @@
 
 (defpackage :swank-mrepl
   (:use :cl :swank-api)
-  (:export #:create-listener))
+  (:export #:create-mrepl))
 
 (in-package :swank-mrepl)
 
@@ -107,7 +107,7 @@
 
 (defun send-prompt (channel)
   (with-slots (env remote) channel
-    (let ((pkg (cdr (or (assoc '*package* env) *package*)))
+    (let ((pkg (or (cdr (assoc '*package* env)) *package*))
 	  (out (cdr (assoc '*standard-output* env)))
 	  (in (cdr (assoc '*standard-input* env))))
       (when out (force-output out))