(use-package :test-util)
(use-package "ASSERTOID")
-(setf sb-unix::*on-dangerous-select* :error)
+(setf sb-unix::*on-dangerous-wait* :error)
(defun wait-for-threads (threads)
(mapc (lambda (thread) (sb-thread:join-thread thread :default nil)) threads)
(with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede)
(format o "void loop_forever() { while(1) ; }~%"))
-(sb-ext:run-program
- #-sunos "cc" #+sunos "gcc"
- (or #+(or linux freebsd sunos) '(#+x86-64 "-fPIC"
- "-shared" "-o" "threads-foreign.so" "threads-foreign.c")
- #+darwin '(#+x86-64 "-arch" #+x86-64 "x86_64"
- "-dynamiclib" "-o" "threads-foreign.so" "threads-foreign.c")
- (error "Missing shared library compilation options for this platform"))
- :search t)
+(sb-ext:run-program "/bin/sh"
+ '("run-compiler.sh" "-sbcl-pic" "-sbcl-shared"
+ "-o" "threads-foreign.so" "threads-foreign.c")
+ :environment (test-util::test-env))
(sb-alien:load-shared-object (truename "threads-foreign.so"))
(sb-alien:define-alien-routine loop-forever sb-alien:void)
(delete-file "threads-foreign.c")
(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)))
(with-mutex (m)
(assert (null (join-thread (make-thread
(grab-mutex m :timeout 0.1)))))))))
(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)))
(with-mutex (m)
(assert (eq (join-thread
: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))
+ #+darwin
+ (error "Hangs on Darwin.")
(let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff))))))
(let ((killers
(loop repeat 4 collect
(format t "~&multi interrupt test done~%")
+#+(or x86 x86-64) ;; x86oid-only, see internal commentary.
(with-test (:name (:interrupt-thread :interrupt-consing-child :again))
+ #+darwin
+ (error "Hangs on Darwin.")
(let ((c (make-thread (lambda () (loop (alloc-stuff))))))
;; NB this only works on x86: other ports don't have a symbol for
;; pseudo-atomic atomicity
(assert (sb-thread:join-thread thread))))
(with-test (:name (:two-threads-running-gc))
+ #+darwin
+ (error "Hangs on Darwin.")
(let (a-done b-done)
(make-thread (lambda ()
(dotimes (i 100)
(format t "~&multiple reader hash table test done~%")
(with-test (:name (:hash-table-single-accessor-parallel-gc))
+ #+darwin
+ (error "Prone to hang on Darwin due to interrupt issues.")
(let ((hash (make-hash-table))
(*errors* nil))
(let ((threads (list (sb-thread:make-thread
(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)
(format t "infodb test done~%")
(with-test (:name (:backtrace))
+ #+darwin
+ (error "Prone to crash on Darwin, cause unknown.")
;; 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.")
;; 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