Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

(thread-id, find-thread): New backend function.

  • Loading branch information...
commit 12da8214307286332abaacf5e8b9fb77f075087f 1 parent d68b527
Helmut Eller authored
View
29 swank-abcl.lisp
@@ -309,10 +309,27 @@ Should work (with a patched xref.lisp) but is it any use without find-definition
(defimplementation startup-multiprocessing ()
#+nil(mp:start-scheduler))
-
(defimplementation spawn (fn &key name)
(ext:make-thread (lambda () (funcall fn))))
+(defvar *thread-props-lock* (ext:make-thread-lock))
+
+(defvar *thread-props* (make-hash-table) ; should be a weak table
+ "A hashtable mapping threads to a plist.")
+
+(defvar *thread-id-counter* 0)
+
+(defimplementation thread-id (thread)
+ (ext:with-thread-lock (*thread-props-lock*)
+ (or (getf (gethash thread *thread-props*) 'id)
+ (setf (getf (gethash thread *thread-props*) 'id)
+ (incf *thread-id-counter*)))))
+
+(defimplementation find-thread (id)
+ (find id (all-threads)
+ :test (lambda (thread)
+ (getf (gethash thread *thread-props*) 'id))))
+
(defimplementation thread-name (thread)
(princ-to-string thread))
@@ -337,15 +354,11 @@ Should work (with a patched xref.lisp) but is it any use without find-definition
(defimplementation kill-thread (thread)
(ext:destroy-thread thread))
-(defvar *mailbox-lock* (ext:make-thread-lock))
-
-(defvar *thread-mailbox* (make-hash-table))
-
(defun mailbox (thread)
"Return THREAD's mailbox."
- (ext:with-thread-lock (*mailbox-lock*)
- (or (gethash thread *thread-mailbox*)
- (setf (gethash thread *thread-mailbox*)
+ (ext:with-thread-lock (*thread-props-lock*)
+ (or (getf (gethash thread *thread-props*) 'mailbox)
+ (setf (getf (gethash thread *thread-props*) 'mailbox)
(ext:make-mailbox)))))
(defimplementation send (thread object)
View
13 swank-allegro.lisp
@@ -297,6 +297,19 @@
(defimplementation spawn (fn &key name)
(mp:process-run-function name fn))
+(defvar *id-lock* (mp:make-process-lock :name "id lock"))
+(defvar *thread-id-counter* 0)
+
+(defimplementation thread-id (thread)
+ (mp:with-process-lock (*id-lock*)
+ (or (getf (mp:process-property-list thread) 'id)
+ (setf (getf (mp:process-property-list thread) 'id)
+ (incf *thread-id-counter*)))))
+
+(defimplementation find-thread (id)
+ (find id mp:*all-processes*
+ :key (lambda (p) (getf (mp:process-property-list p) 'id))))
+
(defimplementation thread-name (thread)
(mp:process-name thread))
View
17 swank-backend.lisp
@@ -180,6 +180,9 @@ This is used to resolve filenames without directory component."
"Return a suitable initial value for SWANK:*READTABLE-ALIST*."
'())
+(definterface quit-lisp ()
+ "Exit the current lisp image.")
+
;;;; Compilation
@@ -550,6 +553,17 @@ normal function."
(definterface spawn (fn &key name)
"Create a new thread to call FN.")
+(definterface thread-id (thread)
+ "Return an Emacs-parsable object to identify THREAD.
+
+Ids should be comparable with equal, i.e.:
+ (equal (thread-id <t1>) (thread-id <t2>)) <==> (eq <t1> <t2>)")
+
+(definterface find-thread (id)
+ "Return the thread for ID.
+ID should be an id previously obtained with THREAD-ID.
+Can return nil if the thread no longer exists.")
+
(definterface thread-name (thread)
"Return the name of THREAD.
@@ -599,6 +613,3 @@ Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time."
(definterface receive ()
"Return the next message from current thread's mailbox.")
-
-(definterface quit-lisp ()
- "Exit the current lisp image.")
View
11 swank-cmucl.lisp
@@ -1735,6 +1735,17 @@ The `symbol-value' of each element is a type tag.")
(defimplementation spawn (fn &key (name "Anonymous"))
(mp:make-process fn :name name))
+ (defvar *thread-id-counter* 0)
+
+ (defimplementation thread-id (thread)
+ (or (getf (mp:process-property-list thread) 'id)
+ (setf (getf (mp:process-property-list thread) 'id)
+ (incf *thread-id-counter*))))
+
+ (defimplementation find-thread (id)
+ (find id (all-threads)
+ :key (lambda (p) (getf (mp:process-property-list p) 'id))))
+
(defimplementation thread-name (thread)
(mp:process-name thread))
View
20 swank-lispworks.lisp
@@ -91,7 +91,7 @@
(defimplementation call-without-interrupts (fn)
(lw:without-interrupts (funcall fn)))
-
+
(defimplementation getpid ()
#+win32 (win32:get-current-process-id)
#-win32 (system::getpid))
@@ -196,8 +196,9 @@ Return NIL if the symbol is unbound."
"Unwind FRAME N times."
(do ((frame frame (dbg::frame-next frame))
(i n (if (interesting-frame-p frame) (1- i) i)))
- ((and (interesting-frame-p frame) (zerop i)) frame)
- (assert frame)))
+ ((or (not frame)
+ (and (interesting-frame-p frame) (zerop i)))
+ frame)))
(defun nth-frame (index)
(nth-next-frame *sldb-top-frame* index))
@@ -537,6 +538,19 @@ Return NIL if the symbol is unbound."
:key (lambda (x) (symbol-package (car x))))))
(mp:process-run-function name () fn)))
+(defvar *id-lock* (mp:make-lock))
+(defvar *thread-id-counter* 0)
+
+(defimplementation thread-id (thread)
+ (mp:with-lock (*id-lock*)
+ (or (getf (mp:process-plist thread) 'id)
+ (setf (getf (mp:process-plist thread) 'id)
+ (incf *thread-id-counter*)))))
+
+(defimplementation find-thread (id)
+ (find id (mp:list-all-processes)
+ :key (lambda (p) (getf (mp:process-plist p) 'id))))
+
(defimplementation thread-name (thread)
(mp:process-name thread))
View
6 swank-openmcl.lisp
@@ -520,6 +520,12 @@ out IDs for.")
(defimplementation startup-multiprocessing ())
+(defimplementation thread-id (thread)
+ (ccl::process-serial-number thread))
+
+(defimplementation find-thread (id)
+ (find id (ccl:all-processes) :key #'ccl::process-serial-number))
+
(defimplementation thread-name (thread)
(ccl::process-name thread))
View
7 swank-sbcl.lisp
@@ -742,6 +742,13 @@ stack."
(defimplementation startup-multiprocessing ())
+ (defimplementation thread-id (thread)
+ thread)
+
+ (defimplementation find-thread (id)
+ (if (member id (all-threads))
+ id))
+
(defimplementation thread-name (thread)
(format nil "Thread ~D" thread))
Please sign in to comment.
Something went wrong with that request. Please try again.