* Remove all lutex-specific code from the system.
** Use SB-FUTEX for futex-capable platforms, and plain SB-THREAD
otherwise.
** Make non-futex mutexes unfair spinlocks for now, using WAIT-FOR to
provide timeouts and backoff.
** Build non-futex condition variables on top of a queue and WAIT-FOR.
Performance implications: SB-FUTEX builds should perform pretty much the
same, or improve a bit. Threaded non-futex builds are affected as follows:
1. Threads idling on semaphores or condition variables aren't quite as
cheap. Just how costly depends on the OS. On Darwin 1000 idle threads
can chew up a bit over 50% CPU. I will try to address this later.
2. Contested locking around operations that take considerably longer
than a single timeslice suffers mild degradation.
3. Contested locking around operations that don't take long is an order
of magnitude performant.
4. Highly active semaphores perform much better. (Follows from #3.)
* GRAB-MUTEX gets timeout support on all platforms.
* CONDITION-WAIT gets timeout support.
* Disable a bunch of prone-to-hang thread tests on Darwin. (All of them
were already prone to hang prior to this commit.)
* Enable a bunch tests that now /pass/ on Darwin. \o/ This doesn't mean that
the threaded Darwin is fully expected to pass all tests yet, but let's say
it's more likely to do so.
...but still not robust enough to enable threads on Darwin by default.
* GET-MUTEX/GRAB-MUTEX get refactored into two main parts: %TRY-MUTEX and
%WAIT-ON-MUTEX, which are also used directly from CONDITION-WAIT where
appropriate.
;; x86oid Darwin, FreeBSD, and Solaris.
; :sb-thread
- ;; lutex support
+ ;; futex support
;;
;; While on linux we are able to use futexes for our locking
- ;; primitive, on other platforms we don't have this luxury. NJF's
- ;; lutexes present a locking API similar to the futex-based API that
- ;; allows for sb-thread support on x86 OS X, Solaris and
- ;; FreeBSD.
+ ;; primitive, on other platforms we don't have this luxury.
;;
- ; :sb-lutex
+ ; :sb-futex
;; On some operating systems the FS segment register (used for SBCL's
;; thread local storage) is not reliably preserved in signal
(case (sb-kernel:widetag-of object)
(#.sb-vm::value-cell-header-widetag
(call (sb-kernel::value-cell-ref object)))
- #+(and sb-lutex sb-thread)
- (#.sb-vm::lutex-widetag)
(t
(warn "~&MAP-ROOT: Unknown widetag ~S: ~S~%"
(sb-kernel:widetag-of object) object)))))))
printf ' :largefile' >> $ltf
;;
x86 | x86-64)
- printf ' :sb-thread :largefile' >> $ltf
+ printf ' :sb-thread :sb-futex :largefile' >> $ltf
;;
esac
printf ' :bsd' >> $ltf
printf ' :darwin' >> $ltf
if [ $sbcl_arch = "x86" ]; then
- printf ' :mach-exception-handler :sb-lutex :restore-fs-segment-register-from-tls :ud2-breakpoints' >> $ltf
+ printf ' :mach-exception-handler :restore-fs-segment-register-from-tls :ud2-breakpoints' >> $ltf
fi
if [ $sbcl_arch = "x86-64" ]; then
- printf ' :mach-exception-handler :sb-lutex :ud2-breakpoints' >> $ltf
+ printf ' :mach-exception-handler :ud2-breakpoints' >> $ltf
fi
link_or_copy $sbcl_arch-darwin-os.h target-arch-os.h
link_or_copy bsd-os.h target-os.h
if [ $sbcl_arch = "x86-64" ]; then
printf ' :largefile' >> $ltf
fi
- if [ $sbcl_arch = "x86" ] || [ $sbcl_arch = "x86-64" ]; then
- printf ' :sb-lutex' >> $ltf
- fi
link_or_copy Config.$sbcl_arch-sunos Config
link_or_copy $sbcl_arch-sunos-os.h target-arch-os.h
link_or_copy sunos-os.h target-os.h
"INITIAL-FUN-CORE-ENTRY-TYPE-CODE"
"*!LOAD-TIME-VALUES*"
"LOAD-TYPE-PREDICATE"
- #!+(and sb-thread sb-lutex) "LUTEX-TABLE-CORE-ENTRY-TYPE-CODE"
"MAX-CORE-SPACE-ID"
"NEW-DIRECTORY-CORE-ENTRY-TYPE-CODE"
"OPEN-FASL-OUTPUT" "PAGE-TABLE-CORE-ENTRY-TYPE-CODE"
#!+long-float "LONG-STACK-SC-NUMBER"
"LOWTAG-LIMIT" "LOWTAG-MASK"
"LRA-SAVE-OFFSET"
- #!+(and sb-thread sb-lutex) "LUTEX-WIDETAG"
"MEMORY-USAGE" "MOST-POSITIVE-COST"
"N-LOWTAG-BITS"
"N-FIXNUM-TAG-BITS"
(declare (ignore name value))
nil)
-#!+(and sb-lutex sb-thread)
-(defun make-lutex () nil)
-
(defmacro with-mutex ((mutex) &body body)
(declare (ignore mutex))
`(locally ,@body))
CONDITION, or return NIL if the restart is not found."
(try-restart 'cancel-deadline condition))
+(declaim (inline relative-decoded-times))
+(defun relative-decoded-times (abs-sec abs-usec)
+ #!+sb-doc
+ "Returns relative decoded times: difference between SEC and USEC and
+current real time."
+ (multiple-value-bind (now-sec now-usec)
+ (decode-internal-time (get-internal-real-time))
+ (let ((rel-sec (- abs-sec now-sec)))
+ (cond ((> now-usec abs-usec)
+ (values (max 0 (1- rel-sec))
+ (- (+ abs-usec 1000000) now-usec)))
+ (t
+ (values (max 0 rel-sec)
+ (- abs-usec now-usec)))))))
+
;;; Returns TIMEOUT-SEC, TIMEOUT-USEC, DEADLINE-SEC, DEADLINE-USEC, SIGNALP
;;;
;;; Takes *DEADLINE* into account: if it occurs before given SECONDS,
(decode-internal-time final-timeout)
(multiple-value-bind (stop-sec stop-usec)
(decode-internal-time final-deadline)
- (values to-sec to-usec stop-sec stop-usec signalp)))
+ (values (max 0 to-sec) (max 0 to-usec) stop-sec stop-usec signalp)))
(values nil nil nil nil nil)))))))
(!defun-from-collected-cold-init-forms !deadline-cold-init)
(number-of-gcs int)
(number-of-gcs-before-promotion int)
(cum-sum-bytes-allocated unsigned-long)
- (minimum-age-before-gc double)
- ;; `struct lutex *' or `void *', depending.
- (lutexes (* char))))
+ (minimum-age-before-gc double)))
#!+gencgc
(define-alien-variable generations
;;;; WAIT-FOR -- waiting on arbitrary conditions
-(defun %wait-for (test timeout)
+(defun %%wait-for (test stop-sec stop-usec)
(declare (function test))
(labels ((try ()
(declare (optimize (safety 0)))
(awhen (funcall test)
- (return-from %wait-for it)))
+ (return-from %%wait-for it)))
(tick (sec usec)
(declare (fixnum sec usec))
;; TICK is microseconds
(get-tick ()
(multiple-value-call #'tick
(decode-internal-time (get-internal-real-time)))))
- ;; Compute timeout: must come first so that deadlines already passed
- ;; are noticed before the first try.
- (multiple-value-bind (to-sec to-usec stop-sec stop-usec deadlinep)
- (decode-timeout timeout)
- (declare (ignore to-sec to-usec))
- (let* ((timeout-tick (when stop-sec (tick stop-sec stop-usec)))
- (start (get-tick))
- ;; Rough estimate of how long a single attempt takes.
- (try-ticks (progn
- (try) (try) (try)
- (max 1 (truncate (- (get-tick) start) 3)))))
- ;; Scale sleeping between attempts:
- ;;
- ;; Start by sleeping for as many ticks as an average attempt
- ;; takes, then doubling for each attempt.
- ;;
- ;; Max out at 0.1 seconds, or the 2 x time of a single try,
- ;; whichever is longer -- with a hard cap of 10 seconds.
- ;;
- ;; FIXME: Maybe the API should have a :MAX-SLEEP argument?
- (loop with max-ticks = (max 100000 (min (* 2 try-ticks)
- (expt 10 7)))
- for scale of-type fixnum = 1
- then (let ((x (logand most-positive-fixnum (* 2 scale))))
- (if (> scale x)
- most-positive-fixnum
- x))
- do (try)
- (let* ((now (get-tick))
- (sleep-ticks (min (* try-ticks scale) max-ticks))
- (sleep
- (if timeout-tick
- ;; If sleep would take us past the
- ;; timeout, shorten it so it's just
- ;; right.
- (if (>= (+ now sleep-ticks) timeout-tick)
- (- timeout-tick now)
- sleep-ticks)
- sleep-ticks)))
- (declare (fixnum sleep))
- (cond ((plusp sleep)
- ;; microseconds to seconds and nanoseconds
- (multiple-value-bind (sec nsec)
- (truncate (* 1000 sleep) (expt 10 9))
- (with-interrupts
- (sb!unix:nanosleep sec nsec))))
- (deadlinep
- (signal-deadline))
- (t
- (return-from %wait-for nil)))))))))
+ (let* ((timeout-tick (when stop-sec (tick stop-sec stop-usec)))
+ (start (get-tick))
+ ;; Rough estimate of how long a single attempt takes.
+ (try-ticks (progn
+ (try) (try) (try)
+ (max 1 (truncate (- (get-tick) start) 3)))))
+ ;; Scale sleeping between attempts:
+ ;;
+ ;; Start by sleeping for as many ticks as an average attempt
+ ;; takes, then doubling for each attempt.
+ ;;
+ ;; Max out at 0.1 seconds, or the 2 x time of a single try,
+ ;; whichever is longer -- with a hard cap of 10 seconds.
+ ;;
+ ;; FIXME: Maybe the API should have a :MAX-SLEEP argument?
+ (loop with max-ticks = (max 100000 (min (* 2 try-ticks)
+ (expt 10 7)))
+ for scale of-type fixnum = 1
+ then (let ((x (logand most-positive-fixnum (* 2 scale))))
+ (if (> scale x)
+ most-positive-fixnum
+ x))
+ do (try)
+ (let* ((now (get-tick))
+ (sleep-ticks (min (* try-ticks scale) max-ticks))
+ (sleep
+ (if timeout-tick
+ ;; If sleep would take us past the
+ ;; timeout, shorten it so it's just
+ ;; right.
+ (if (>= (+ now sleep-ticks) timeout-tick)
+ (- timeout-tick now)
+ sleep-ticks)
+ sleep-ticks)))
+ (declare (fixnum sleep))
+ (cond ((plusp sleep)
+ ;; microseconds to seconds and nanoseconds
+ (multiple-value-bind (sec nsec)
+ (truncate (* 1000 sleep) (expt 10 9))
+ (with-interrupts
+ (sb!unix:nanosleep sec nsec))))
+ (t
+ (return-from %%wait-for nil))))))))
+
+(defun %wait-for (test timeout)
+ (declare (function test))
+ (tagbody
+ :restart
+ (multiple-value-bind (to-sec to-usec stop-sec stop-usec deadlinep)
+ (decode-timeout timeout)
+ (declare (ignore to-sec to-usec))
+ (return-from %wait-for
+ (or (%%wait-for test stop-sec stop-usec)
+ (when deadlinep
+ (signal-deadline)
+ (go :restart)))))))
(defmacro wait-for (test-form &key timeout)
"Wait until TEST-FORM evaluates to true, then return its primary value.
(def-type-predicate-wrapper integerp)
(def-type-predicate-wrapper listp)
(def-type-predicate-wrapper long-float-p)
- #!+(and sb-thread sb-lutex)
- (def-type-predicate-wrapper lutexp)
(def-type-predicate-wrapper lra-p)
(def-type-predicate-wrapper null)
(def-type-predicate-wrapper numberp)
;;; Return a list of N gensyms. (This is a common suboperation in
;;; macros and other code-manipulating code.)
-(declaim (ftype (function (index) list) make-gensym-list))
-(defun make-gensym-list (n)
- (loop repeat n collect (block-gensym)))
+(declaim (ftype (function (index &optional t) (values list &optional))
+ make-gensym-list))
+(defun make-gensym-list (n &optional name)
+ (case name
+ ((t)
+ (loop repeat n collect (gensym)))
+ ((nil)
+ (loop repeat n collect (block-gensym)))
+ (otherwise
+ (loop repeat n collect (gensym name)))))
\f
;;;; miscellany
(in-package "SB!THREAD")
+;;; CAS Lock
+;;;
+;;; Locks don't come any simpler -- or more lightweight than this. While
+;;; this is probably a premature optimization for most users, we still
+;;; need it internally for implementing condition variables outside Futex
+;;; builds.
+
+(defmacro with-cas-lock ((place) &body body)
+ #!+sb-doc
+ "Runs BODY with interrupts disabled and *CURRENT-THREAD* compare-and-swapped
+into PLACE instead of NIL. PLACE must be a place acceptable to
+COMPARE-AND-SWAP, and must initially hold NIL.
+
+WITH-CAS-LOCK is suitable mostly when the critical section needing protection
+is very small, and cost of allocating a separate lock object would be
+prohibitive. While it is the most lightweight locking constructed offered by
+SBCL, it is also the least scalable if the section is heavily contested or
+long.
+
+WITH-CAS-LOCK can be entered recursively."
+ `(without-interrupts
+ (%with-cas-lock (,place) ,@body)))
+
+(defmacro %with-cas-lock ((place) &body body &environment env)
+ (with-unique-names (self owner)
+ ;; Take care not to multiply-evaluate anything.
+ ;;
+ ;; FIXME: Once we get DEFCAS this can use GET-CAS-EXPANSION.
+ (let* ((placex (sb!xc:macroexpand place env))
+ (place-op (if (consp placex)
+ (car placex)
+ (error "~S: ~S is not a valid place for ~S"
+ 'with-cas-lock
+ place 'sb!ext:compare-and-swap)))
+ (place-args (cdr placex))
+ (temps (make-gensym-list (length place-args) t))
+ (place `(,place-op ,@temps)))
+ `(let* (,@(mapcar #'list temps place-args)
+ (,self *current-thread*)
+ (,owner ,place))
+ (unwind-protect
+ (progn
+ (unless (eq ,owner ,self)
+ (loop while (setf ,owner
+ (or ,place
+ (sb!ext:compare-and-swap ,place nil ,self)))
+ do (thread-yield)))
+ ,@body)
+ (unless (eq ,owner ,self)
+ (sb!ext:compare-and-swap ,place ,self nil)))))))
+
;;; Conditions
(define-condition thread-error (error)
(multiple-value-list
(join-thread thread :default cookie))))
(state (if (eq :running info)
- (let* ((lock (thread-waiting-for thread)))
- (typecase lock
+ (let* ((thing (thread-waiting-for thread)))
+ (typecase thing
(cons
- (list "waiting for:" (cdr lock)
- "timeout: " (car lock)))
+ (list "waiting on:" (cdr thing)
+ "timeout: " (car thing)))
(null
(list info))
(t
- (list "waiting for:" lock))))
+ (list "waiting on:" thing))))
(if (eq cookie (car info))
(list :aborted)
:finished)))
(defun block-deferrable-signals ()
(%block-deferrable-signals 0 0))
- #!+sb-lutex
- (progn
- (declaim (inline %lutex-init %lutex-wait %lutex-wake
- %lutex-lock %lutex-unlock))
-
- (define-alien-routine ("lutex_init" %lutex-init)
- int (lutex unsigned-long))
-
- (define-alien-routine ("lutex_wait" %lutex-wait)
- int (queue-lutex unsigned-long) (mutex-lutex unsigned-long))
-
- (define-alien-routine ("lutex_wake" %lutex-wake)
- int (lutex unsigned-long) (n int))
-
- (define-alien-routine ("lutex_lock" %lutex-lock)
- int (lutex unsigned-long))
-
- (define-alien-routine ("lutex_trylock" %lutex-trylock)
- int (lutex unsigned-long))
-
- (define-alien-routine ("lutex_unlock" %lutex-unlock)
- int (lutex unsigned-long))
-
- (define-alien-routine ("lutex_destroy" %lutex-destroy)
- int (lutex 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
+ #!+sb-futex
(progn
(declaim (inline futex-wait %futex-wait futex-wake))
;;;; Spinlocks
-(defmacro with-deadlocks ((thread lock &optional timeout) &body forms)
- (declare (ignorable timeout))
- (with-unique-names (n-thread n-lock n-timeout new)
+(defmacro with-deadlocks ((thread lock &optional (timeout nil timeoutp)) &body forms)
+ (with-unique-names (n-thread n-lock new n-timeout)
`(let* ((,n-thread ,thread)
(,n-lock ,lock)
- (,n-timeout #!-sb-lutex
- ,(when timeout
+ (,n-timeout ,(when timeoutp
`(or ,timeout
(when sb!impl::*deadline*
sb!impl::*deadline-seconds*))))
(,new (if ,n-timeout
+ ;; Using CONS tells the rest of the system there's a
+ ;; timeout in place, so it isn't considered a deadlock.
(cons ,n-timeout ,n-lock)
,n-lock)))
(declare (dynamic-extent ,new))
(fdocumentation 'mutex-name 'function)
"The name of the mutex. Setfable.")
-#!+(and sb-thread (not sb-lutex))
+#!+(and sb-thread sb-futex)
(progn
(define-structure-slot-addressor mutex-state-address
:structure mutex
(etypecase lock
(mutex (mutex-%owner lock))
(spinlock (spinlock-value lock))))
+ (lock-p (thing)
+ (typep thing '(or mutex spinlock)))
(detect-deadlock (lock)
(let ((other-thread (lock-owner lock)))
(cond ((not other-thread))
;; If the thread is waiting with a timeout OTHER-LOCK
;; is a cons, and we don't consider it a deadlock -- since
;; it will time out on its own sooner or later.
- (when (and other-lock (not (consp other-lock)))
+ (when (lock-p other-lock)
(detect-deadlock other-lock)))))))
(deadlock-chain (thread lock)
(let* ((other-thread (lock-owner lock))
((consp other-lock)
;; There's a timeout -- no deadlock.
(return-from check-deadlock nil))
+ ((waitqueue-p other-lock)
+ ;; Not a lock.
+ (return-from check-deadlock nil))
((eq self other-thread)
;; Done
(list (list thread lock)))
;; Again, the deadlock is gone?
(return-from check-deadlock nil)))))))
;; Timeout means there is no deadlock
- (unless (consp origin)
+ (when (lock-p origin)
(detect-deadlock origin)
t))))
-(defun get-mutex (mutex &optional new-owner
- (waitp t) (timeout nil))
- #!+sb-doc
- "Deprecated in favor of GRAB-MUTEX."
- (declare (type mutex mutex) (optimize (speed 3))
- #!-sb-thread (ignore waitp timeout))
- (unless new-owner
- (setq new-owner *current-thread*))
+(defun %try-mutex (mutex new-owner)
+ (declare (type mutex mutex) (optimize (speed 3)))
(barrier (:read))
(let ((old (mutex-%owner mutex)))
(when (eq new-owner old)
(error "Recursive lock attempt ~S." mutex))
#!-sb-thread
(when old
- (error "Strange deadlock on ~S in an unithreaded build?" mutex)))
- #!-sb-thread
- (setf (mutex-%owner mutex) new-owner)
- #!+sb-thread
- (with-deadlocks (new-owner mutex timeout)
- ;; FIXME: Lutexes do not currently support deadlines, as at least
- ;; on Darwin pthread_foo_timedbar functions are not supported:
- ;; this means that we probably need to use the Carbon multiprocessing
- ;; functions on Darwin.
- ;;
- ;; FIXME: This is definitely not interrupt safe: what happens if
- ;; we get hit (1) during the lutex calls (ok, they may be safe,
- ;; but has that been checked?) (2) after the lutex call, but
- ;; before setting the mutex owner.
- #!+sb-lutex
- (progn
- (when timeout
- (error "Mutex timeouts not supported on this platform."))
- (when (zerop (with-lutex-address (lutex (mutex-lutex mutex))
- (if waitp
- (let ((once (%lutex-trylock lutex)))
- (cond ((zerop once)
- ;; No need to wait.
- once)
- (t
- (with-interrupts
- ;; Check for deadlocks before waiting
- (check-deadlock)
- (%lutex-lock lutex)))))
- (%lutex-trylock lutex))))
- ;; FIXME: If %LUTEX-LOCK unwinds due to a signal, we may actually
- ;; be holding the lock already -- and but neglect to mark ourselves
- ;; as the owner here. This is bad.
- (setf (mutex-%owner mutex) new-owner)
- (barrier (:write))
- t))
- #!-sb-lutex
- ;; This is a direct translation of the Mutex 2 algorithm from
- ;; "Futexes are Tricky" by Ulrich Drepper.
- (let ((old (sb!ext:compare-and-swap (mutex-state mutex)
- +lock-free+
- +lock-taken+)))
- (unless (or (eql +lock-free+ old) (not waitp))
- (tagbody
- :retry
- (when (or (eql +lock-contested+ old)
- (not (eql +lock-free+
- (sb!ext:compare-and-swap (mutex-state mutex)
- +lock-taken+
- +lock-contested+))))
- ;; Wait on the contested lock.
- (with-interrupts
- (check-deadlock)
- (loop
- (multiple-value-bind (to-sec to-usec stop-sec stop-usec deadlinep)
- (decode-timeout timeout)
- (declare (ignore stop-sec stop-usec))
- (case (with-pinned-objects (mutex)
- (futex-wait (mutex-state-address mutex)
- (get-lisp-obj-address +lock-contested+)
- (or to-sec -1)
- (or to-usec 0)))
- ((1) (if deadlinep
- (signal-deadline)
- (return-from get-mutex nil)))
- ((2))
- (otherwise (return)))))))
- (setf old (sb!ext:compare-and-swap (mutex-state mutex)
- +lock-free+
- +lock-contested+))
- ;; Did we get it?
- (unless (eql +lock-free+ old)
- (go :retry))))
- (cond ((eql +lock-free+ old)
+ (error "Strange deadlock on ~S in an unithreaded build?" mutex))
+ #!-sb-futex
+ (and (not (mutex-%owner mutex))
+ (not (sb!ext:compare-and-swap (mutex-%owner mutex) nil new-owner)))
+ #!+sb-futex
+ ;; From the Mutex 2 algorithm from "Futexes are Tricky" by Ulrich Drepper.
+ (when (eql +lock-free+ (sb!ext:compare-and-swap (mutex-state mutex)
+ +lock-free+
+ +lock-taken+))
+ (let ((prev (sb!ext:compare-and-swap (mutex-%owner mutex) nil new-owner)))
+ (when prev
+ (bug "Old owner in free mutex: ~S" prev))
+ t))))
+
+#!+sb-thread
+(defun %%wait-for-mutex (mutex new-owner to-sec to-usec stop-sec stop-usec)
+ (declare (type mutex mutex) (optimize (speed 3)))
+ #!-sb-futex
+ (declare (ignore to-sec to-usec))
+ #!-sb-futex
+ (flet ((cas ()
+ (loop repeat 24
+ when (and (not (mutex-%owner mutex))
+ (not (sb!ext:compare-and-swap (mutex-%owner mutex) nil
+ new-owner)))
+ do (return-from cas t))
+ ;; Check for pending interrupts.
+ (with-interrupts nil)))
+ (declare (dynamic-extent #'cas))
+ (sb!impl::%%wait-for #'cas stop-sec stop-usec))
+ #!+sb-futex
+ ;; This is a fairly direct translation of the Mutex 2 algorithm from
+ ;; "Futexes are Tricky" by Ulrich Drepper.
+ (flet ((maybe (old)
+ (when (eql +lock-free+ old)
(let ((prev (sb!ext:compare-and-swap (mutex-%owner mutex)
nil new-owner)))
(when prev
(bug "Old owner in free mutex: ~S" prev))
- t))
- (waitp
- (bug "Failed to acquire lock with WAITP."))))))
+ (return-from %%wait-for-mutex t)))))
+ (prog ((old (sb!ext:compare-and-swap (mutex-state mutex)
+ +lock-free+ +lock-taken+)))
+ ;; Got it right off the bat?
+ (maybe old)
+ :retry
+ ;; Mark it as contested, and sleep. (Exception: it was just released.)
+ (when (or (eql +lock-contested+ old)
+ (not (eql +lock-free+
+ (sb!ext:compare-and-swap
+ (mutex-state mutex) +lock-taken+ +lock-contested+))))
+ (when (eql 1 (with-pinned-objects (mutex)
+ (futex-wait (mutex-state-address mutex)
+ (get-lisp-obj-address +lock-contested+)
+ (or to-sec -1)
+ (or to-usec 0))))
+ ;; -1 = EWOULDBLOCK, possibly spurious wakeup
+ ;; 0 = normal wakeup
+ ;; 1 = ETIMEDOUT ***DONE***
+ ;; 2 = EINTR, a spurious wakeup
+ (return-from %%wait-for-mutex nil)))
+ ;; Try to get it, still marking it as contested.
+ (maybe
+ (sb!ext:compare-and-swap (mutex-state mutex) +lock-free+ +lock-contested+))
+ ;; Update timeout if necessary.
+ (when stop-sec
+ (setf (values to-sec to-usec)
+ (sb!impl::relative-decoded-times stop-sec stop-usec)))
+ ;; Spin.
+ (go :retry))))
+
+(defun %wait-for-mutex (mutex self timeout to-sec to-usec stop-sec stop-usec deadlinep)
+ (with-deadlocks (self mutex timeout)
+ (with-interrupts (check-deadlock))
+ (tagbody
+ :again
+ (return-from %wait-for-mutex
+ (or (%%wait-for-mutex mutex self to-sec to-usec stop-sec stop-usec)
+ (when deadlinep
+ (signal-deadline)
+ ;; FIXME: substract elapsed time from timeout...
+ (setf (values to-sec to-usec stop-sec stop-usec deadlinep)
+ (decode-timeout timeout))
+ (go :again)))))))
+
+(defun get-mutex (mutex &optional new-owner (waitp t) (timeout nil))
+ #!+sb-doc
+ "Deprecated in favor of GRAB-MUTEX."
+ (declare (ignorable waitp timeout))
+ (let ((new-owner (or new-owner *current-thread*)))
+ (or (%try-mutex mutex new-owner)
+ #!+sb-thread
+ (when waitp
+ (multiple-value-call #'%wait-for-mutex
+ mutex new-owner timeout (decode-timeout timeout))))))
(defun grab-mutex (mutex &key (waitp t) (timeout nil))
#!+sb-doc
"Acquire MUTEX for the current thread. If WAITP is true (the default) and
the mutex is not immediately available, sleep until it is available.
-If TIMEOUT is given, it specifies a relative timeout, in seconds, on
-how long GRAB-MUTEX should try to acquire the lock in the contested
-case. Unsupported on :SB-LUTEX platforms (eg. Darwin), where a non-NIL
-TIMEOUT signals an error.
+If TIMEOUT is given, it specifies a relative timeout, in seconds, on how long
+GRAB-MUTEX should try to acquire the lock in the contested case.
-If GRAB-MUTEX returns T, the lock acquisition was successful. In case
-of WAITP being NIL, or an expired TIMEOUT, GRAB-MUTEX may also return
-NIL which denotes that GRAB-MUTEX did -not- acquire the lock.
+If GRAB-MUTEX returns T, the lock acquisition was successful. In case of WAITP
+being NIL, or an expired TIMEOUT, GRAB-MUTEX may also return NIL which denotes
+that GRAB-MUTEX did -not- acquire the lock.
Notes:
(ALLOW-WITH-INTERRUPTS (GRAB-MUTEX ...))
...)
- WITHOUT-INTERRUPTS is necessary to avoid an interrupt unwinding
- the call while the mutex is in an inconsistent state while
- ALLOW-WITH-INTERRUPTS allows the call to be interrupted from
- sleep.
+ WITHOUT-INTERRUPTS is necessary to avoid an interrupt unwinding the call
+ while the mutex is in an inconsistent state while ALLOW-WITH-INTERRUPTS
+ allows the call to be interrupted from sleep.
- (GRAB-MUTEX <mutex> :timeout 0.0) differs from
(GRAB-MUTEX <mutex> :waitp nil) in that the former may signal a
- DEADLINE-TIMEOUT if the global deadline was due already on
- entering GRAB-MUTEX.
+ DEADLINE-TIMEOUT if the global deadline was due already on entering
+ GRAB-MUTEX.
- The exact interplay of GRAB-MUTEX and deadlines are reserved to
- change in future versions.
+ The exact interplay of GRAB-MUTEX and deadlines are reserved to change in
+ future versions.
- - It is recommended that you use WITH-MUTEX instead of calling
- GRAB-MUTEX directly.
+ - It is recommended that you use WITH-MUTEX instead of calling GRAB-MUTEX
+ directly.
"
- (get-mutex mutex nil waitp timeout))
+ (declare (ignorable waitp timeout))
+ (let ((self *current-thread*))
+ (or (%try-mutex mutex self)
+ #!+sb-thread
+ (when waitp
+ (multiple-value-call #'%wait-for-mutex
+ mutex self timeout (decode-timeout timeout))))))
(defun release-mutex (mutex &key (if-not-owner :punt))
#!+sb-doc
;; Order matters: set owner to NIL before releasing state.
(let* ((self *current-thread*)
(old-owner (sb!ext:compare-and-swap (mutex-%owner mutex) self nil)))
- (unless (eql self old-owner)
+ (unless (eq self old-owner)
(ecase if-not-owner
((:punt) (return-from release-mutex nil))
((:warn)
(warn "Releasing ~S, owned by another thread: ~S" mutex old-owner))
- ((:force))))
- #!+sb-thread
- (when old-owner
+ ((:force)))
(setf (mutex-%owner mutex) nil)
- #!+sb-lutex
- (with-lutex-address (lutex (mutex-lutex mutex))
- (%lutex-unlock lutex))
- #!-sb-lutex
+ ;; FIXME: Is a :memory barrier too strong here? Can we use a :write
+ ;; barrier instead?
+ (barrier (:memory)))
+ #!+sb-futex
+ (when old-owner
;; FIXME: once ATOMIC-INCF supports struct slots with word sized
;; unsigned-byte type this can be used:
;;
;;;; Waitqueues/condition variables
+#!+(or (not sb-thread) sb-futex)
(defstruct (waitqueue (:constructor %make-waitqueue))
#!+sb-doc
"Waitqueue type."
(name nil :type (or null thread-name))
- #!+(and sb-lutex sb-thread)
- (lutex (make-lutex))
- #!-sb-lutex
+ #!+sb-futex
(token nil))
+#!+(and sb-thread (not sb-futex))
+(progn
+ (defstruct (waitqueue (:constructor %make-waitqueue))
+ #!+sb-doc
+ "Waitqueue type."
+ (name nil :type (or null thread-name))
+ ;; For WITH-CAS-LOCK: because CONDITION-WAIT must be able to call
+ ;; %WAITQUEUE-WAKEUP without re-aquiring the mutex, we need a separate
+ ;; lock. In most cases this should be uncontested thanks to the mutex --
+ ;; the only case where that might not be true is when CONDITION-WAIT
+ ;; unwinds and %WAITQUEUE-DROP is called.
+ %owner
+ %head
+ %tail)
+
+ (defun %waitqueue-enqueue (thread queue)
+ (setf (thread-waiting-for thread) queue)
+ (let ((head (waitqueue-%head queue))
+ (tail (waitqueue-%tail queue))
+ (new (list thread)))
+ (unless head
+ (setf (waitqueue-%head queue) new))
+ (when tail
+ (setf (cdr tail) new))
+ (setf (waitqueue-%tail queue) new)
+ nil))
+ (defun %waitqueue-drop (thread queue)
+ (setf (thread-waiting-for thread) nil)
+ (let ((head (waitqueue-%head queue)))
+ (do ((list head (cdr list))
+ (prev nil))
+ ((eq (car list) thread)
+ (let ((rest (cdr list)))
+ (cond (prev
+ (setf (cdr prev) rest))
+ (t
+ (setf (waitqueue-%head queue) rest
+ prev rest)))
+ (unless rest
+ (setf (waitqueue-%tail queue) prev))))
+ (setf prev list)))
+ nil)
+ (defun %waitqueue-wakeup (queue n)
+ (declare (fixnum n))
+ (loop while (plusp n)
+ for next = (let ((head (waitqueue-%head queue))
+ (tail (waitqueue-%tail queue)))
+ (when head
+ (if (eq head tail)
+ (setf (waitqueue-%head queue) nil
+ (waitqueue-%tail queue) nil)
+ (setf (waitqueue-%head queue) (cdr head)))
+ (car head)))
+ while next
+ do (when (eq queue (sb!ext:compare-and-swap (thread-waiting-for next) queue nil))
+ (decf n)))
+ nil))
+
(def!method print-object ((waitqueue waitqueue) stream)
(print-unreadable-object (waitqueue stream :type t :identity t)
(format stream "~@[~A~]" (waitqueue-name waitqueue))))
(setf (fdocumentation 'waitqueue-name 'function)
"The name of the waitqueue. Setfable.")
-#!+(and sb-thread (not sb-lutex))
+#!+(and sb-thread sb-futex)
(define-structure-slot-addressor waitqueue-token-address
:structure waitqueue
:slot token)
-(defun condition-wait (queue mutex)
+(defun condition-wait (queue mutex &key timeout)
#!+sb-doc
- "Atomically release MUTEX and enqueue ourselves on QUEUE. Another thread may
-subsequently notify us using CONDITION-NOTIFY, at which time we reacquire
-MUTEX and return to the caller.
+ "Atomically release MUTEX and start waiting on QUEUE for till another thread
+wakes us up using either CONDITION-NOTIFY or CONDITION-BROADCAST on that
+queue, at which point we re-acquire MUTEX and return T.
+
+Spurious wakeups are possible.
-Important: CONDITION-WAIT may return without CONDITION-NOTIFY having occurred.
-The correct way to write code that uses CONDITION-WAIT is to loop around the
-call, checking the the associated data:
+If TIMEOUT is given, it is the maximum number of seconds to wait, including
+both waiting for the wakeup and the time to re-acquire MUTEX. Unless both
+wakeup and re-acquisition do not occur within the given time, returns NIL
+without re-acquiring the mutex.
+
+If CONDITION-WAIT unwinds, it may do so with or without the mutex being held.
+
+Important: Since CONDITION-WAIT may return without CONDITION-NOTIFY having
+occurred the correct way to write code that uses CONDITION-WAIT is to loop
+around the call, checking the the associated data:
(defvar *data* nil)
(defvar *queue* (make-waitqueue))
(defvar *lock* (make-mutex))
;; Consumer
- (defun pop-data ()
+ (defun pop-data (&optional timeout)
(with-mutex (*lock*)
(loop until *data*
- do (condition-wait *queue* *lock*))
+ do (or (condition-wait *queue* *lock* :timeout timeout)
+ ;; Lock not held, must unwind without touching *data*.
+ (return-from pop-data nil)))
(pop *data*)))
;; Producer
(with-mutex (*lock*)
(push data *data*)
(condition-notify *queue*)))
-
-Also note that if CONDITION-WAIT unwinds (due to eg. a timeout) instead of
-returning normally, it may do so without holding the mutex."
- #!-sb-thread (declare (ignore queue))
+"
+ #!-sb-thread (declare (ignore queue timeout))
(assert mutex)
#!-sb-thread (error "Not supported in unithread builds.")
#!+sb-thread
(let ((me *current-thread*))
(barrier (:read))
(assert (eq me (mutex-%owner mutex)))
- (/show0 "CONDITION-WAITing")
- #!+sb-lutex
- ;; Need to disable interrupts so that we don't miss setting the
- ;; owner on our way out. (pthread_cond_wait handles the actual
- ;; re-acquisition.)
- (without-interrupts
- (unwind-protect
- (progn
- (setf (mutex-%owner mutex) nil)
- (with-lutex-address (queue-lutex-address (waitqueue-lutex queue))
- (with-lutex-address (mutex-lutex-address (mutex-lutex mutex))
- (with-local-interrupts
- (%lutex-wait queue-lutex-address mutex-lutex-address)))))
- (barrier (:write)
- (setf (mutex-%owner mutex) me))))
- #!-sb-lutex
- ;; Need to disable interrupts so that we don't miss grabbing the
- ;; mutex on our way out.
- (without-interrupts
- ;; This setf becomes visible to other CPUS due to the usual
- ;; memory barrier semantics of lock acquire/release. This must
- ;; not be moved into the loop else wakeups may be lost upon
- ;; continuing after a deadline or EINTR.
- (setf (waitqueue-token queue) me)
- (loop
- (multiple-value-bind (to-sec to-usec)
- (allow-with-interrupts (decode-timeout nil))
- (case (unwind-protect
- (with-pinned-objects (queue me)
- ;; RELEASE-MUTEX is purposefully as close to
- ;; FUTEX-WAIT as possible to reduce the size of
- ;; the window where the token may be set by a
- ;; notifier.
- (release-mutex mutex)
- ;; Now we go to sleep using futex-wait. If
- ;; anyone else manages to grab MUTEX and call
- ;; CONDITION-NOTIFY during this comment, it
- ;; will change the token, and so futex-wait
- ;; returns immediately instead of sleeping.
- ;; Ergo, no lost wakeup. We may get spurious
- ;; wakeups, but that's ok.
- (allow-with-interrupts
- (futex-wait (waitqueue-token-address queue)
- (get-lisp-obj-address me)
- ;; our way of saying "no
- ;; timeout":
- (or to-sec -1)
- (or to-usec 0))))
- ;; 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
- ;; better than nothing.
- (allow-with-interrupts (get-mutex mutex)))
- ;; ETIMEDOUT; we know it was a timeout, yet we cannot
- ;; signal a deadline unconditionally here because the
- ;; call to GET-MUTEX may already have signaled it.
- ((1))
- ;; EINTR; we do not need to return to the caller because
- ;; an interleaved wakeup would change the token causing an
- ;; EWOULDBLOCK in the next iteration.
- ((2))
- ;; EWOULDBLOCK, -1 here, is the possible spurious wakeup
- ;; case. 0 is the normal wakeup.
- (otherwise (return))))))))
+ (multiple-value-bind (to-sec to-usec stop-sec stop-usec deadlinep)
+ (decode-timeout timeout)
+ (let ((status :interrupted))
+ ;; Need to disable interrupts so that we don't miss grabbing the
+ ;; mutex on our way out.
+ (without-interrupts
+ (unwind-protect
+ (progn
+ #!-sb-futex
+ (progn
+ (%waitqueue-enqueue me queue)
+ (release-mutex mutex)
+ (setf status
+ (or (flet ((wakeup ()
+ (when (neq queue (thread-waiting-for me))
+ :ok)))
+ (declare (dynamic-extent #'wakeup))
+ (allow-with-interrupts
+ (sb!impl::%%wait-for #'wakeup stop-sec stop-usec)))
+ :timeout)))
+ #!+sb-futex
+ (with-pinned-objects (queue me)
+ (setf (waitqueue-token queue) me)
+ (release-mutex mutex)
+ ;; Now we go to sleep using futex-wait. If anyone else
+ ;; manages to grab MUTEX and call CONDITION-NOTIFY during
+ ;; this comment, it will change the token, and so futex-wait
+ ;; returns immediately instead of sleeping. Ergo, no lost
+ ;; wakeup. We may get spurious wakeups, but that's ok.
+ (setf status
+ (case (allow-with-interrupts
+ (futex-wait (waitqueue-token-address queue)
+ (get-lisp-obj-address me)
+ ;; our way of saying "no
+ ;; timeout":
+ (or to-sec -1)
+ (or to-usec 0)))
+ ((1)
+ ;; 1 = ETIMEDOUT
+ :timeout)
+ (t
+ ;; -1 = EWOULDBLOCK, possibly spurious wakeup
+ ;; 0 = normal wakeup
+ ;; 2 = EINTR, a spurious wakeup
+ :ok)))))
+ #!-sb-futex
+ (%with-cas-lock ((waitqueue-%owner queue))
+ (if (eq queue (thread-waiting-for me))
+ (%waitqueue-drop me queue)
+ (unless (eq :ok status)
+ ;; CONDITION-NOTIFY thinks we've been woken up, but really
+ ;; we're unwinding. Wake someone else up.
+ (%waitqueue-wakeup queue 1))))
+ ;; Update timeout for mutex re-aquisition.
+ (when (and (eq :ok status) to-sec)
+ (setf (values to-sec to-usec)
+ (sb!impl::relative-decoded-times stop-sec stop-usec)))
+ ;; If we ran into deadline, try to get the mutex before
+ ;; signaling. If we don't unwind it will look like a normal
+ ;; return from user perspective.
+ (when (and (eq :timeout status) deadlinep)
+ (let ((got-it (%try-mutex mutex me)))
+ (allow-with-interrupts
+ (signal-deadline))
+ (cond (got-it
+ (return-from condition-wait t))
+ (t
+ (setf (values to-sec to-usec stop-sec stop-usec deadlinep)
+ (decode-timeout timeout))))))
+ ;; Re-acquire the mutex for normal return.
+ (unless (or (%try-mutex mutex me)
+ (allow-with-interrupts
+ (%wait-for-mutex mutex me timeout
+ to-sec to-usec
+ stop-sec stop-usec deadlinep)))
+ ;; The only case we return normally without re-acquiring the
+ ;; mutex is when there is a :TIMEOUT that runs out.
+ (aver (and timeout (not deadlinep)))
+ (return-from condition-wait nil)))))))
+ t)
(defun condition-notify (queue &optional (n 1))
#!+sb-doc
- "Notify N threads waiting on QUEUE. The same mutex that is used in
-the corresponding CONDITION-WAIT must be held by this thread during
-this call."
- #!-sb-thread (declare (ignore queue n))
- #!-sb-thread (error "Not supported in unithread builds.")
+ "Notify N threads waiting on QUEUE.
+
+IMPORTANT: The same mutex that is used in the corresponding CONDITION-WAIT
+must be held by this thread during this call."
+ #!-sb-thread
+ (declare (ignore queue n))
+ #!-sb-thread
+ (error "Not supported in unithread builds.")
#!+sb-thread
(declare (type (and fixnum (integer 1)) n))
(/show0 "Entering CONDITION-NOTIFY")
#!+sb-thread
(progn
- #!+sb-lutex
- (with-lutex-address (lutex (waitqueue-lutex queue))
- (%lutex-wake lutex n))
+ #!-sb-futex
+ (with-cas-lock ((waitqueue-%owner queue))
+ (%waitqueue-wakeup queue n))
+ #!+sb-futex
+ (progn
;; 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 -- using the queue object itself is handy.
;; is visible to all CPUs.
;;
;; ^-- surely futex_wake() involves a memory barrier?
- #!-sb-lutex
- (progn
(setf (waitqueue-token queue) queue)
(with-pinned-objects (queue)
(futex-wake (waitqueue-token-address queue) n)))))
(defun condition-broadcast (queue)
#!+sb-doc
- "Notify all threads waiting on QUEUE."
+ "Notify all threads waiting on QUEUE.
+
+IMPORTANT: The same mutex that is used in the corresponding CONDITION-WAIT
+must be held by this thread during this call."
(condition-notify queue
;; On a 64-bit platform truncating M-P-F to an int
;; results in -1, which wakes up only one thread.
(declaim (inline semaphore-count))
(defun semaphore-count (instance)
"Returns the current count of the semaphore INSTANCE."
+ (barrier (:read))
(semaphore-%count instance))
(defun make-semaphore (&key name (count 0))
"Try to decrement the count of SEMAPHORE by N. If the count were to
become negative, punt and return NIL, otherwise return true."
(declare (type (integer 1) n))
- (with-mutex ((semaphore-mutex semaphore))
+ (with-system-mutex ((semaphore-mutex semaphore) :allow-with-interrupts t)
(let ((new-count (- (semaphore-%count semaphore) n)))
(when (not (minusp new-count))
(setf (semaphore-%count semaphore) new-count)))))
(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))))
+ (%delete-thread-from-session thread *session*))))
(defun terminate-session ()
#!+sb-doc
"Mutex type."
(name nil :type (or null thread-name))
(%owner nil :type (or null thread))
- #!+(and (not sb-lutex) sb-thread)
- (state 0 :type fixnum)
- #!+(and sb-lutex sb-thread)
- (lutex (make-lutex)))
+ #!+(and sb-thread sb-futex)
+ (state 0 :type fixnum))
(defun mutex-value (mutex)
"Current owner of the mutex, NIL if the mutex is free. May return a
fdefn-widetag ; 01010110
no-tls-value-marker-widetag ; 01011010
- #!-(and sb-lutex sb-thread)
- unused01-widetag
- #!+(and sb-lutex sb-thread)
- lutex-widetag ; 01011110
+ unused01-widetag ; 01011110
unused02-widetag ; 01100010
unused03-widetag ; 01100110
unused04-widetag ; 01101010
(defconstant new-directory-core-entry-type-code 3861)
(defconstant initial-fun-core-entry-type-code 3863)
(defconstant page-table-core-entry-type-code 3880)
-#!+(and sb-lutex sb-thread)
-(defconstant lutex-table-core-entry-type-code 3887)
(defconstant end-core-entry-type-code 3840)
(declaim (ftype (function (sb!vm:word) sb!vm:word) write-word))
(!define-type-vops fdefn-p nil nil nil
(fdefn-widetag))
-#!+(and sb-thread sb-lutex)
-(!define-type-vops lutexp nil nil nil
- (lutex-widetag))
-
(!define-type-vops funcallable-instance-p nil nil nil
(funcallable-instance-header-widetag))
(real :c-type "double" :length #!-x86-64 2 #!+x86-64 1)
(imag :c-type "double" :length #!-x86-64 2 #!+x86-64 1))
-#!+(and sb-lutex sb-thread)
-(define-primitive-object (lutex
- :lowtag other-pointer-lowtag
- :widetag lutex-widetag
- :alloc-trans %make-lutex)
- (gen :c-type "long" :length 1)
- (live :c-type "long" :length 1)
- (next :c-type "struct lutex *" :length 1)
- (prev :c-type "struct lutex *" :length 1)
- (mutex :c-type "pthread_mutex_t *"
- :length 1)
- (mutexattr :c-type "pthread_mutexattr_t *"
- :length 1)
- (condition-variable :c-type "pthread_cond_t *"
- :length 1))
-
;;; this isn't actually a lisp object at all, it's a c structure that lives
;;; in c-land. However, we need sight of so many parts of it from Lisp that
;;; it makes sense to define it here anyway, so that the GENESIS machinery
;;;; threading
-#!+(and sb-lutex sb-thread)
-(progn
- (defknown sb!vm::%make-lutex () sb!vm::lutex ())
- (defknown sb!vm::lutexp (t) boolean (foldable flushable)))
-
(defknown (dynamic-space-free-pointer binding-stack-pointer-sap
control-stack-pointer-sap) ()
system-area-pointer
COMMON_SRC = alloc.c backtrace.c breakpoint.c coreparse.c \
dynbind.c funcall.c gc-common.c globals.c interr.c interrupt.c \
largefile.c monitor.c os-common.c parse.c print.c purify.c \
- pthread-futex.c pthread-lutex.c \
+ pthread-futex.c \
regnames.c run-program.c runtime.c save.c search.c \
thread.c time.c util.c validate.c vars.c wrap.c
#include "validate.h"
#include "gc-internal.h"
-/* lutex stuff */
-#if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_SB_LUTEX)
-#include "genesis/sap.h"
-#include "pthread-lutex.h"
-#endif
-
#include <errno.h>
#ifdef LISP_FEATURE_SB_CORE_COMPRESSION
initial_function = (lispobj)*ptr;
break;
-#if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_SB_LUTEX)
- case LUTEX_TABLE_CORE_ENTRY_TYPE_CODE:
- SHOW("LUTEX_TABLE_CORE_ENTRY_TYPE_CODE case");
- {
- size_t n_lutexes = *ptr;
- size_t fdoffset = (*(ptr + 1) + 1) * (os_vm_page_size);
- size_t data_length = n_lutexes * sizeof(struct sap *);
- struct lutex **lutexes_to_resurrect = malloc(data_length);
- long bytes_read;
-
- lseek(fd, fdoffset + file_offset, SEEK_SET);
-
- FSHOW((stderr, "attempting to read %ld lutexes from core\n", n_lutexes));
- bytes_read = read(fd, lutexes_to_resurrect, data_length);
-
- /* XXX */
- if (bytes_read != data_length) {
- lose("Could not read the lutex table");
- }
- else {
- int i;
-
- for (i=0; i<n_lutexes; ++i) {
- struct lutex *lutex = lutexes_to_resurrect[i];
-
- FSHOW((stderr, "re-init'ing lutex @ %p\n", lutex));
- lutex_init((tagged_lutex_t) lutex);
- }
-
- free(lutexes_to_resurrect);
- }
- break;
- }
-#endif
-
#ifdef LISP_FEATURE_GENCGC
case PAGE_TABLE_CORE_ENTRY_TYPE_CODE:
{
#include "genesis/instance.h"
#include "genesis/layout.h"
#include "gencgc.h"
-#if defined(LUTEX_WIDETAG)
-#include "pthread-lutex.h"
-#endif
#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
#include "genesis/cons.h"
#endif
* prevent a GC when a large number of new live objects have been
* added, in which case a GC could be a waste of time */
double minimum_age_before_gc;
-
- /* A linked list of lutex structures in this generation, used for
- * implementing lutex finalization. */
-#ifdef LUTEX_WIDETAG
- struct lutex *lutexes;
-#else
- void *lutexes;
-#endif
};
/* an array of generation structures. There needs to be one more
return copy_large_unboxed_object(object, length);
}
#endif
-
-\f
-/*
- * Lutexes. Using the normal finalization machinery for finalizing
- * lutexes is tricky, since the finalization depends on working lutexes.
- * So we track the lutexes in the GC and finalize them manually.
- */
-
-#if defined(LUTEX_WIDETAG)
-
-/*
- * Start tracking LUTEX in the GC, by adding it to the linked list of
- * lutexes in the nursery generation. The caller is responsible for
- * locking, and GCs must be inhibited until the registration is
- * complete.
- */
-void
-gencgc_register_lutex (struct lutex *lutex) {
- int index = find_page_index(lutex);
- generation_index_t gen;
- struct lutex *head;
-
- /* This lutex is in static space, so we don't need to worry about
- * finalizing it.
- */
- if (index == -1)
- return;
-
- gen = page_table[index].gen;
-
- gc_assert(gen >= 0);
- gc_assert(gen < NUM_GENERATIONS);
-
- head = generations[gen].lutexes;
-
- lutex->gen = gen;
- lutex->next = head;
- lutex->prev = NULL;
- if (head)
- head->prev = lutex;
- generations[gen].lutexes = lutex;
-}
-
-/*
- * Stop tracking LUTEX in the GC by removing it from the appropriate
- * linked lists. This will only be called during GC, so no locking is
- * needed.
- */
-void
-gencgc_unregister_lutex (struct lutex *lutex) {
- if (lutex->prev) {
- lutex->prev->next = lutex->next;
- } else {
- generations[lutex->gen].lutexes = lutex->next;
- }
-
- if (lutex->next) {
- lutex->next->prev = lutex->prev;
- }
-
- lutex->next = NULL;
- lutex->prev = NULL;
- lutex->gen = -1;
-}
-
-/*
- * Mark all lutexes in generation GEN as not live.
- */
-static void
-unmark_lutexes (generation_index_t gen) {
- struct lutex *lutex = generations[gen].lutexes;
-
- while (lutex) {
- lutex->live = 0;
- lutex = lutex->next;
- }
-}
-
-/*
- * Finalize all lutexes in generation GEN that have not been marked live.
- */
-static void
-reap_lutexes (generation_index_t gen) {
- struct lutex *lutex = generations[gen].lutexes;
-
- while (lutex) {
- struct lutex *next = lutex->next;
- if (!lutex->live) {
- lutex_destroy((tagged_lutex_t) lutex);
- gencgc_unregister_lutex(lutex);
- }
- lutex = next;
- }
-}
-
-/*
- * Mark LUTEX as live.
- */
-static void
-mark_lutex (lispobj tagged_lutex) {
- struct lutex *lutex = (struct lutex*) native_pointer(tagged_lutex);
-
- lutex->live = 1;
-}
-
-/*
- * Move all lutexes in generation FROM to generation TO.
- */
-static void
-move_lutexes (generation_index_t from, generation_index_t to) {
- struct lutex *tail = generations[from].lutexes;
-
- /* Nothing to move */
- if (!tail)
- return;
-
- /* Change the generation of the lutexes in FROM. */
- while (tail->next) {
- tail->gen = to;
- tail = tail->next;
- }
- tail->gen = to;
-
- /* Link the last lutex in the FROM list to the start of the TO list */
- tail->next = generations[to].lutexes;
-
- /* And vice versa */
- if (generations[to].lutexes) {
- generations[to].lutexes->prev = tail;
- }
-
- /* And update the generations structures to match this */
- generations[to].lutexes = generations[from].lutexes;
- generations[from].lutexes = NULL;
-}
-
-static long
-scav_lutex(lispobj *where, lispobj object)
-{
- mark_lutex((lispobj) where);
-
- return CEILING(sizeof(struct lutex)/sizeof(lispobj), 2);
-}
-
-static lispobj
-trans_lutex(lispobj object)
-{
- struct lutex *lutex = (struct lutex *) native_pointer(object);
- lispobj copied;
- size_t words = CEILING(sizeof(struct lutex)/sizeof(lispobj), 2);
- gc_assert(is_lisp_pointer(object));
- copied = copy_object(object, words);
-
- /* Update the links, since the lutex moved in memory. */
- if (lutex->next) {
- lutex->next->prev = (struct lutex *) native_pointer(copied);
- }
-
- if (lutex->prev) {
- lutex->prev->next = (struct lutex *) native_pointer(copied);
- } else {
- generations[lutex->gen].lutexes =
- (struct lutex *) native_pointer(copied);
- }
-
- return copied;
-}
-
-static long
-size_lutex(lispobj *where)
-{
- return CEILING(sizeof(struct lutex)/sizeof(lispobj), 2);
-}
-#endif /* LUTEX_WIDETAG */
-
\f
/*
* weak pointers
#endif
case SAP_WIDETAG:
case WEAK_POINTER_WIDETAG:
-#ifdef LUTEX_WIDETAG
- case LUTEX_WIDETAG:
-#endif
break;
default:
#endif
case SAP_WIDETAG:
case WEAK_POINTER_WIDETAG:
-#ifdef LUTEX_WIDETAG
- case LUTEX_WIDETAG:
-#endif
#ifdef NO_TLS_VALUE_MARKER_WIDETAG
case NO_TLS_VALUE_MARKER_WIDETAG:
#endif
/* Initialize the weak pointer list. */
weak_pointers = NULL;
-#ifdef LUTEX_WIDETAG
- unmark_lutexes(generation);
-#endif
-
/* When a generation is not being raised it is transported to a
* temporary generation (NUM_GENERATIONS), and lowered when
* done. Set up this new generation. There should be no pages
else
++generations[generation].num_gc;
-#ifdef LUTEX_WIDETAG
- reap_lutexes(generation);
- if (raise)
- move_lutexes(generation, generation+1);
-#endif
}
/* Update last_free_page, then SymbolValue(ALLOCATION_POINTER). */
generations[page].gc_trigger = 2000000;
generations[page].num_gc = 0;
generations[page].cum_sum_bytes_allocated = 0;
- generations[page].lutexes = NULL;
}
if (gencgc_verbose > 1)
scavtab[WEAK_POINTER_WIDETAG] = scav_weak_pointer;
transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed_large;
-#ifdef LUTEX_WIDETAG
- scavtab[LUTEX_WIDETAG] = scav_lutex;
- transother[LUTEX_WIDETAG] = trans_lutex;
- sizetab[LUTEX_WIDETAG] = size_lutex;
-#endif
-
heap_base = (void*)DYNAMIC_SPACE_START;
/* The page structures are initialized implicitly when page_table
generations[i].bytes_consed_between_gc = 2000000;
generations[i].number_of_gcs_before_promotion = 1;
generations[i].minimum_age_before_gc = 0.75;
- generations[i].lutexes = NULL;
}
/* Initialize gc_alloc. */
page++;
} while (page_address(page) < alloc_ptr);
-#ifdef LUTEX_WIDETAG
- /* Lutexes have been registered in generation 0 by coreparse, and
- * need to be moved to the right one manually.
- */
- move_lutexes(0, PSEUDO_STATIC_GENERATION);
-#endif
-
last_free_page = page;
generations[gen].bytes_allocated = npage_bytes(page);
#ifndef __GENCGC_H__
#define __GENCGC_H__
-#if defined(LUTEX_WIDETAG)
-#include "genesis/lutex.h"
-
-extern void gencgc_register_lutex (struct lutex *lutex);
-extern void gencgc_unregister_lutex (struct lutex *lutex);
-#endif
-
#endif /* __GENCGC_H__ */
+++ /dev/null
-/* An approximation of Linux futexes implemented using pthread mutexes
- * and pthread condition variables.
- */
-
-/*
- * This software is part of the SBCL system. See the README file for
- * more information.
- *
- * The software is in the public domain and is provided with
- * absolutely no warranty. See the COPYING and CREDITS files for more
- * information.
- */
-
-#include "sbcl.h"
-
-#if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_SB_LUTEX)
-
-#include <errno.h>
-#include <stdlib.h>
-
-#include "runtime.h"
-#include "arch.h"
-#include "target-arch-os.h"
-#include "os.h"
-#include "pthread-lutex.h"
-#include "gencgc.h"
-
-#include "genesis/lutex.h"
-
-#if 1
-# define lutex_assert(ex) \
-do { \
- if (!(ex)) lutex_abort(); \
-} while (0)
-# define lutex_assert_verbose(ex, fmt, ...) \
-do { \
- if (!(ex)) { \
- fprintf(stderr, fmt, ## __VA_ARGS__); \
- lutex_abort(); \
- } \
-} while (0)
-#else
-# define lutex_assert(ex)
-# define lutex_assert_verbose(ex, fmt, ...)
-#endif
-
-#define lutex_abort() \
- lose("Lutex assertion failure, file \"%s\", line %d\n", __FILE__, __LINE__)
-
-
-pthread_mutex_t lutex_register_lock = PTHREAD_MUTEX_INITIALIZER;
-
-int
-lutex_init (tagged_lutex_t tagged_lutex)
-{
- int ret;
- struct lutex *lutex = (struct lutex*) native_pointer(tagged_lutex);
-
- lutex->mutexattr = malloc(sizeof(pthread_mutexattr_t));
- lutex_assert(lutex->mutexattr != 0);
-
- ret = pthread_mutexattr_init(lutex->mutexattr);
- lutex_assert(ret == 0);
-
- /* The default type of mutex is implementation dependent.
- * We use PTHREAD_MUTEX_ERRORCHECK so that locking on mutexes
- * locked by the same thread does not cause deadlocks. */
- /* FIXME: pthread_mutexattr_settype is available on SUSv2 level
- * implementations. Can be used without checking? */
- ret = pthread_mutexattr_settype(lutex->mutexattr,
- PTHREAD_MUTEX_ERRORCHECK);
- lutex_assert(ret == 0);
-
- lutex->mutex = malloc(sizeof(pthread_mutex_t));
- lutex_assert(lutex->mutex != 0);
-
- ret = pthread_mutex_init(lutex->mutex, lutex->mutexattr);
- lutex_assert(ret == 0);
-
- lutex->condition_variable = malloc(sizeof(pthread_cond_t));
- lutex_assert(lutex->condition_variable != 0);
-
- ret = pthread_cond_init(lutex->condition_variable, NULL);
- lutex_assert(ret == 0);
-
- ret = thread_mutex_lock(&lutex_register_lock); lutex_assert(ret == 0);
-
- gencgc_register_lutex(lutex);
-
- ret = thread_mutex_unlock(&lutex_register_lock); lutex_assert(ret == 0);
-
- return ret;
-}
-
-int
-lutex_wait (tagged_lutex_t tagged_queue_lutex, tagged_lutex_t tagged_mutex_lutex)
-{
- int ret;
- struct lutex *queue_lutex = (struct lutex*) native_pointer(tagged_queue_lutex);
- struct lutex *mutex_lutex = (struct lutex*) native_pointer(tagged_mutex_lutex);
-
- ret = pthread_cond_wait(queue_lutex->condition_variable, mutex_lutex->mutex);
- lutex_assert(ret == 0);
-
- return ret;
-}
-
-int
-lutex_wake (tagged_lutex_t tagged_lutex, int n)
-{
- int ret = 0;
- struct lutex *lutex = (struct lutex*) native_pointer(tagged_lutex);
-
- /* The lisp-side code passes N=2**29-1 for a broadcast. */
- if (n >= ((1 << 29) - 1)) {
- /* CONDITION-BROADCAST */
- ret = pthread_cond_broadcast(lutex->condition_variable);
- lutex_assert(ret == 0);
- } else{
- /* We're holding the condition variable mutex, so a thread
- * we're waking can't re-enter the wait between to calls to
- * pthread_cond_signal. Thus we'll wake N different threads,
- * instead of the same thread N times.
- */
- while (n--) {
- ret = pthread_cond_signal(lutex->condition_variable);
- lutex_assert(ret == 0);
- }
- }
-
- return ret;
-}
-
-int
-lutex_lock (tagged_lutex_t tagged_lutex)
-{
- int ret = 0;
- struct lutex *lutex = (struct lutex*) native_pointer(tagged_lutex);
-
- ret = thread_mutex_lock(lutex->mutex);
- /* The mutex is locked by the same thread.
- *
- * FIXME: Usually when POSIX says that "an error value is returned"
- * it actually refers to errno...
- */
- if (ret == EDEADLK)
- return ret;
- lutex_assert(ret == 0);
-
- return ret;
-}
-
-int
-lutex_trylock (tagged_lutex_t tagged_lutex)
-{
- int ret = 0;
- struct lutex *lutex = (struct lutex*) native_pointer(tagged_lutex);
-
- ret = pthread_mutex_trylock(lutex->mutex);
- /* The mutex is locked */
- if (ret == EDEADLK || ret == EBUSY)
- return ret;
- lutex_assert(ret == 0);
-
- return ret;
-}
-
-int
-lutex_unlock (tagged_lutex_t tagged_lutex)
-{
- int ret = 0;
- struct lutex *lutex = (struct lutex*) native_pointer(tagged_lutex);
-
- ret = thread_mutex_unlock(lutex->mutex);
- /* Unlocking unlocked mutex would occur as:
- * (with-mutex (mutex) (cond-wait cond mutex)) */
- if (ret == EPERM)
- return ret;
- lutex_assert(ret == 0);
-
- return ret;
-}
-
-int
-lutex_destroy (tagged_lutex_t tagged_lutex)
-{
- struct lutex *lutex = (struct lutex*) native_pointer(tagged_lutex);
-
- if (lutex->condition_variable) {
- pthread_cond_destroy(lutex->condition_variable);
- free(lutex->condition_variable);
- lutex->condition_variable = NULL;
- }
-
- if (lutex->mutex) {
- pthread_mutex_destroy(lutex->mutex);
- free(lutex->mutex);
- lutex->mutex = NULL;
- }
-
- if (lutex->mutexattr) {
- pthread_mutexattr_destroy(lutex->mutexattr);
- free(lutex->mutexattr);
- lutex->mutexattr = NULL;
- }
-
- return 0;
-}
-#endif
+++ /dev/null
-/*
- * This software is part of the SBCL system. See the README file for
- * more information.
- *
- * This software is derived from the CMU CL system, which was
- * written at Carnegie Mellon University and released into the
- * public domain. The software is in the public domain and is
- * provided with absolutely no warranty. See the COPYING and CREDITS
- * files for more information.
- */
-
-#ifndef __PTHREAD_LUTEX_H__
-#define __PTHREAD_LUTEX_H__
-
-#if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_SB_LUTEX)
-
-typedef unsigned long tagged_lutex_t;
-
-extern int lutex_init (tagged_lutex_t tagged_lutex);
-extern int lutex_destroy (tagged_lutex_t tagged_lutex);
-
-#endif
-
-#endif /* __PTHREAD_LUTEX_H__ */
#endif
case SAP_WIDETAG:
return ptrans_unboxed(thing, header);
-#ifdef LUTEX_WIDETAG
- case LUTEX_WIDETAG:
- gencgc_unregister_lutex((struct lutex *) native_pointer(thing));
- return ptrans_unboxed(thing, header);
-#endif
-
case RATIO_WIDETAG:
case COMPLEX_WIDETAG:
case SIMPLE_ARRAY_WIDETAG:
#include "genesis/static-symbols.h"
#include "genesis/symbol.h"
-#if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_SB_LUTEX)
-#include "genesis/lutex.h"
-#endif
-
#ifdef LISP_FEATURE_SB_CORE_COMPRESSION
# include <zlib.h>
#endif
-
/* write_runtime_options uses a simple serialization scheme that
* consists of one word of magic, one word indicating whether options
* are actually saved, and one word per struct field. */
COMPRESSION_LEVEL_NONE);
}
-#if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_SB_LUTEX)
-/* saving lutexes in the core */
-static void **lutex_addresses;
-static long n_lutexes = 0;
-static long max_lutexes = 0;
-
-static long
-default_scan_action(lispobj *obj)
-{
- return (sizetab[widetag_of(*obj)])(obj);
-}
-
-static long
-lutex_scan_action(lispobj *obj)
-{
- /* note the address of the lutex */
- if(n_lutexes >= max_lutexes) {
- max_lutexes *= 2;
- lutex_addresses = realloc(lutex_addresses, max_lutexes * sizeof(void *));
- gc_assert(lutex_addresses);
- }
-
- lutex_addresses[n_lutexes++] = obj;
-
- return (*sizetab[widetag_of(*obj)])(obj);
-}
-
-typedef long (*scan_table[256])(lispobj *obj);
-
-static void
-scan_objects(lispobj *start, long n_words, scan_table table)
-{
- lispobj *end = start + n_words;
- lispobj *object_ptr;
- long n_words_scanned;
- for (object_ptr = start;
- object_ptr < end;
- object_ptr += n_words_scanned) {
- lispobj obj = *object_ptr;
-
- n_words_scanned = (table[widetag_of(obj)])(object_ptr);
- }
-}
-
-static void
-scan_for_lutexes(lispobj *addr, long n_words)
-{
- static int initialized = 0;
- static scan_table lutex_scan_table;
-
- if (!initialized) {
- int i;
-
- /* allocate a little space to get started */
- lutex_addresses = malloc(16*sizeof(void *));
- gc_assert(lutex_addresses);
- max_lutexes = 16;
-
- /* initialize the mapping table */
- for(i = 0; i < ((sizeof lutex_scan_table)/(sizeof lutex_scan_table[0])); ++i) {
- lutex_scan_table[i] = default_scan_action;
- }
-
- lutex_scan_table[LUTEX_WIDETAG] = lutex_scan_action;
-
- initialized = 1;
- }
-
- /* do the scan */
- scan_objects(addr, n_words, lutex_scan_table);
-}
-#endif
-
static void
output_space(FILE *file, int id, lispobj *addr, lispobj *end,
os_vm_offset_t file_offset,
bytes = words * sizeof(lispobj);
-#if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_SB_LUTEX)
- printf("scanning space for lutexes...\n");
- scan_for_lutexes((void *)addr, words);
-#endif
-
printf("writing %lu bytes from the %s space at 0x%08lx\n",
(unsigned long)bytes, names[id], (unsigned long)addr);
}
#endif
-#if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_SB_LUTEX)
- if(n_lutexes > 0) {
- long offset;
- printf("writing %ld lutexes to the core...\n", n_lutexes);
- write_lispobj(LUTEX_TABLE_CORE_ENTRY_TYPE_CODE, file);
- /* word count of the entry */
- write_lispobj(4, file);
- /* indicate how many lutexes we saved */
- write_lispobj(n_lutexes, file);
- /* save the lutexes */
- offset = write_bytes(file, (char *) lutex_addresses,
- n_lutexes * sizeof(*lutex_addresses),
- core_start_pos);
-
- write_lispobj(offset, file);
- }
-#endif
-
write_lispobj(END_CORE_ENTRY_TYPE_CODE, file);
/* Write a trailing header, ignored when parsing the core normally.
(assert (= n 1))
(assert (not final))))
-(with-test (:name (:deadline :get-mutex) :skipped-on '(not (and :sb-thread (not :sb-lutex))))
+(with-test (:name (:deadline :get-mutex) :skipped-on '(not :sb-thread))
(assert-timeout
(let ((lock (sb-thread:make-mutex))
(waitp t))
(sb-sys:with-deadline (:seconds 1)
(sb-thread:get-mutex lock)))))
-(with-test (:name (:deadline :wait-on-semaphore) :skipped-on '(not (and :sb-thread (not :sb-lutex))))
+(with-test (:name (:deadline :wait-on-semaphore) :skipped-on '(not :sb-thread))
(assert-timeout
(let ((sem (sb-thread::make-semaphore :count 0)))
(sb-sys:with-deadline (:seconds 1)
(sb-thread::wait-on-semaphore sem)))))
-(with-test (:name (:deadline :join-thread) :skipped-on '(not (and :sb-thread (not :sb-lutex))))
+(with-test (:name (:deadline :join-thread) :skipped-on '(not :sb-thread))
(assert-timeout
(sb-sys:with-deadline (:seconds 1)
(sb-thread:join-thread
(sb-thread:make-thread (lambda () (loop (sleep 1))))))))
-(with-test (:name (:deadline :futex-wait-eintr) :skipped-on '(not (and :sb-thread (not :sb-lutex))))
+(with-test (:name (:deadline :futex-wait-eintr) :skipped-on '(not :sb-thread))
(let ((lock (sb-thread:make-mutex))
(waitp t))
(sb-thread:make-thread (lambda ()
(caar frame-specs)
full-backtrace)
(setf result nil))
-
;; check that we have all the frames we wanted
(mapcar
(lambda (spec frame)
(list '(flet test) #'not-optimized))))))
(with-test (:name :backtrace-interrupted-condition-wait
- :skipped-on '(not :sb-thread))
+ :skipped-on '(not :sb-thread)
+ ;; For some unfathomable reason the backtrace becomes
+ ;; stunted on Darwin, ending at _sigtramp, when we add
+ ;; :TIMEOUT NIL to the frame we expect. If we leave it out,
+ ;; the backtrace is fine -- but the test fails. I can only
+ ;; boggle right now.
+ :fails-on :darwin)
(let ((m (sb-thread:make-mutex))
(q (sb-thread:make-waitqueue)))
(assert (verify-backtrace
(error "foo"))))
(with-timeout 0.1
(sb-thread:condition-wait q m)))))
- `((sb-thread:condition-wait ,q ,m))))))
+ `((sb-thread:condition-wait ,q ,m :timeout nil))))))
;;; Division by zero was a common error on PPC. It depended on the
;;; return function either being before INTEGER-/-INTEGER in memory,
(incf *test-count*))
(defun fail-test (type test-name condition)
- (log-msg "~@<~A ~S ~:_due to ~S: ~4I~:_\"~A\"~:>"
- type test-name condition condition)
+ (if (stringp condition)
+ (log-msg "~@<~A ~S ~:_~A~:>"
+ type test-name condition)
+ (log-msg "~@<~A ~S ~:_due to ~S: ~4I~:_\"~A\"~:>"
+ type test-name condition condition))
(push (list type *test-file* (or test-name *test-count*))
*failures*)
- (when (or (and *break-on-failure*
- (not (eq type :expected-failure)))
- *break-on-expected-failure*)
- (really-invoke-debugger condition)))
+ (unless (stringp condition)
+ (when (or (and *break-on-failure*
+ (not (eq type :expected-failure)))
+ *break-on-expected-failure*)
+ (really-invoke-debugger condition))))
(defun expected-failure-p (fails-on)
(sb-impl::featurep fails-on))
(grab-mutex m :waitp nil)))))))))
(with-test (:name (:grab-mutex :timeout :acquisition-fail))
- #+sb-lutex
- (error "Mutex timeout not supported here.")
(let ((m (make-mutex))
(w (make-semaphore)))
(with-mutex (m)
(assert (null (join-thread th)))))))
(with-test (:name (:grab-mutex :timeout :acquisition-success))
- #+sb-lutex
- (error "Mutex timeout not supported here.")
(let ((m (make-mutex))
(child))
(with-mutex (m)
(assert (eq (join-thread child) 't))))
(with-test (:name (:grab-mutex :timeout+deadline))
- #+sb-lutex
- (error "Mutex timeout not supported here.")
(let ((m (make-mutex))
(w (make-semaphore)))
(with-mutex (m)
(assert (eq (join-thread th) :deadline))))))
(with-test (:name (:grab-mutex :waitp+deadline))
- #+sb-lutex
- (error "Mutex timeout not supported here.")
(let ((m (make-mutex)))
(with-mutex (m)
(assert (eq (join-thread
(defun alloc-stuff () (copy-list '(1 2 3 4 5)))
-(with-test (:name (:interrupt-thread :interrupt-consing-child))
+(with-test (:name (:interrupt-thread :interrupt-consing-child)
+ :broken-on :darwin)
(let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff))))))
(let ((killers
(loop repeat 4 collect
;;; Make sure that a deadline handler is not invoked twice in a row in
;;; CONDITION-WAIT. See LP #512914 for a detailed explanation.
;;;
-#-sb-lutex ; See KLUDGE above: no deadlines for condition-wait+lutexes.
-(with-test (:name (:condition-wait :deadlines :LP-512914))
- (let ((n 2) ; was empirically enough to trigger the bug
+(with-test (:name (:condition-wait :deadlines :LP-512914)
+ :skipped-on '(not :sb-futex))
+ (let ((n 2) ; was empirically enough to trigger the bug
(mutex (sb-thread:make-mutex))
(waitq (sb-thread:make-waitqueue))
(threads nil)
(deadline-handler-run-twice? nil))
(dotimes (i n)
(let ((child
- (sb-thread:make-thread
- #'(lambda ()
- (handler-bind
- ((sb-sys:deadline-timeout
- (let ((already? nil))
- #'(lambda (c)
- (when already?
- (setq deadline-handler-run-twice? t))
- (setq already? t)
- (sleep 0.2)
- (sb-thread:condition-broadcast waitq)
- (sb-sys:defer-deadline 10.0 c)))))
- (sb-sys:with-deadline (:seconds 0.1)
- (sb-thread:with-mutex (mutex)
- (sb-thread:condition-wait waitq mutex))))))))
+ (sb-thread:make-thread
+ #'(lambda ()
+ (handler-bind
+ ((sb-sys:deadline-timeout
+ (let ((already? nil))
+ #'(lambda (c)
+ (when already?
+ (setq deadline-handler-run-twice? t))
+ (setq already? t)
+ (sleep 0.2)
+ (sb-thread:condition-broadcast waitq)
+ (sb-sys:defer-deadline 10.0 c)))))
+ (sb-sys:with-deadline (:seconds 0.1)
+ (sb-thread:with-mutex (mutex)
+ (sb-thread:condition-wait waitq mutex))))))))
(push child threads)))
(mapc #'sb-thread:join-thread threads)
(assert (not deadline-handler-run-twice?))))
(with-test (:name (:condition-wait :signal-deadline-with-interrupts-enabled))
- #+darwin
- (error "Bad Darwin")
(let ((mutex (sb-thread:make-mutex))
(waitq (sb-thread:make-waitqueue))
(A-holds? :unknown)
(sb-sys:defer-deadline 10.0 c))))
(sb-sys:with-deadline (:seconds 0.1)
(sb-thread:with-mutex (mutex)
- (sb-thread:condition-wait waitq mutex)))))))
+ (sb-thread:condition-wait waitq mutex)))))
+ :name "A"))
(setq B (sb-thread:make-thread
#'(lambda ()
(thread-yield)
(sb-sys:defer-deadline 10.0 c))))
(sb-sys:with-deadline (:seconds 0.1)
(sb-thread:with-mutex (mutex)
- (sb-thread:condition-wait waitq mutex)))))))
+ (sb-thread:condition-wait waitq mutex)))))
+ :name "B"))
(sb-thread:join-thread A)
(sb-thread:join-thread B)
(let ((A-result (list A-holds? A-interrupts-enabled?))
;; behaviour.
(cond ((equal A-result '(t t)) (assert (equal B-result '(nil t))))
((equal B-result '(t t)) (assert (equal A-result '(nil t))))
- (t (error "Failure: fall through."))))))
+ (t
+ (error "Failure: fell through wit A: ~S, B: ~S"
+ A-result
+ B-result))))))
(with-test (:name (:mutex :finalization))
(let ((a nil))
(format t "infodb test done~%")
-(with-test (:name (:backtrace))
- #+darwin
- (error "Prone to crash on Darwin, cause unknown.")
+(with-test (:name :backtrace)
;; Printing backtraces from several threads at once used to hang the
;; whole SBCL process (discovered by accident due to a timer.impure
;; test misbehaving). The cause was that packages weren't even
(format t "~&starting gc deadlock test: WARNING: THIS TEST WILL HANG ON FAILURE!~%")
-(with-test (:name (:gc-deadlock))
- #+darwin
- (error "Prone to hang on Darwin due to interrupt issues.")
+(with-test (:name :gc-deadlock
+ ;; Prone to hang on Darwin due to interrupt issues.
+ :broken-on :darwin)
;; Prior to 0.9.16.46 thread exit potentially deadlocked the
;; GC due to *all-threads-lock* and session lock. On earlier
;; versions and at least on one specific box this test is good enough
;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS
(with-test (:name without-interrupts+condition-wait
- :fails-on :sb-lutex
:skipped-on '(not :sb-thread))
(let* ((lock (make-mutex))
(queue (make-waitqueue))
;;; wich _appear_ to be caused by malloc() and free() not being thread safe: an
;;; interrupted malloc in one thread can apparently block a free in another. There
;;; are also some indications that pthread_mutex_lock is not re-entrant.
-(with-test (:name symbol-value-in-thread.3 :skipped-on '(not :sb-thread) :broken-on :darwin)
+(with-test (:name symbol-value-in-thread.3
+ :skipped-on '(not :sb-thread)
+ :broken-on :darwin)
(let* ((parent *current-thread*)
(semaphore (make-semaphore))
(running t)
:ok)))
:name "T1")))
;; Currently we don't consider it a deadlock
- ;; if there is a timeout in the chain. No
- ;; Timeouts on lutex builds, though.
- (assert (eq #-sb-lutex :deadline
- #+sb-lutex :deadlock
+ ;; if there is a timeout in the chain.
+ (assert (eq :deadline
(handler-case
(sb-thread:with-mutex (m2)
(sb-thread:signal-semaphore s2)
projects / sbcl.git / commitdiff