projects
/
sbcl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
test for multiply-interrupted sleeps
[sbcl.git]
/
src
/
code
/
target-thread.lisp
diff --git
a/src/code/target-thread.lisp
b/src/code/target-thread.lisp
index
ba189b3
..
038dad0
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))
(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
`(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*))))
`(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)))
(,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)
(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))
(declaim (inline get-spinlock release-spinlock))
@@
-443,9
+443,11
@@
HOLDING-MUTEX-P."
(detect-deadlock other-lock)))))))
(deadlock-chain (thread lock)
(let* ((other-thread (lock-owner lock))
(detect-deadlock other-lock)))))))
(deadlock-chain (thread lock)
(let* ((other-thread (lock-owner lock))
- (other-lock (thread-waiting-for other-thread)))
+ (other-lock (when other-thread
+ (thread-waiting-for other-thread))))
(cond ((not other-thread)
(cond ((not other-thread)
- ;; The deadlock is gone -- maybe someone timed out?
+ ;; The deadlock is gone -- maybe someone unwound
+ ;; from the same deadlock already?
(return-from check-deadlock nil))
((consp other-lock)
;; There's a timeout -- no deadlock.
(return-from check-deadlock nil))
((consp other-lock)
;; There's a timeout -- no deadlock.
@@
-1071,17
+1073,26
@@
have the foreground next."
;;;; The beef
;;;; The beef
-(defun make-thread (function &key name)
+(defun make-thread (function &key name arguments)
#!+sb-doc
#!+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."
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 (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))
#!+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
(initial-function
(named-lambda initial-thread-function ()
;; In time we'll move some of the binding presently done in C
@@
-1142,7
+1153,7
@@
around and can be retrieved by JOIN-THREAD."
(setf (thread-result thread)
(cons t
(multiple-value-list
(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
;; Try to block deferrables. An
;; interrupt may unwind it, but for a
;; normal exit it prevents interrupt