1.0.46.41: double-check simple functions in looks_like_valid_lisp_pointer_p

[sbcl.git] / src / code / target-thread.lisp

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 25a6c17..8723a7f 100644 (file)
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -59,17 +59,9 @@ offending thread using THREAD-ERROR-THREAD."))
 to be joined. The offending thread can be accessed using
 THREAD-ERROR-THREAD."))
 
-(defun join-thread-error-thread (condition)
+(define-deprecated-function :late "1.0.29.17" join-thread-error-thread thread-error-thread
+    (condition)
   (thread-error-thread condition))
-(define-compiler-macro join-thread-error-thread (condition)
-  (deprecation-warning 'join-thread-error-thread 'thread-error-thread)
-  `(thread-error-thread ,condition))
-
-#!+sb-doc
-(setf
- (fdocumentation 'join-thread-error-thread 'function)
- "The thread that we failed to join. Deprecated, use THREAD-ERROR-THREAD
-instead.")
 
 (define-condition interrupt-thread-error (thread-error) ()
   (:report (lambda (c s)
@@ -80,17 +72,9 @@ instead.")
    "Signalled when interrupting a thread fails because the thread has already
 exited. The offending thread can be accessed using THREAD-ERROR-THREAD."))
 
-(defun interrupt-thread-error-thread (condition)
+(define-deprecated-function :late "1.0.29.17" interrupt-thread-error-thread thread-error-thread
+    (condition)
   (thread-error-thread condition))
-(define-compiler-macro interrupt-thread-error-thread (condition)
-  (deprecation-warning 'join-thread-error-thread 'thread-error-thread)
-  `(thread-error-thread ,condition))
-
-#!+sb-doc
-(setf
- (fdocumentation 'interrupt-thread-error-thread 'function)
- "The thread that was not interrupted. Deprecated, use THREAD-ERROR-THREAD
-instead.")
 
 ;;; Of the WITH-PINNED-OBJECTS in this file, not every single one is
 ;;; necessary because threads are only supported with the conservative
@@ -543,6 +527,10 @@ IF-NOT-OWNER is :FORCE)."
   #!-sb-lutex
   (token nil))
 
+(def!method print-object ((waitqueue waitqueue) stream)
+  (print-unreadable-object (waitqueue stream :type t :identity t)
+    (format stream "~@[~A~]" (waitqueue-name waitqueue))))
+
 (defun make-waitqueue (&key name)
   #!+sb-doc
   "Create a waitqueue."
@@ -1208,7 +1196,24 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated"
                      (setf (sap-ref-word (%thread-sap thread) offset)
                            (get-lisp-obj-address value))
                      (values value :ok))))
-            (values nil :thread-dead))))))
+            (values nil :thread-dead)))))
+
+  (define-alien-variable tls-index-start unsigned-int)
+
+  ;; Get values from the TLS.
+  (defun %thread-local-values (thread)
+    (without-gcing
+      (when (thread-alive-p thread)
+        (let ((sap (%thread-sap thread)))
+          (loop for index from tls-index-start below
+                   (symbol-value 'sb!vm::*free-tls-index*)
+                for value = (sap-ref-word sap (* sb!vm:n-word-bytes index))
+                for obj = (sb!kernel:make-lisp-obj value nil)
+                unless (or (typep obj '(or boolean fixnum character))
+                           (member value
+                                   '(#.sb!vm:no-tls-value-marker-widetag
+                                     #.sb!vm:unbound-marker-widetag)))
+                collect obj))))))
 
 (defun symbol-value-in-thread (symbol thread &optional (errorp t))
   "Return the local value of SYMBOL in THREAD, and a secondary value of T