1.0.5.6: compare-and-swap / instance-set-conditional refactoring

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

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 19e293a..59d0562 100644 (file)
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -11,10 +11,15 @@
 
 (in-package "SB!THREAD")
 
 
 (in-package "SB!THREAD")
 

+;;; Of the WITH-PINNED-OBJECTS in this file, not every single one is
+;;; necessary because threads are only supported with the conservative
+;;; gencgc and numbers on the stack (returned by GET-LISP-OBJ-ADDRESS)
+;;; are treated as references.
+

 ;;; set the doc here because in early-thread FDOCUMENTATION is not
 ;;; available, yet
 #!+sb-doc
 ;;; set the doc here because in early-thread FDOCUMENTATION is not
 ;;; available, yet
 #!+sb-doc

-(setf (sb!kernel:fdocumentation '*current-thread* 'variable)
+(setf (fdocumentation '*current-thread* 'variable)

       "Bound in each thread to the thread itself.")
 
 (defstruct (thread (:constructor %make-thread))
       "Bound in each thread to the thread itself.")
 
 (defstruct (thread (:constructor %make-thread))

@@ -22,10 +27,15 @@
   "Thread type. Do not rely on threads being structs as it may change
 in future versions."
   name
   "Thread type. Do not rely on threads being structs as it may change
 in future versions."
   name

-  %sap)
+  %alive-p
+  os-thread
+  interruptions
+  (interruptions-lock (make-mutex :name "thread interruptions lock"))
+  result
+  (result-lock (make-mutex :name "thread result lock")))

 
 #!+sb-doc
 
 #!+sb-doc

-(setf (sb!kernel:fdocumentation 'thread-name 'function)
+(setf (fdocumentation 'thread-name 'function)

       "The name of the thread. Setfable.")
 
 (def!method print-object ((thread thread) stream)
       "The name of the thread. Setfable.")
 
 (def!method print-object ((thread thread) stream)

@@ -38,22 +48,10 @@ in future versions."
         ))
   thread)
 
         ))
   thread)
 

