[slime-cvs] CVS slime
trittweiler
trittweiler at common-lisp.net
Sat Jul 5 11:48:12 UTC 2008
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv27837
Modified Files:
swank.lisp swank-sbcl.lisp swank-backend.lisp slime.el
ChangeLog
Log Message:
`M-x slime-lisp-threads' will now contain a summary of what's
currently executed in a thread that was created by Swank.
* swank-backend.lisp (thread-description, set-thread-description):
New interface functions to associate strings with threads.
* swank-sbcl.lisp (thread-description, set-thread-description):
Implemented.
* swank.lisp (call-with-thread-description),
(with-thread-description): New.
(read-from-emacs): Now temporarily sets the thread-description of
the current thread to a summary of what's going to be executed by
the current request.
(defslimefun list-threads): Changed return value to also contain
a thread's description.
* slime.el (slime-list-threads, slime-thread-insert): Adapted to
new return value of LIST-THREADS.
--- /project/slime/cvsroot/slime/swank.lisp 2008/07/04 23:30:10 1.544
+++ /project/slime/cvsroot/slime/swank.lisp 2008/07/05 11:48:11 1.545
@@ -1316,9 +1316,33 @@
(*terminal-io* io))
(funcall function))))
+(defun call-with-thread-description (description thunk)
+ (let* ((thread (current-thread))
+ (old-description (thread-description thread)))
+ (set-thread-description thread description)
+ (unwind-protect (funcall thunk)
+ (set-thread-description thread old-description))))
+
+(defmacro with-thread-description (description &body body)
+ `(call-with-thread-description ,description #'(lambda () , at body)))
+
(defun read-from-emacs ()
"Read and process a request from Emacs."
- (apply #'funcall (funcall (connection.read *emacs-connection*))))
+ (flet ((request-to-string (req)
+ (remove #\Newline
+ (string-trim '(#\Space #\Tab)
+ (prin1-to-string req))))
+ (truncate-string (str n)
+ (if (> (length str) n)
+ (format nil "~A..." (subseq str 0 n))
+ str)))
+ (let ((request (funcall (connection.read *emacs-connection*))))
+ (if (eq *communication-style* :spawn)
+ ;; For `M-x slime-list-threads': Display what threads
+ ;; created by swank are currently doing.
+ (with-thread-description (truncate-string (request-to-string request) 55)
+ (apply #'funcall request))
+ (apply #'funcall request)))))
(defun read-from-control-thread ()
(receive))
@@ -2878,13 +2902,15 @@
a time.")
(defslimefun list-threads ()
- "Return a list ((NAME DESCRIPTION) ...) of all threads."
+ "Return a list ((ID NAME STATUS DESCRIPTION) ...) of all threads."
(setq *thread-list* (all-threads))
(loop for thread in *thread-list*
for name = (thread-name thread)
- collect (list (if (symbolp name) (symbol-name name) name)
+ collect (list (thread-id thread)
+ (if (symbolp name) (symbol-name name) name)
(thread-status thread)
- (thread-id thread))))
+ (thread-description thread)
+ )))
(defslimefun quit-thread-browser ()
(setq *thread-list* nil))
--- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/07/04 22:04:12 1.197
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/07/05 11:48:11 1.198
@@ -1212,7 +1212,22 @@
(if (sb-thread:thread-alive-p thread)
"RUNNING"
"STOPPED"))
-
+ #+#.(swank-backend::sbcl-with-weak-hash-tables)
+ (progn
+ (defparameter *thread-description-map*
+ (make-weak-key-hash-table))
+
+ (defvar *thread-descr-map-lock*
+ (sb-thread:make-mutex :name "thread description map lock"))
+
+ (defimplementation thread-description (thread)
+ (sb-thread:with-mutex (*thread-descr-map-lock*)
+ (or (gethash thread *thread-description-map*) "")))
+
+ (defimplementation set-thread-description (thread description)
+ (sb-thread:with-mutex (*thread-descr-map-lock*)
+ (setf (gethash thread *thread-description-map*) description))))
+
(defimplementation make-lock (&key name)
(sb-thread:make-mutex :name name))
--- /project/slime/cvsroot/slime/swank-backend.lisp 2008/04/24 18:51:03 1.132
+++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/07/05 11:48:12 1.133
@@ -950,6 +950,16 @@
(declare (ignore thread))
"")
+(definterface thread-description (thread)
+ "Return a string describing THREAD."
+ (declare (ignore thread))
+ "")
+
+(definterface set-thread-description (thread description)
+ "Set THREAD's description to DESCRIPTION."
+ (declare (ignore thread description))
+ "")
+
(definterface make-lock (&key name)
"Make a lock for thread synchronization.
Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time."
--- /project/slime/cvsroot/slime/slime.el 2008/07/04 22:55:29 1.943
+++ /project/slime/cvsroot/slime/slime.el 2008/07/05 11:48:12 1.944
@@ -7133,18 +7133,19 @@
(let ((inhibit-read-only t))
(erase-buffer)
(loop for idx from 0
- for (name status id) in threads
- do (slime-thread-insert idx name status id))
+ for (id name status desc) in threads
+ do (slime-thread-insert idx name status desc id))
(goto-char (point-min))
(setq buffer-read-only t)
(pop-to-buffer (current-buffer))))))
-(defun slime-thread-insert (idx name summary id)
+(defun slime-thread-insert (idx name status summary id)
(slime-propertize-region `(thread-id ,idx)
(insert (format "%3s: " id))
(slime-insert-propertized '(face bold) name)
(insert-char ?\ (- 30 (current-column)))
(let ((summary-start (point)))
+ (insert " " status)
(insert " " summary)
(unless (bolp) (insert "\n"))
(indent-rigidly summary-start (point) 2))))
--- /project/slime/cvsroot/slime/ChangeLog 2008/07/04 23:30:44 1.1365
+++ /project/slime/cvsroot/slime/ChangeLog 2008/07/05 11:48:12 1.1366
@@ -1,3 +1,24 @@
+2008-07-05 Tobias C. Rittweiler <tcr at freebits.de>
+
+ `M-x slime-lisp-threads' will now contain a summary of what's
+ currently executed in a thread that was created by Swank.
+
+ * swank-backend.lisp (thread-description, set-thread-description):
+ New interface functions to associate strings with threads.
+ * swank-sbcl.lisp (thread-description, set-thread-description):
+ Implemented.
+
+ * swank.lisp (call-with-thread-description),
+ (with-thread-description): New.
+ (read-from-emacs): Now temporarily sets the thread-description of
+ the current thread to a summary of what's going to be executed by
+ the current request.
+ (defslimefun list-threads): Changed return value to also contain
+ a thread's description.
+
+ * slime.el (slime-list-threads, slime-thread-insert): Adapted to
+ new return value of LIST-THREADS.
+
2008-07-04 Gábor Melis <mega at retes.hu>
* swank.lisp (call-with-redirected-io): Rebind only standard
More information about the slime-cvs
mailing list