[slime-cvs] CVS slime
CVS User heller
heller at common-lisp.net
Fri Jan 6 09:02:43 UTC 2012
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 ()
More information about the slime-cvs
mailing list