Skip testl fcntl.flock.2 on NetBSD.

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

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 89c5111..16b5a2d 100644 (file)
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -301,7 +301,7 @@ created and old ones may exit at any time."
 
 (defmacro with-deadlocks ((thread lock &optional timeout) &body forms)
   (declare (ignorable timeout))
-  (with-unique-names (prev n-thread n-lock n-timeout new)
+  (with-unique-names (n-thread n-lock n-timeout new)
     `(let* ((,n-thread ,thread)
             (,n-lock ,lock)
             (,n-timeout #!-sb-lutex
@@ -309,8 +309,6 @@ created and old ones may exit at any time."
                            `(or ,timeout
                                 (when sb!impl::*deadline*
                                   sb!impl::*deadline-seconds*))))
-            ;; If we get interrupted while waiting for a lock, etc.
-            (,prev (thread-waiting-for ,n-thread))
             (,new (if ,n-timeout
                       (cons ,n-timeout ,n-lock)
                       ,n-lock)))
@@ -321,7 +319,9 @@ created and old ones may exit at any time."
             (progn
               (setf (thread-waiting-for ,n-thread) ,new)
               ,@forms)
-         (setf (thread-waiting-for ,n-thread) ,prev)))))
+         ;; Interrupt handlers and GC save and restore any
+         ;; previous wait marks using WITHOUT-DEADLOCKS below.
+         (setf (thread-waiting-for ,n-thread) nil)))))
 
 (declaim (inline get-spinlock release-spinlock))
 
@@ -1073,17 +1073,26 @@ have the foreground next."
 
 ;;;; The beef
 
-(defun make-thread (function &key name)
+(defun make-thread (function &key name arguments)
   #!+sb-doc
-  "Create a new thread of NAME that runs FUNCTION. When the function
+  "Create a new thread of NAME that runs FUNCTION with the argument
+list designator provided (defaults to no argument). When the function
 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 (declare (ignore function name arguments))
   #!-sb-thread (error "Not supported in unithread builds.")
+  #!+sb-thread (assert (or (atom arguments)
+                           (null (cdr (last arguments))))
+                       (arguments)
+                       "Argument passed to ~S, ~S, is an improper list."
+                       'make-thread arguments)
   #!+sb-thread
   (let* ((thread (%make-thread :name name))
          (setup-sem (make-semaphore :name "Thread setup semaphore"))
          (real-function (coerce function 'function))
+         (arguments     (if (listp arguments)
+                            arguments
+                            (list arguments)))
          (initial-function
           (named-lambda initial-thread-function ()
             ;; In time we'll move some of the binding presently done in C
@@ -1144,7 +1153,7 @@ around and can be retrieved by JOIN-THREAD."
                                (setf (thread-result thread)
                                      (cons t
                                            (multiple-value-list
-                                            (funcall real-function))))
+                                            (apply real-function arguments))))
                                ;; Try to block deferrables. An
                                ;; interrupt may unwind it, but for a
                                ;; normal exit it prevents interrupt
@@ -1287,8 +1296,8 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated"
       (loop
         (if (thread-alive-p thread)
             (let* ((epoch sb!kernel::*gc-epoch*)
-                   (offset (* sb!vm:n-word-bytes
-                              (sb!vm::symbol-tls-index symbol)))
+                   (offset (sb!kernel:get-lisp-obj-address
+                            (sb!vm::symbol-tls-index symbol)))
                    (tl-val (sap-ref-word (%thread-sap thread) offset)))
               (cond ((zerop offset)
                      (return (values nil :no-tls-value)))
@@ -1322,8 +1331,8 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated"
       ;; area...
       (with-all-threads-lock
         (if (thread-alive-p thread)
-            (let ((offset (* sb!vm:n-word-bytes
-                             (sb!vm::symbol-tls-index symbol))))
+            (let ((offset (sb!kernel:get-lisp-obj-address
+                           (sb!vm::symbol-tls-index symbol))))
               (cond ((zerop offset)
                      (values nil :no-tls-value))
                     (t