1.0.18.6: rename SB-PCL::FUNCTION-KEYWORD-PARAMETERS to CL:FUNCTION-KEYWORDS

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

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 1ddd0a1..61ea1af 100644 (file)
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -39,14 +39,22 @@ in future versions."
       "The name of the thread. Setfable.")
 
 (def!method print-object ((thread thread) stream)
-  (if (thread-name thread)
-      (print-unreadable-object (thread stream :type t :identity t)
-        (prin1 (thread-name thread) stream))
-      (print-unreadable-object (thread stream :type t :identity t)
-        ;; body is empty => there is only one space between type and
-        ;; identity
-        ))
-  thread)
+  (print-unreadable-object (thread stream :type t :identity t)
+    (let* ((cookie (list thread))
+           (info (if (thread-alive-p thread)
+                     :running
+                     (multiple-value-list (join-thread thread :default cookie))))
+           (state (if (eq :running info)
+                      info
+                      (if (eq cookie (car info))
+                          :aborted
+                          :finished)))
+           (values (when (eq :finished state) info)))
+      (format stream "~@[~S ~]~:[~A~;~A~:[ no values~; values: ~:*~{~S~^, ~}~]~]"
+              (thread-name thread)
+              (eq :finished state)
+              state
+              values))))
 
 (defun thread-alive-p (thread)
   #!+sb-doc
@@ -59,6 +67,8 @@ in future versions."
 (defvar *all-threads* ())
 (defvar *all-threads-lock* (make-mutex :name "all threads lock"))
 
+(defvar *default-alloc-signal* nil)
+
 (defmacro with-all-threads-lock (&body body)
   `(with-system-mutex (*all-threads-lock*)
      ,@body))
@@ -704,6 +714,8 @@ around and can be retrieved by JOIN-THREAD."
                    (sb!impl::*zap-array-data-temp* empty)
                    (sb!impl::*internal-symbol-output-fun* nil)
                    (sb!impl::*descriptor-handlers* nil)) ; serve-event
+              ;; Binding from C
+              (setf sb!vm:*alloc-signal* *default-alloc-signal*)
               (setf (thread-os-thread thread) (current-thread-os-thread))
               (with-mutex ((thread-result-lock thread))
                 (with-all-threads-lock