X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Ftarget-thread.lisp;h=3edfb7d5092f71df77df75dc60197b3718946364;hb=cd8fe50554652680dde36396d7862fc6cc83839c;hp=18832b4b6923658e19b0d72c04df60565b31c5f5;hpb=64d420902d31cb87ea752f09b314e4767816a9c9;p=sbcl.git

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 18832b4..3edfb7d 100644
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -11,6 +11,11 @@
 
 (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
@@ -112,17 +117,11 @@ in future versions."
 
 ;;;; spinlocks
 
-(defstruct spinlock
-  #!+sb-doc
-  "Spinlock type."
-  (name nil :type (or null simple-string))
-  (value 0))
-
 (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
            (ignore spinlock new-value))
@@ -130,7 +129,7 @@ in future versions."
   ;; store any value
   #!+sb-thread
   (loop until
-        (eql (sb!vm::%instance-set-conditional spinlock 2 0 new-value) 0)))
+        (eql (sb!vm::%instance-set-conditional spinlock 2 0 1) 0)))
 
 (defun release-spinlock (spinlock)
   (declare (optimize (speed 3) (safety 0))
@@ -145,19 +144,13 @@ in future versions."
 (defmacro with-spinlock ((spinlock) &body body)
   (sb!int:with-unique-names (lock)
     `(let ((,lock ,spinlock))
-      (get-spinlock ,lock *current-thread*)
+      (get-spinlock ,lock)
       (unwind-protect
            (progn ,@body)
         (release-spinlock ,lock)))))
 
 ;;;; mutexes
 
-(defstruct mutex
-  #!+sb-doc
-  "Mutex type."
-  (name nil :type (or null simple-string))
-  (value nil))
-
 #!+sb-doc
 (setf (sb!kernel:fdocumentation 'make-mutex 'function)
       "Create a mutex."
@@ -176,13 +169,14 @@ in future versions."
    (+ (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))
+(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
 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)))
-  (unless new-value (setf new-value *current-thread*))
+  (unless new-value
+    (setq new-value *current-thread*))
   #!-sb-thread
   (let ((old-value (mutex-value mutex)))
     (when (and old-value wait-p)
@@ -203,8 +197,9 @@ until it is available"
          (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)))))
+     (with-pinned-objects (mutex old)
+       (futex-wait (mutex-value-address mutex)
+                   (sb!kernel:get-lisp-obj-address old))))))
 
 (defun release-mutex (mutex)
   #!+sb-doc
@@ -263,8 +258,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
-           (futex-wait (waitqueue-data-address queue)
-                       (sb!kernel:get-lisp-obj-address me)))
+           (with-pinned-objects (queue me)
+             (futex-wait (waitqueue-data-address queue)
+                         (sb!kernel: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
@@ -286,7 +282,8 @@ time we reacquire MUTEX and return to the caller."
     ;; 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)))
+    (with-pinned-objects (queue)
+      (futex-wake (waitqueue-data-address queue) n))))
 
 (defun condition-broadcast (queue)
   #!+sb-doc
@@ -539,13 +536,12 @@ returns the thread exits."
                         ;; reference to this thread
                         (handle-thread-exit thread)))))))
             (values))))
+    ;; Keep INITIAL-FUNCTION pinned until the child thread is
+    ;; initialized properly.
     (with-pinned-objects (initial-function)
       (let ((os-thread
-             ;; 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 initial-function)))))
+             (%create-thread
+              (sb!kernel:get-lisp-obj-address initial-function))))
         (when (zerop os-thread)
           (error "Can't create a new thread"))
         (wait-on-semaphore setup-sem)
@@ -630,7 +626,6 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated"
      (let ((os-thread (sap-ref-word thread-sap
                                     (* sb!vm:n-word-bytes
                                        sb!vm::thread-os-thread-slot))))
-       (print os-thread)
        (when (= os-thread id) (return thread-sap))
        (setf thread-sap
              (sap-ref-sap thread-sap (* sb!vm:n-word-bytes