-(defun thread-state (thread)
-  (let ((state
-         (sb!sys:sap-int
-          (sb!sys:sap-ref-sap (thread-%sap thread)
-                              (* sb!vm::thread-state-slot
-                                 sb!vm::n-word-bytes)))))
-    (ecase state
-      (#.(sb!vm:fixnumize 0) :starting)
-      (#.(sb!vm:fixnumize 1) :running)
-      (#.(sb!vm:fixnumize 2) :suspended)
-      (#.(sb!vm:fixnumize 3) :dead))))
-

 (defun thread-alive-p (thread)
   #!+sb-doc
   "Check if THREAD is running."
 (defun thread-alive-p (thread)
   #!+sb-doc
   "Check if THREAD is running."

-  (not (eq :dead (thread-state thread))))
+  (thread-%alive-p thread))

 
 ;; A thread is eligible for gc iff it has finished and there are no
 ;; more references to it. This list is supposed to keep a reference to
 
 ;; A thread is eligible for gc iff it has finished and there are no
 ;; more references to it. This list is supposed to keep a reference to

@@ -61,10 +59,18 @@ in future versions."
 (defvar *all-threads* ())
 (defvar *all-threads-lock* (make-mutex :name "all threads lock"))
 
 (defvar *all-threads* ())
 (defvar *all-threads-lock* (make-mutex :name "all threads lock"))
 

+(defmacro with-all-threads-lock (&body body)
+  #!-sb-thread
+  `(locally ,@body)
+  #!+sb-thread
+  `(without-interrupts
+     (with-mutex (*all-threads-lock*)
+       ,@body)))
+

 (defun list-all-threads ()
   #!+sb-doc
   "Return a list of the live threads."
 (defun list-all-threads ()
   #!+sb-doc
   "Return a list of the live threads."

-  (with-mutex (*all-threads-lock*)
+  (with-all-threads-lock

     (copy-list *all-threads*)))
 
 (declaim (inline current-thread-sap))
     (copy-list *all-threads*)))
 
 (declaim (inline current-thread-sap))

@@ -73,12 +79,14 @@ in future versions."
 
 (declaim (inline current-thread-sap-id))
 (defun current-thread-sap-id ()
 
 (declaim (inline current-thread-sap-id))
 (defun current-thread-sap-id ()

-  (sb!sys:sap-int
+  (sap-int

    (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot)))
 
 (defun init-initial-thread ()
    (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot)))
 
 (defun init-initial-thread ()

+  (/show0 "Entering INIT-INITIAL-THREAD")

   (let ((initial-thread (%make-thread :name "initial thread"
   (let ((initial-thread (%make-thread :name "initial thread"

-                                      :%sap (current-thread-sap))))
+                                      :%alive-p t
+                                      :os-thread (current-thread-sap-id))))

     (setq *current-thread* initial-thread)
     ;; Either *all-threads* is empty or it contains exactly one thread
     ;; in case we are in reinit since saving core with multiple
     (setq *current-thread* initial-thread)
     ;; Either *all-threads* is empty or it contains exactly one thread
     ;; in case we are in reinit since saving core with multiple

@@ -89,105 +97,149 @@ in future versions."
 
 #!+sb-thread
 (progn
 
 #!+sb-thread
 (progn

+  ;; FIXME it would be good to define what a thread id is or isn't
+  ;; (our current assumption is that it's a fixnum).  It so happens
+  ;; that on Linux it's a pid, but it might not be on posix thread
+  ;; implementations.

   (define-alien-routine ("create_thread" %create-thread)
   (define-alien-routine ("create_thread" %create-thread)

-      system-area-pointer
-    (lisp-fun-address unsigned-long))
+      unsigned-long (lisp-fun-address unsigned-long))
+
+  (define-alien-routine "signal_interrupt_thread"
+      integer (os-thread unsigned-long))
+
+  (define-alien-routine "block_deferrable_signals"
+      void)
+
+  #!+sb-lutex
+  (progn
+    (declaim (inline %lutex-init %lutex-wait %lutex-wake
+                     %lutex-lock %lutex-unlock))
+
+    (sb!alien:define-alien-routine ("lutex_init" %lutex-init)
+        int (lutex unsigned-long))
+
+    (sb!alien:define-alien-routine ("lutex_wait" %lutex-wait)
+        int (queue-lutex unsigned-long) (mutex-lutex unsigned-long))
+
+    (sb!alien:define-alien-routine ("lutex_wake" %lutex-wake)
+        int (lutex unsigned-long) (n int))

 
 

-  (define-alien-routine "block_blockable_signals"
-    void)
+    (sb!alien:define-alien-routine ("lutex_lock" %lutex-lock)
+        int (lutex unsigned-long))

 
 

-  (define-alien-routine reap-dead-thread void
-    (thread-sap system-area-pointer))
+    (sb!alien:define-alien-routine ("lutex_trylock" %lutex-trylock)
+        int (lutex unsigned-long))

 
 

-  (declaim (inline futex-wait futex-wake))
+    (sb!alien:define-alien-routine ("lutex_unlock" %lutex-unlock)
+        int (lutex unsigned-long))

 
 

-  (sb!alien:define-alien-routine "futex_wait"
-      int (word unsigned-long) (old-value unsigned-long))
+    (sb!alien:define-alien-routine ("lutex_destroy" %lutex-destroy)
+        int (lutex unsigned-long))

 
 

-  (sb!alien:define-alien-routine "futex_wake"
-      int (word unsigned-long) (n unsigned-long)))
+    ;; FIXME: Defining a whole bunch of alien-type machinery just for
+    ;; passing primitive lutex objects directly to foreign functions
+    ;; doesn't seem like fun right now. So instead we just manually
+    ;; pin the lutex, get its address, and let the callee untag it.
+    (defmacro with-lutex-address ((name lutex) &body body)
+      `(let ((,name ,lutex))
+         (with-pinned-objects (,name)
+           (let ((,name (get-lisp-obj-address ,name)))
+             ,@body))))
+
+    (defun make-lutex ()
+      (/show0 "Entering MAKE-LUTEX")
+      ;; Suppress GC until the lutex has been properly registered with
+      ;; the GC.
+      (without-gcing
+        (let ((lutex (sb!vm::%make-lutex)))
+          (/show0 "LUTEX=..")
+          (/hexstr lutex)
+          (with-lutex-address (lutex lutex)
+            (%lutex-init lutex))
+          lutex))))
+
+  #!-sb-lutex
+  (progn
+    (declaim (inline futex-wait futex-wake))
+
+    (sb!alien:define-alien-routine "futex_wait"
+        int (word unsigned-long) (old-value unsigned-long))
+
+    (sb!alien:define-alien-routine "futex_wake"
+        int (word unsigned-long) (n unsigned-long))))

 
 ;;; used by debug-int.lisp to access interrupt contexts
 
 ;;; used by debug-int.lisp to access interrupt contexts

-#!-(and sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap))
+#!-(or sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap))

 #!-sb-thread
 (defun sb!vm::current-thread-offset-sap (n)
   (declare (type (unsigned-byte 27) n))
 #!-sb-thread
 (defun sb!vm::current-thread-offset-sap (n)
   (declare (type (unsigned-byte 27) n))

-  (sb!sys:sap-ref-sap (alien-sap (extern-alien "all_threads" (* t)))
+  (sap-ref-sap (alien-sap (extern-alien "all_threads" (* t)))

                (* n sb!vm:n-word-bytes)))
 
                (* n sb!vm:n-word-bytes)))
 

-;;;; spinlocks
+#!+sb-thread
+(defun sb!vm::current-thread-offset-sap (n)
+  (declare (type (unsigned-byte 27) n))
+  (sb!vm::current-thread-offset-sap n))

 
 

-(defstruct spinlock
-  #!+sb-doc
-  "Spinlock type."
-  (name nil :type (or null simple-string))
-  (value 0))
+;;;; spinlocks
+#!+sb-thread
+(define-structure-slot-compare-and-swap
+    compare-and-swap-spinlock-value
+    :structure spinlock
+    :slot value)

 
 (declaim (inline get-spinlock release-spinlock))
 
 
 (declaim (inline get-spinlock release-spinlock))
 

-;;; The bare 2 here and below are offsets of the slots in the struct.
-;;; There ought to be some better way to get these numbers
-(defun get-spinlock (spinlock new-value)
+(defun get-spinlock (spinlock)

   (declare (optimize (speed 3) (safety 0))
            #!-sb-thread
   (declare (optimize (speed 3) (safety 0))
            #!-sb-thread

-           (ignore spinlock new-value))
+           (ignore spinlock))

   ;; %instance-set-conditional can test for 0 (which is a fixnum) and
   ;; store any value
   #!+sb-thread
   (loop until
   ;; %instance-set-conditional can test for 0 (which is a fixnum) and
   ;; store any value
   #!+sb-thread
   (loop until

-        (eql (sb!vm::%instance-set-conditional spinlock 2 0 new-value) 0)))
+       (eql 0 (compare-and-swap-spinlock-value spinlock 0 1)))
+  t)

 
 (defun release-spinlock (spinlock)
   (declare (optimize (speed 3) (safety 0))
            #!-sb-thread (ignore spinlock))
   ;; %instance-set-conditional cannot compare arbitrary objects
 
 (defun release-spinlock (spinlock)
   (declare (optimize (speed 3) (safety 0))
            #!-sb-thread (ignore spinlock))
   ;; %instance-set-conditional cannot compare arbitrary objects

-  ;; meaningfully, so
-  ;; (sb!vm::%instance-set-conditional spinlock 2 our-value 0)
+  ;; meaningfully, so (compare-and-swap-spinlock-value our-value 0)

   ;; does not work for bignum thread ids.
   #!+sb-thread
   ;; does not work for bignum thread ids.
   #!+sb-thread

-  (sb!vm::%instance-set spinlock 2 0))
-
-(defmacro with-spinlock ((spinlock) &body body)
-  (sb!int:with-unique-names (lock)
-    `(let ((,lock ,spinlock))
-      (get-spinlock ,lock *current-thread*)
-      (unwind-protect
-           (progn ,@body)
-        (release-spinlock ,lock)))))
+  (setf (spinlock-value spinlock) 0)
+  nil)

 
 ;;;; mutexes
 
 
 ;;;; mutexes
 

-(defstruct mutex
-  #!+sb-doc
-  "Mutex type."
-  (name nil :type (or null simple-string))
-  (value nil))
-

 #!+sb-doc
 #!+sb-doc

-(setf (sb!kernel:fdocumentation 'make-mutex 'function)
+(setf (fdocumentation 'make-mutex 'function)

       "Create a mutex."
       "Create a mutex."

-      (sb!kernel:fdocumentation 'mutex-name 'function)
+      (fdocumentation 'mutex-name 'function)

       "The name of the mutex. Setfable."
       "The name of the mutex. Setfable."

-      (sb!kernel:fdocumentation 'mutex-value 'function)
+      (fdocumentation 'mutex-value 'function)

       "The value of the mutex. NIL if the mutex is free. Setfable.")
 
       "The value of the mutex. NIL if the mutex is free. Setfable.")
 

-#!+sb-thread
-(declaim (inline mutex-value-address))
-#!+sb-thread
-(defun mutex-value-address (mutex)
-  (declare (optimize (speed 3)))
-  (sb!ext:truly-the
-   sb!vm:word
-   (+ (sb!kernel:get-lisp-obj-address mutex)
-      (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
-
-(defun get-mutex (mutex &optional new-value (wait-p t))
+#!+(and sb-thread (not sb-lutex))
+(progn
+  (define-structure-slot-addressor mutex-value-address
+      :structure mutex
+      :slot value)
+  (define-structure-slot-compare-and-swap
+      compare-and-swap-mutex-value
+      :structure mutex
+      :slot value))
+
+(defun get-mutex (mutex &optional (new-value *current-thread*) (wait-p t))

   #!+sb-doc
   "Acquire MUTEX, setting it to NEW-VALUE or some suitable default
   #!+sb-doc
   "Acquire MUTEX, setting it to NEW-VALUE or some suitable default

-value if NIL.  If WAIT-P is non-NIL and the mutex is in use, sleep
-until it is available"
+value if NIL. If WAIT-P is non-NIL and the mutex is in use, sleep
+until it is available."

   (declare (type mutex mutex) (optimize (speed 3)))
   (declare (type mutex mutex) (optimize (speed 3)))

-  (unless new-value (setf new-value *current-thread*))
+  (/show0 "Entering GET-MUTEX")
+  (unless new-value
+    (setq new-value *current-thread*))

   #!-sb-thread
   (let ((old-value (mutex-value mutex)))
     (when (and old-value wait-p)
   #!-sb-thread
   (let ((old-value (mutex-value mutex)))
     (when (and old-value wait-p)

@@ -197,28 +249,44 @@ until it is available"
     (setf (mutex-value mutex) new-value)
     t)
   #!+sb-thread
     (setf (mutex-value mutex) new-value)
     t)
   #!+sb-thread

-  (let (old)
+  (progn

     (when (eql new-value (mutex-value mutex))
       (warn "recursive lock attempt ~S~%" mutex)
       (format *debug-io* "Thread: ~A~%" *current-thread*)
       (sb!debug:backtrace most-positive-fixnum *debug-io*)
       (force-output *debug-io*))
     (when (eql new-value (mutex-value mutex))
       (warn "recursive lock attempt ~S~%" mutex)
       (format *debug-io* "Thread: ~A~%" *current-thread*)
       (sb!debug:backtrace most-positive-fixnum *debug-io*)
       (force-output *debug-io*))

-    (loop
-     (unless
-         (setf old (sb!vm::%instance-set-conditional mutex 2 nil new-value))
-       (return t))
-     (unless wait-p (return nil))
-     (futex-wait (mutex-value-address mutex)
-                 (sb!kernel:get-lisp-obj-address old)))))
+    #!+sb-lutex
+    (when (zerop (with-lutex-address (lutex (mutex-lutex mutex))
+                   (if wait-p
+                       (%lutex-lock lutex)
+                       (%lutex-trylock lutex))))
+      (setf (mutex-value mutex) new-value))
+    #!-sb-lutex
+    (let (old)
+      (loop
+         (unless
+             (setf old
+                   (compare-and-swap-mutex-value mutex nil new-value))
+           (return t))
+         (unless wait-p (return nil))
+         (with-pinned-objects (mutex old)
+           (futex-wait (mutex-value-address mutex)
+                       (get-lisp-obj-address old)))))))

 
 (defun release-mutex (mutex)
   #!+sb-doc
   "Release MUTEX by setting it to NIL. Wake up threads waiting for
 this mutex."
   (declare (type mutex mutex))
 
 (defun release-mutex (mutex)
   #!+sb-doc
   "Release MUTEX by setting it to NIL. Wake up threads waiting for
 this mutex."
   (declare (type mutex mutex))

+  (/show0 "Entering RELEASE-MUTEX")

   (setf (mutex-value mutex) nil)
   #!+sb-thread
   (setf (mutex-value mutex) nil)
   #!+sb-thread

-  (futex-wake (mutex-value-address mutex) 1))
+  (progn
+    #!+sb-lutex
+    (with-lutex-address (lutex (mutex-lutex mutex))
+      (%lutex-unlock lutex))
+    #!-sb-lutex
+    (futex-wake (mutex-value-address mutex) 1)))

 
 ;;;; waitqueues/condition variables
 
 
 ;;;; waitqueues/condition variables
 

@@ -226,6 +294,9 @@ this mutex."
   #!+sb-doc
   "Waitqueue type."
   (name nil :type (or null simple-string))
   #!+sb-doc
   "Waitqueue type."
   (name nil :type (or null simple-string))

+  #!+(and sb-lutex sb-thread)
+  (lutex (make-lutex))
+  #!-sb-lutex

   (data nil))
 
 (defun make-waitqueue (&key name)
   (data nil))
 
 (defun make-waitqueue (&key name)

@@ -234,18 +305,13 @@ this mutex."
   (%make-waitqueue :name name))
 
 #!+sb-doc
   (%make-waitqueue :name name))
 
 #!+sb-doc

-(setf (sb!kernel:fdocumentation 'waitqueue-name 'function)
+(setf (fdocumentation 'waitqueue-name 'function)

       "The name of the waitqueue. Setfable.")
 
       "The name of the waitqueue. Setfable.")
 

-#!+sb-thread
-(declaim (inline waitqueue-data-address))
-#!+sb-thread
-(defun waitqueue-data-address (waitqueue)
-  (declare (optimize (speed 3)))
-  (sb!ext:truly-the
-   sb!vm:word
-   (+ (sb!kernel:get-lisp-obj-address waitqueue)
-      (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
+#!+(and sb-thread (not sb-lutex))
+(define-structure-slot-addressor waitqueue-data-address
+    :structure waitqueue
+    :slot data)

 
 (defun condition-wait (queue mutex)
   #!+sb-doc
 
 (defun condition-wait (queue mutex)
   #!+sb-doc

@@ -257,6 +323,15 @@ time we reacquire MUTEX and return to the caller."
   #!-sb-thread (error "Not supported in unithread builds.")
   #!+sb-thread
   (let ((value (mutex-value mutex)))
   #!-sb-thread (error "Not supported in unithread builds.")
   #!+sb-thread
   (let ((value (mutex-value mutex)))

+    (/show0 "CONDITION-WAITing")
+    #!+sb-lutex
+    (progn
+      (setf (mutex-value mutex) nil)
+      (with-lutex-address (queue-lutex-address (waitqueue-lutex queue))
+        (with-lutex-address (mutex-lutex-address (mutex-lutex mutex))
+          (%lutex-wait queue-lutex-address mutex-lutex-address)))
+      (setf (mutex-value mutex) value))
+    #!-sb-lutex

     (unwind-protect
          (let ((me *current-thread*))
            ;; XXX we should do something to ensure that the result of this setf
     (unwind-protect
          (let ((me *current-thread*))
            ;; XXX we should do something to ensure that the result of this setf

@@ -268,8 +343,9 @@ time we reacquire MUTEX and return to the caller."
            ;; this comment, it will change queue->data, and so
            ;; futex-wait returns immediately instead of sleeping.
            ;; Ergo, no lost wakeup
            ;; this comment, it will change queue->data, and so
            ;; futex-wait returns immediately instead of sleeping.
            ;; Ergo, no lost wakeup

-           (futex-wait (waitqueue-data-address queue)
-                       (sb!kernel:get-lisp-obj-address me)))
+           (with-pinned-objects (queue me)
+             (futex-wait (waitqueue-data-address queue)
+                         (get-lisp-obj-address me))))

       ;; If we are interrupted while waiting, we should do these things
       ;; before returning.  Ideally, in the case of an unhandled signal,
       ;; we should do them before entering the debugger, but this is
       ;; If we are interrupted while waiting, we should do these things
       ;; before returning.  Ideally, in the case of an unhandled signal,
       ;; we should do them before entering the debugger, but this is

@@ -283,20 +359,32 @@ time we reacquire MUTEX and return to the caller."
   #!-sb-thread (error "Not supported in unithread builds.")
   #!+sb-thread
   (declare (type (and fixnum (integer 1)) n))
   #!-sb-thread (error "Not supported in unithread builds.")
   #!+sb-thread
   (declare (type (and fixnum (integer 1)) n))

+  (/show0 "Entering CONDITION-NOTIFY")

   #!+sb-thread
   #!+sb-thread

-  (let ((me *current-thread*))
+  (progn
+    #!+sb-lutex
+    (with-lutex-address (lutex (waitqueue-lutex queue))
+      (%lutex-wake lutex n))

     ;; no problem if >1 thread notifies during the comment in
     ;; condition-wait: as long as the value in queue-data isn't the
     ;; waiting thread's id, it matters not what it is
     ;; XXX we should do something to ensure that the result of this setf
     ;; is visible to all CPUs
     ;; no problem if >1 thread notifies during the comment in
     ;; condition-wait: as long as the value in queue-data isn't the
     ;; waiting thread's id, it matters not what it is
     ;; XXX we should do something to ensure that the result of this setf
     ;; is visible to all CPUs

-    (setf (waitqueue-data queue) me)
-    (futex-wake (waitqueue-data-address queue) n)))
+    #!-sb-lutex
+    (let ((me *current-thread*))
+      (progn
+        (setf (waitqueue-data queue) me)
+        (with-pinned-objects (queue)
+          (futex-wake (waitqueue-data-address queue) n))))))

 
 (defun condition-broadcast (queue)
   #!+sb-doc
   "Notify all threads waiting on QUEUE."
 
 (defun condition-broadcast (queue)
   #!+sb-doc
   "Notify all threads waiting on QUEUE."

-  (condition-notify queue most-positive-fixnum))
+  (condition-notify queue
+                    ;; On a 64-bit platform truncating M-P-F to an int results
+                    ;; in -1, which wakes up only one thread.
+                    (ldb (byte 29 0)
+                         most-positive-fixnum)))

 
 ;;;; semaphores
 
 
 ;;;; semaphores
 

@@ -313,7 +401,7 @@ time we reacquire MUTEX and return to the caller."
   "Create a semaphore with the supplied COUNT."
   (%make-semaphore :name name :count count))
 
   "Create a semaphore with the supplied COUNT."
   (%make-semaphore :name name :count count))
 

-(setf (sb!kernel:fdocumentation 'semaphore-name 'function)
+(setf (fdocumentation 'semaphore-name 'function)

       "The name of the semaphore. Setfable.")
 
 (defun wait-on-semaphore (sem)
       "The name of the semaphore. Setfable.")
 
 (defun wait-on-semaphore (sem)

@@ -354,16 +442,18 @@ this semaphore, then N of them is woken up."
   #!-sb-thread
   `(locally ,@body)
   #!+sb-thread
   #!-sb-thread
   `(locally ,@body)
   #!+sb-thread

-  `(sb!sys:without-interrupts
-    (with-mutex ((session-lock ,session))
-      ,@body)))
+  `(without-interrupts
+     (with-mutex ((session-lock ,session))
+       ,@body)))

 
 (defun new-session ()
   (make-session :threads (list *current-thread*)
                 :interactive-threads (list *current-thread*)))
 
 (defun init-job-control ()
 
 (defun new-session ()
   (make-session :threads (list *current-thread*)
                 :interactive-threads (list *current-thread*)))
 
 (defun init-job-control ()

-  (setf *session* (new-session)))
+  (/show0 "Entering INIT-JOB-CONTROL")
+  (setf *session* (new-session))
+  (/show0 "Exiting INIT-JOB-CONTROL"))

 
 (defun %delete-thread-from-session (thread session)
   (with-session-lock (session)
 
 (defun %delete-thread-from-session (thread session)
   (with-session-lock (session)

@@ -386,10 +476,22 @@ this semaphore, then N of them is woken up."
 ;;; Remove thread from its session, if it has one.
 #!+sb-thread
 (defun handle-thread-exit (thread)
 ;;; Remove thread from its session, if it has one.
 #!+sb-thread
 (defun handle-thread-exit (thread)

-  (with-mutex (*all-threads-lock*)
-    (setq *all-threads* (delete thread *all-threads*)))
-  (when *session*
-    (%delete-thread-from-session thread *session*)))
+  (/show0 "HANDLING THREAD EXIT")
+  ;; We're going down, can't handle interrupts sanely anymore.
+  ;; GC remains enabled.
+  (block-deferrable-signals)
+  ;; Lisp-side cleanup
+  (with-all-threads-lock
+    (setf (thread-%alive-p thread) nil)
+    (setf (thread-os-thread thread) nil)
+    (setq *all-threads* (delete thread *all-threads*))
+    (when *session*
+      (%delete-thread-from-session thread *session*)))
+  #!+sb-lutex
+  (without-gcing
+    (/show0 "FREEING MUTEX LUTEX")
+    (with-lutex-address (lutex (mutex-lutex (thread-interruptions-lock thread)))
+      (%lutex-destroy lutex))))

 
 (defun terminate-session ()
   #!+sb-doc
 
 (defun terminate-session ()
   #!+sb-doc

@@ -428,6 +530,7 @@ interactive."
   #!+sb-thread
   (let ((was-foreground t))
     (loop
   #!+sb-thread
   (let ((was-foreground t))
     (loop

+     (/show0 "Looping in GET-FOREGROUND")

      (with-session-lock (*session*)
        (let ((int-t (session-interactive-threads *session*)))
          (when (eq (car int-t) *current-thread*)
      (with-session-lock (*session*)
        (let ((int-t (session-interactive-threads *session*)))
          (when (eq (car int-t) *current-thread*)

@@ -470,16 +573,16 @@ have the foreground next."
     (labels ((thread-repl ()
                (sb!unix::unix-setsid)
                (let* ((sb!impl::*stdin*
     (labels ((thread-repl ()
                (sb!unix::unix-setsid)
                (let* ((sb!impl::*stdin*

-                       (sb!sys:make-fd-stream in :input t :buffering :line
-                                              :dual-channel-p t))
+                       (make-fd-stream in :input t :buffering :line
+                                       :dual-channel-p t))

                       (sb!impl::*stdout*
                       (sb!impl::*stdout*

-                       (sb!sys:make-fd-stream out :output t :buffering :line
+                       (make-fd-stream out :output t :buffering :line

                                               :dual-channel-p t))
                       (sb!impl::*stderr*
                                               :dual-channel-p t))
                       (sb!impl::*stderr*

-                       (sb!sys:make-fd-stream err :output t :buffering :line
+                       (make-fd-stream err :output t :buffering :line

                                               :dual-channel-p t))
                       (sb!impl::*tty*
                                               :dual-channel-p t))
                       (sb!impl::*tty*

-                       (sb!sys:make-fd-stream err :input t :output t
+                       (make-fd-stream err :input t :output t

                                               :buffering :line
                                               :dual-channel-p t))
                       (sb!impl::*descriptor-handlers* nil))
                                               :buffering :line
                                               :dual-channel-p t))
                       (sb!impl::*descriptor-handlers* nil))

@@ -494,64 +597,106 @@ have the foreground next."
 (defun make-thread (function &key name)
   #!+sb-doc
   "Create a new thread of NAME that runs FUNCTION. When the function
 (defun make-thread (function &key name)
   #!+sb-doc
   "Create a new thread of NAME that runs FUNCTION. When the function

-returns the thread exits."
+returns the thread exits. The return values of FUNCTION are kept
+around and can be retrieved by JOIN-THREAD."

   #!-sb-thread (declare (ignore function name))
   #!-sb-thread (error "Not supported in unithread builds.")
   #!+sb-thread
   (let* ((thread (%make-thread :name name))
          (setup-sem (make-semaphore :name "Thread setup semaphore"))
          (real-function (coerce function 'function))
   #!-sb-thread (declare (ignore function name))
   #!-sb-thread (error "Not supported in unithread builds.")
   #!+sb-thread
   (let* ((thread (%make-thread :name name))
          (setup-sem (make-semaphore :name "Thread setup semaphore"))
          (real-function (coerce function 'function))

-         (thread-sap
-          ;; don't let the child inherit *CURRENT-THREAD* because that
-          ;; can prevent gc'ing this thread while the child runs
-          (let ((*current-thread* nil))
-            (%create-thread
-             (sb!kernel:get-lisp-obj-address
-              (lambda ()
-                ;; in time we'll move some of the binding presently done in C
-                ;; here too
-                (let ((*current-thread* thread)
-                      (sb!kernel::*restart-clusters* nil)
-                      (sb!kernel::*handler-clusters* nil)
-                      (sb!kernel::*condition-restarts* nil)
-                      (sb!impl::*descriptor-handlers* nil)) ; serve-event
-                  (wait-on-semaphore setup-sem)
-                  ;; can't use handling-end-of-the-world, because that flushes
-                  ;; output streams, and we don't necessarily have any (or we
-                  ;; could be sharing them)
-                  (unwind-protect
-                       (catch 'sb!impl::toplevel-catcher
-                         (catch 'sb!impl::%end-of-the-world
-                           (with-simple-restart
-                               (terminate-thread
-                                (format nil
-                                        "~~@<Terminate this thread (~A)~~@:>"
-                                        *current-thread*))
+         (initial-function
+          (lambda ()
+            ;; In time we'll move some of the binding presently done in C
+            ;; here too.
+            ;;
+            ;; KLUDGE: Here we have a magic list of variables that are
+            ;; not thread-safe for one reason or another.  As people
+            ;; report problems with the thread safety of certain
+            ;; variables, (e.g. "*print-case* in multiple threads
+            ;; broken", sbcl-devel 2006-07-14), we add a few more
+            ;; bindings here.  The Right Thing is probably some variant
+            ;; of Allegro's *cl-default-special-bindings*, as that is at
+            ;; least accessible to users to secure their own libraries.
+            ;;   --njf, 2006-07-15
+            (let ((*current-thread* thread)
+                  (*restart-clusters* nil)
+                  (*handler-clusters* nil)
+                  (*condition-restarts* nil)
+                  (sb!impl::*step-out* nil)
+                  ;; internal printer variables
+                  (sb!impl::*previous-case* nil)
+                  (sb!impl::*previous-readtable-case* nil)
+                  (sb!impl::*merge-sort-temp-vector* (vector)) ; keep these small!
+                  (sb!impl::*zap-array-data-temp* (vector))    ;
+                  (sb!impl::*internal-symbol-output-fun* nil)
+                  (sb!impl::*descriptor-handlers* nil)) ; serve-event
+              (setf (thread-os-thread thread) (current-thread-sap-id))
+              (with-mutex ((thread-result-lock thread))
+                (with-all-threads-lock
+                  (push thread *all-threads*))
+                (with-session-lock (*session*)
+                  (push thread (session-threads *session*)))
+                (setf (thread-%alive-p thread) t)
+                (signal-semaphore setup-sem)
+                ;; can't use handling-end-of-the-world, because that flushes
+                ;; output streams, and we don't necessarily have any (or we
+                ;; could be sharing them)
+                (catch 'sb!impl::toplevel-catcher
+                  (catch 'sb!impl::%end-of-the-world
+                    (with-simple-restart
+                        (terminate-thread
+                         (format nil
+                                 "~~@<Terminate this thread (~A)~~@:>"
+                                 *current-thread*))
+                      (unwind-protect
+                           (progn

                              ;; now that most things have a chance to
                              ;; work properly without messing up other
                              ;; threads, it's time to enable signals
                              (sb!unix::reset-signal-mask)
                              ;; now that most things have a chance to
                              ;; work properly without messing up other
                              ;; threads, it's time to enable signals
                              (sb!unix::reset-signal-mask)

-                             (unwind-protect
-                                  (funcall real-function)
-                               ;; we're going down, can't handle
-                               ;; interrupts sanely anymore
-                               (let ((sb!impl::*gc-inhibit* t))
-                                 (block-blockable-signals)
-                                 ;; and remove what can be the last
-                                 ;; reference to this thread
-                                 (handle-thread-exit thread))))))
-                    0))
-                (values)))))))
-    (when (sb!sys:sap= thread-sap (sb!sys:int-sap 0))
-      (error "Can't create a new thread"))
-    (setf (thread-%sap thread) thread-sap)
-    (with-mutex (*all-threads-lock*)
-      (push thread *all-threads*))
-    (with-session-lock (*session*)
-      (push thread (session-threads *session*)))
-    (signal-semaphore setup-sem)
-    (sb!impl::finalize thread (lambda () (reap-dead-thread thread-sap)))
-    thread))
+                             (setf (thread-result thread)
+                                   (cons t
+                                         (multiple-value-list
+                                          (funcall real-function)))))
+                        (handle-thread-exit thread)))))))
+            (values))))
+    ;; Keep INITIAL-FUNCTION pinned until the child thread is
+    ;; initialized properly.
+    (with-pinned-objects (initial-function)
+      (let ((os-thread
+             (%create-thread
+              (get-lisp-obj-address initial-function))))
+        (when (zerop os-thread)
+          (error "Can't create a new thread"))
+        (wait-on-semaphore setup-sem)
+        thread))))
+
+(define-condition join-thread-error (error)
+  ((thread :reader join-thread-error-thread :initarg :thread))
+  #!+sb-doc
+  (:documentation "Joining thread failed.")
+  (:report (lambda (c s)
+             (format s "Joining thread failed: thread ~A ~
+                        has not returned normally."
+                     (join-thread-error-thread c)))))
+
+#!+sb-doc
+(setf (fdocumentation 'join-thread-error-thread 'function)
+      "The thread that we failed to join.")
+
+(defun join-thread (thread &key (default nil defaultp))
+  #!+sb-doc
+  "Suspend current thread until THREAD exits. Returns the result
+values of the thread function. If the thread does not exit normally,
+return DEFAULT if given or else signal JOIN-THREAD-ERROR."
+  (with-mutex ((thread-result-lock thread))
+    (cond ((car (thread-result thread))
+           (values-list (cdr (thread-result thread))))
+          (defaultp
+           default)
+          (t
+           (error 'join-thread-error :thread thread)))))

 
 (defun destroy-thread (thread)
   #!+sb-doc
 
 (defun destroy-thread (thread)
   #!+sb-doc

@@ -559,26 +704,44 @@ returns the thread exits."
   (terminate-thread thread))
 
 (define-condition interrupt-thread-error (error)
   (terminate-thread thread))
 
 (define-condition interrupt-thread-error (error)

-  ((thread :reader interrupt-thread-error-thread :initarg :thread)
-   (errno :reader interrupt-thread-error-errno :initarg :errno))
+  ((thread :reader interrupt-thread-error-thread :initarg :thread))

   #!+sb-doc
   (:documentation "Interrupting thread failed.")
   (:report (lambda (c s)
   #!+sb-doc
   (:documentation "Interrupting thread failed.")
   (:report (lambda (c s)

-             (format s "interrupt thread ~A failed (~A: ~A)"
-                     (interrupt-thread-error-thread c)
-                     (interrupt-thread-error-errno c)
-                     (strerror (interrupt-thread-error-errno c))))))
+             (format s "Interrupt thread failed: thread ~A has exited."
+                     (interrupt-thread-error-thread c)))))

 
 #!+sb-doc
 
 #!+sb-doc

-(setf (sb!kernel:fdocumentation 'interrupt-thread-error-thread 'function)
-      "The thread that was not interrupted."
-      (sb!kernel:fdocumentation 'interrupt-thread-error-errno 'function)
-      "The reason why the interruption failed.")
+(setf (fdocumentation 'interrupt-thread-error-thread 'function)
+      "The thread that was not interrupted.")

 
 

+(defmacro with-interruptions-lock ((thread) &body body)
+  `(without-interrupts
+     (with-mutex ((thread-interruptions-lock ,thread))
+       ,@body)))
+
+;; Called from the signal handler.
+(defun run-interruption ()
+  (in-interruption ()
+    (loop
+       (let ((interruption (with-interruptions-lock (*current-thread*)
+                             (pop (thread-interruptions *current-thread*)))))
+         (if interruption
+             (with-interrupts
+               (funcall interruption))
+             (return))))))
+
+;; The order of interrupt execution is peculiar. If thread A
+;; interrupts thread B with I1, I2 and B for some reason receives I1
+;; when FUN2 is already on the list, then it is FUN2 that gets to run
+;; first. But when FUN2 is run SIG_INTERRUPT_THREAD is enabled again
+;; and I2 hits pretty soon in FUN2 and run FUN1. This is of course
+;; just one scenario, and the order of thread interrupt execution is
+;; undefined.

 (defun interrupt-thread (thread function)
   #!+sb-doc
   "Interrupt the live THREAD and make it run FUNCTION. A moderate
 (defun interrupt-thread (thread function)
   #!+sb-doc
   "Interrupt the live THREAD and make it run FUNCTION. A moderate

-degree of care is expected for use of interrupt-thread, due to its
+degree of care is expected for use of INTERRUPT-THREAD, due to its

 nature: if you interrupt a thread that was holding important locks
 then do something that turns out to need those locks, you probably
 won't like the effect."
 nature: if you interrupt a thread that was holding important locks
 then do something that turns out to need those locks, you probably
 won't like the effect."

@@ -590,18 +753,14 @@ won't like the effect."
   #!+sb-thread
   (if (eq thread *current-thread*)
       (funcall function)
   #!+sb-thread
   (if (eq thread *current-thread*)
       (funcall function)

-      (let ((function (coerce function 'function)))
-        (multiple-value-bind (res err)
-            ;; protect against gcing just when the ub32 address is
-            ;; just ready to be passed to C
-            (sb!sys::with-pinned-objects (function)
-              (sb!unix::syscall ("interrupt_thread"
-                                 system-area-pointer sb!alien:unsigned-long)
-                                thread
-                                (thread-%sap thread)
-                                (sb!kernel:get-lisp-obj-address function)))
-          (unless res
-            (error 'interrupt-thread-error :thread thread :errno err))))))
+      (let ((os-thread (thread-os-thread thread)))
+        (cond ((not os-thread)
+               (error 'interrupt-thread-error :thread thread))
+              (t
+               (with-interruptions-lock (thread)
+                 (push function (thread-interruptions thread)))
+               (when (minusp (signal-interrupt-thread os-thread))
+                 (error 'interrupt-thread-error :thread thread)))))))

 
 (defun terminate-thread (thread)
   #!+sb-doc
 
 (defun terminate-thread (thread)
   #!+sb-doc

@@ -614,11 +773,38 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated"
 ;;; with an SBCL developer first, or are doing something that you
 ;;; should probably discuss with a professional psychiatrist first
 #!+sb-thread
 ;;; with an SBCL developer first, or are doing something that you
 ;;; should probably discuss with a professional psychiatrist first
 #!+sb-thread

-(defun symbol-value-in-thread (symbol thread)
-  (let ((thread-sap (thread-%sap thread)))
-    (let* ((index (sb!vm::symbol-tls-index symbol))
-           (tl-val (sb!sys:sap-ref-word thread-sap
-                                        (* sb!vm:n-word-bytes index))))
-      (if (eql tl-val sb!vm::no-tls-value-marker-widetag)
-          (sb!vm::symbol-global-value symbol)
-          (sb!kernel:make-lisp-obj tl-val)))))
+(defun thread-sap-for-id (id)
+  (let ((thread-sap (alien-sap (extern-alien "all_threads" (* t)))))
+    (loop
+     (when (sap= thread-sap (int-sap 0)) (return nil))
+     (let ((os-thread (sap-ref-word thread-sap
+                                    (* sb!vm:n-word-bytes
+                                       sb!vm::thread-os-thread-slot))))
+       (when (= os-thread id) (return thread-sap))
+       (setf thread-sap
+             (sap-ref-sap thread-sap (* sb!vm:n-word-bytes
+                                        sb!vm::thread-next-slot)))))))
+
+#!+sb-thread
+(defun symbol-value-in-thread (symbol thread-sap)
+  (let* ((index (sb!vm::symbol-tls-index symbol))
+         (tl-val (sap-ref-word thread-sap
+                               (* sb!vm:n-word-bytes index))))
+    (if (eql tl-val sb!vm::no-tls-value-marker-widetag)
+        (sb!vm::symbol-global-value symbol)
+        (make-lisp-obj tl-val))))
+
+(defun sb!vm::locked-symbol-global-value-add (symbol-name delta)
+  (sb!vm::locked-symbol-global-value-add symbol-name delta))
+
+;;; Stepping
+
+(defun thread-stepping ()
+  (make-lisp-obj
+   (sap-ref-word (current-thread-sap)
+                 (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes))))
+
+(defun (setf thread-stepping) (value)
+  (setf (sap-ref-word (current-thread-sap)
+                      (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes))
+        (get-lisp-obj-address value)))