mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
Split threads.impure in two
So that it can be run in parallel.
This commit is contained in:
Stas Boukarev
parent
c21065bff9
commit
159d9c9583
|
|
@ -126,7 +126,7 @@
|
|||
"../contrib/sb-sprof/test.lisp" "../contrib/sb-sprof/graph.lisp")
|
||||
("signals.impure.lisp" "contrib/sb-posix.fasl")
|
||||
("stream.impure.lisp" "contrib/sb-posix.fasl")
|
||||
("threads.impure.lisp"
|
||||
("threads-2.impure.lisp"
|
||||
"tests/alloca.so"
|
||||
"tests/threads-foreign.so")
|
||||
("threads.test.sh" "tests/condition-wait-sigcont.lisp")
|
||||
|
|
|
|||
579
tests/threads-2.impure.lisp
Normal file
579
tests/threads-2.impure.lisp
Normal file
|
|
@ -0,0 +1,579 @@
|
|||
;;;; miscellaneous tests of thread stuff
|
||||
|
||||
;;;; This software is part of the SBCL system. See the README file for
|
||||
;;;; more information.
|
||||
;;;;
|
||||
;;;; While most of SBCL is derived from the CMU CL system, the test
|
||||
;;;; files (like this one) were written from scratch after the fork
|
||||
;;;; from CMU CL.
|
||||
;;;
|
||||
;;;; This software is in the public domain and is provided with
|
||||
;;;; absoluely no warranty. See the COPYING and CREDITS files for
|
||||
;;;; more information.
|
||||
|
||||
(shadowing-import 'assertoid:assert-error)
|
||||
(use-package "SB-THREAD")
|
||||
(use-package "SB-SYS")
|
||||
|
||||
(setf sb-unix::*on-dangerous-wait* :error)
|
||||
|
||||
;;; semaphores
|
||||
|
||||
(defmacro raises-timeout-p (&body body)
|
||||
`(handler-case (progn (progn ,@body) nil)
|
||||
(sb-ext:timeout () t)))
|
||||
|
||||
(with-test (:name (semaphore :wait-forever)
|
||||
:skipped-on (:and :sb-safepoint :linux)) ; hangs
|
||||
(let ((sem (make-semaphore :count 0)))
|
||||
(assert (raises-timeout-p
|
||||
(sb-ext:with-timeout 0.1
|
||||
(wait-on-semaphore sem))))))
|
||||
|
||||
(with-test (:name (semaphore :initial-count))
|
||||
(let ((sem (make-semaphore :count 1)))
|
||||
(sb-ext:with-timeout 0.1
|
||||
(assert (= 0 (wait-on-semaphore sem))))))
|
||||
|
||||
(with-test (:name (semaphore :wait-then-signal))
|
||||
(let ((sem (make-semaphore))
|
||||
(signalled-p nil))
|
||||
(make-join-thread (lambda ()
|
||||
(sleep 0.1)
|
||||
(setq signalled-p t)
|
||||
(signal-semaphore sem)))
|
||||
(assert (= 0 (wait-on-semaphore sem)))
|
||||
(assert signalled-p)))
|
||||
|
||||
(with-test (:name (semaphore :signal-then-wait))
|
||||
(let ((sem (make-semaphore))
|
||||
(signalled-p nil))
|
||||
(make-join-thread (lambda ()
|
||||
(signal-semaphore sem)
|
||||
(setq signalled-p t)))
|
||||
(loop until signalled-p)
|
||||
(assert (= 0 (wait-on-semaphore sem)))
|
||||
(assert signalled-p)))
|
||||
|
||||
(defun test-semaphore-multiple-signals (wait-on-semaphore)
|
||||
(let* ((sem (make-semaphore :count 5))
|
||||
(threads (loop repeat 20 collecting
|
||||
(make-join-thread (lambda ()
|
||||
(funcall wait-on-semaphore sem))))))
|
||||
(flet ((count-live-threads ()
|
||||
(count-if #'thread-alive-p threads)))
|
||||
(sleep 0.5)
|
||||
(assert (= 15 (count-live-threads)))
|
||||
(signal-semaphore sem 10)
|
||||
(sleep 0.5)
|
||||
(assert (= 5 (count-live-threads)))
|
||||
(signal-semaphore sem 3)
|
||||
(sleep 0.5)
|
||||
(assert (= 2 (count-live-threads)))
|
||||
(signal-semaphore sem 4)
|
||||
(sleep 0.5)
|
||||
(assert (= 0 (count-live-threads))))))
|
||||
|
||||
(with-test (:name (semaphore :multiple-signals))
|
||||
(test-semaphore-multiple-signals #'wait-on-semaphore))
|
||||
|
||||
(with-test (:name (try-semaphore :trivial-fail))
|
||||
(assert (eq (try-semaphore (make-semaphore :count 0)) 'nil)))
|
||||
|
||||
(with-test (:name (try-semaphore :trivial-success))
|
||||
(let ((sem (make-semaphore :count 1)))
|
||||
(assert (= 0 (try-semaphore sem)))
|
||||
(assert (zerop (semaphore-count sem)))))
|
||||
|
||||
(with-test (:name (try-semaphore :trivial-fail :n>1))
|
||||
(assert (eq (try-semaphore (make-semaphore :count 1) 2) 'nil)))
|
||||
|
||||
(with-test (:name (try-semaphore :trivial-success :n>1))
|
||||
(let ((sem (make-semaphore :count 10)))
|
||||
(assert (= 5 (try-semaphore sem 5)))
|
||||
(assert (= 0 (try-semaphore sem 5)))
|
||||
(assert (zerop (semaphore-count sem)))))
|
||||
|
||||
(with-test (:name (try-semaphore :emulate-wait-on-semaphore))
|
||||
(flet ((busy-wait-on-semaphore (sem)
|
||||
(loop until (try-semaphore sem) do (sleep 0.001))))
|
||||
(test-semaphore-multiple-signals #'busy-wait-on-semaphore)))
|
||||
|
||||
;;; Here we test that interrupting TRY-SEMAPHORE does not leave a
|
||||
;;; semaphore in a bad state.
|
||||
(with-test (:name (try-semaphore :interrupt-safe)
|
||||
:broken-on :win32)
|
||||
(flet ((make-threads (count fn)
|
||||
(loop repeat count collect (make-thread fn)))
|
||||
(kill-thread (thread)
|
||||
(when (thread-alive-p thread)
|
||||
(ignore-errors (terminate-thread thread))))
|
||||
(count-live-threads (threads)
|
||||
(count-if #'thread-alive-p threads)))
|
||||
;; WAITERS will already be waiting on the semaphore while
|
||||
;; threads-being-interrupted will perform TRY-SEMAPHORE on that
|
||||
;; semaphore, and MORE-WAITERS are new threads trying to wait on
|
||||
;; the semaphore during the interruption-fire.
|
||||
(let* ((sem (make-semaphore :count 100))
|
||||
(waiters (make-threads 20 #'(lambda ()
|
||||
(wait-on-semaphore sem))))
|
||||
(triers (make-threads 40 #'(lambda ()
|
||||
(sleep (random 0.01))
|
||||
(try-semaphore sem (1+ (random 5))))))
|
||||
(more-waiters
|
||||
(loop repeat 10
|
||||
do (kill-thread (nth (random 40) triers))
|
||||
collect (make-thread #'(lambda () (wait-on-semaphore sem)))
|
||||
do (kill-thread (nth (random 40) triers)))))
|
||||
(sleep 0.5)
|
||||
;; Now ensure that the waiting threads will all be waked up,
|
||||
;; i.e. that the semaphore is still working.
|
||||
(loop repeat (+ (count-live-threads waiters)
|
||||
(count-live-threads more-waiters))
|
||||
do (signal-semaphore sem))
|
||||
(sleep 0.5)
|
||||
(assert (zerop (count-live-threads triers)))
|
||||
(assert (zerop (count-live-threads waiters)))
|
||||
(assert (zerop (count-live-threads more-waiters))))))
|
||||
|
||||
;; At some point %DECREMENT-SEMAPHORE did not adjust the remaining
|
||||
;; timeout after spurious wakeups, potentially leading to
|
||||
;; longer/infinite waiting despite the specified timeout.
|
||||
(with-test (:name (semaphore :timeout :spurious-wakeup))
|
||||
(let* ((semaphore (make-semaphore))
|
||||
(done nil)
|
||||
(thread (make-thread (lambda ()
|
||||
(let ((mutex (sb-thread::semaphore-mutex semaphore))
|
||||
(queue (sb-thread::semaphore-queue semaphore)))
|
||||
(loop :until done :do
|
||||
(with-mutex (mutex)
|
||||
(condition-notify queue))))))))
|
||||
(assert (eq nil (wait-on-semaphore semaphore :timeout .5)))
|
||||
(setf done t)
|
||||
(join-thread thread)))
|
||||
|
||||
;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
|
||||
;; (d) waiting on a lock, (e) some code which we hope is likely to be
|
||||
;; in pseudo-atomic
|
||||
|
||||
(with-test (:name (interrupt-thread :more-basics)
|
||||
:broken-on :win32)
|
||||
(let ((child (test-interrupt (lambda () (loop)))))
|
||||
(terminate-thread child)))
|
||||
|
||||
;;; For one of the interupt-thread tests, we want a foreign function
|
||||
;;; that does not make syscalls
|
||||
|
||||
#-win32
|
||||
(progn
|
||||
;; When running from a read-only filesystem, and/or under a test scaffold in which
|
||||
;; no C compiler exists, we'll trust that the extra "test data file" was prepared
|
||||
;; already. Moreover we have to assume that it can't get out-of-date with respect
|
||||
;; to this lisp file. i.e. it always contains at least the one C function neccesary.
|
||||
;; (There's logically no "make clean ; make")
|
||||
(unless (probe-file "threads-foreign.so")
|
||||
(with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede)
|
||||
(format o "void loop_forever() { while(1) ; }~%"))
|
||||
(sb-ext:run-program "/bin/sh"
|
||||
'("run-compiler.sh" "-sbcl-pic" "-sbcl-shared"
|
||||
"-o" "threads-foreign.so" "threads-foreign.c"))
|
||||
(delete-file "threads-foreign.c"))
|
||||
(sb-alien:load-shared-object (truename "threads-foreign.so"))
|
||||
(sb-alien:define-alien-routine loop-forever sb-alien:void))
|
||||
|
||||
(with-test (:name (interrupt-thread :interrupt-foreign-loop)
|
||||
;; This feature is explicitly unsupported on Win32.
|
||||
:broken-on :win32)
|
||||
(test-interrupt #'loop-forever :quit))
|
||||
|
||||
(with-test (:name (interrupt-thread :interrupt-sleep)
|
||||
:broken-on :win32)
|
||||
(let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
|
||||
(terminate-thread child)
|
||||
(wait-for-threads (list child))))
|
||||
|
||||
(defvar *runningp* nil)
|
||||
|
||||
(with-test (:name (interrupt-thread :no-nesting) :broken-on :win32)
|
||||
(let ((thread (make-thread (lambda ()
|
||||
(catch 'xxx
|
||||
(loop))))))
|
||||
(declare (special runningp))
|
||||
(sleep 0.2)
|
||||
(interrupt-thread thread (lambda ()
|
||||
(let ((*runningp* t))
|
||||
(sleep 1))))
|
||||
(sleep 0.2)
|
||||
(interrupt-thread thread (lambda ()
|
||||
(throw 'xxx *runningp*)))
|
||||
(assert (not (join-thread thread)))))
|
||||
|
||||
(with-test (:name (interrupt-thread :nesting) :broken-on :win32)
|
||||
(let ((thread (make-thread (lambda ()
|
||||
(catch 'xxx
|
||||
(loop))))))
|
||||
(declare (special runningp))
|
||||
(sleep 0.2)
|
||||
(interrupt-thread thread (lambda ()
|
||||
(let ((*runningp* t))
|
||||
(sb-sys:with-interrupts
|
||||
(sleep 1)))))
|
||||
(sleep 0.2)
|
||||
(interrupt-thread thread (lambda ()
|
||||
(throw 'xxx *runningp*)))
|
||||
(assert (join-thread thread))))
|
||||
|
||||
(with-test (:name :all-threads-have-abort-restart
|
||||
:broken-on :win32)
|
||||
;; This test can fail with without the extra semaphore.
|
||||
;; See also TEST-INTERRUPT in test-util for further explanation.
|
||||
(let* ((sem (make-semaphore))
|
||||
(thread (make-kill-thread
|
||||
(lambda ()
|
||||
(signal-semaphore sem)
|
||||
(sleep 100000000)))))
|
||||
(wait-on-semaphore sem)
|
||||
(interrupt-thread thread (lambda ()
|
||||
(assert (find-restart 'abort))))
|
||||
(process-all-interrupts thread)))
|
||||
|
||||
(sb-ext:gc :full t)
|
||||
|
||||
;; expose thread creation races by exiting quickly
|
||||
(with-test (:name (:no-thread-creation-race :light))
|
||||
(make-join-thread (lambda ())))
|
||||
|
||||
(with-test (:name (:no-thread-creation-race :heavy))
|
||||
(loop repeat 20 do
|
||||
(wait-for-threads
|
||||
(loop for i below 100 collect
|
||||
(make-thread (lambda ()))))))
|
||||
|
||||
;; interrupt handlers are per-thread with pthreads, make sure the
|
||||
;; handler installed in one thread is global
|
||||
(with-test (:name (:global-interrupt-handler))
|
||||
(make-join-thread
|
||||
(lambda ()
|
||||
(sb-ext:run-program "sleep" '("1") :search t :wait nil))))
|
||||
|
||||
;;;; Binding stack safety
|
||||
|
||||
(defparameter *x* nil)
|
||||
(defparameter *n-gcs-requested* 0)
|
||||
(defparameter *n-gcs-done* 0)
|
||||
|
||||
(let ((counter 0))
|
||||
(defun make-something-big ()
|
||||
(let ((x (make-string 32000)))
|
||||
(incf counter)
|
||||
(let ((counter counter))
|
||||
(sb-ext:finalize x (lambda () (format t " ~S" counter)
|
||||
(force-output)))))))
|
||||
|
||||
(defmacro wait-for-gc ()
|
||||
`(progn
|
||||
(incf *n-gcs-requested*)
|
||||
(loop while (< *n-gcs-done* *n-gcs-requested*))))
|
||||
|
||||
(defun send-gc ()
|
||||
(loop until (< *n-gcs-done* *n-gcs-requested*))
|
||||
(format t "G")
|
||||
(force-output)
|
||||
(sb-ext:gc)
|
||||
(incf *n-gcs-done*))
|
||||
|
||||
#+(or x86 x86-64 riscv loongarch64) ;the only platforms with a *binding-stack-pointer* variable
|
||||
(defun exercise-binding ()
|
||||
(loop
|
||||
(let ((*x* (make-something-big)))
|
||||
(let ((*x* 42))
|
||||
;; at this point the binding stack looks like this:
|
||||
;; NO-TLS-VALUE-MARKER, *x*, SOMETHING, *x*
|
||||
t))
|
||||
(wait-for-gc)
|
||||
;; sig_stop_for_gc_handler binds FREE_INTERRUPT_CONTEXT_INDEX. By
|
||||
;; now SOMETHING is gc'ed and the binding stack looks like this: 0,
|
||||
;; 0, SOMETHING, 0 (because the symbol slots are zeroed on
|
||||
;; unbinding but values are not).
|
||||
(let ((*x* nil)
|
||||
(binding-pointer-delta (ash 2 (- sb-vm:word-shift sb-vm:n-fixnum-tag-bits))))
|
||||
;; bump bsp as if a BIND had just started
|
||||
(incf sb-vm::*binding-stack-pointer* binding-pointer-delta)
|
||||
(wait-for-gc)
|
||||
(decf sb-vm::*binding-stack-pointer* binding-pointer-delta))))
|
||||
|
||||
#+(or x86 x86-64 riscv loongarch64) ;the only platforms with a *binding-stack-pointer* variable
|
||||
(with-test (:name (:binding-stack-gc-safety)
|
||||
:broken-on :win32)
|
||||
(let (threads)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(push (make-kill-thread #'exercise-binding) threads)
|
||||
(push (make-kill-thread (lambda ()
|
||||
(loop
|
||||
(sleep 0.1)
|
||||
(send-gc))))
|
||||
threads)
|
||||
(sleep 3))
|
||||
(mapc #'terminate-thread threads))))
|
||||
|
||||
(with-test (:name :test-%thread-local-references)
|
||||
(let ((mysym (gensym))
|
||||
(fool1 (cons 1 2))
|
||||
(fool2 (cons 2 3)))
|
||||
(progv (list mysym) '(nil)
|
||||
(let* ((i (sb-kernel:symbol-tls-index mysym))
|
||||
(j (+ i sb-vm:n-word-bytes)))
|
||||
(assert (eql (sap-ref-word (sb-thread::current-thread-sap) j)
|
||||
sb-vm:no-tls-value-marker))
|
||||
(setf (sap-ref-lispobj (sb-thread::current-thread-sap) i) fool1
|
||||
(sap-ref-lispobj (sb-thread::current-thread-sap) j) fool2)
|
||||
;; assert that my pointer arithmetic worked as expected
|
||||
(assert (eq (symbol-value mysym) fool1))
|
||||
;; assert that FOOL1 is found by the TLS scan and that FOOL2 is not.
|
||||
(let ((list (sb-thread::%thread-local-references)))
|
||||
(assert (not (find sb-vm:no-tls-value-marker list
|
||||
:key #'sb-kernel:get-lisp-obj-address)))
|
||||
(assert (member fool1 list))
|
||||
(assert (not (member fool2 list))))
|
||||
;; repair the TLS entry that was corrupted by the test
|
||||
(setf (sap-ref-word (sb-thread::current-thread-sap) j)
|
||||
sb-vm:no-tls-value-marker)))))
|
||||
|
||||
|
||||
#| ;; a cll post from eric marsden
|
||||
| (defun crash ()
|
||||
| (setq *debugger-hook*
|
||||
| (lambda (condition old-debugger-hook)
|
||||
| (debug:backtrace 10)
|
||||
| (unix:unix-exit 2)))
|
||||
| #+live-dangerously
|
||||
| (mp::start-sigalrm-yield)
|
||||
| (flet ((roomy () (loop (with-output-to-string (*standard-output*) (room)))))
|
||||
| (mp:make-process #'roomy)
|
||||
| (mp:make-process #'roomy)))
|
||||
|#
|
||||
|
||||
;;; Make sure that a deadline handler is not invoked twice in a row in
|
||||
;;; CONDITION-WAIT. See LP #512914 for a detailed explanation.
|
||||
;;;
|
||||
(with-test (:name (condition-wait :deadlines :LP-512914))
|
||||
(let ((n 2) ; was empirically enough to trigger the bug
|
||||
(mutex (make-mutex))
|
||||
(waitq (make-waitqueue))
|
||||
(threads nil)
|
||||
(deadline-handler-run-twice? nil))
|
||||
(dotimes (i n)
|
||||
(let ((child
|
||||
(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)
|
||||
(with-mutex (mutex)
|
||||
(condition-wait waitq mutex))))))))
|
||||
(push child threads)))
|
||||
(mapc #'join-thread threads)
|
||||
(assert (not deadline-handler-run-twice?))))
|
||||
|
||||
;; You have to shoehorn this arbitrary sexpr into a feature expression
|
||||
;; to have the test summary show that a test was disabled.
|
||||
(unless (eql (extern-alien "verify_gens" int)
|
||||
(+ sb-vm:+highest-normal-generation+ 2))
|
||||
(pushnew :verify-gens *features*))
|
||||
|
||||
(with-test (:name :backtrace :broken-on :verify-gens)
|
||||
;; 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
|
||||
;; thread-safe for only doing FIND-SYMBOL, and while printing
|
||||
;; backtraces a loot of symbol lookups need to be done due to
|
||||
;; *PRINT-ESCAPE*.
|
||||
(let* ((threads (loop repeat 10
|
||||
collect (make-thread
|
||||
(lambda ()
|
||||
(dotimes (i 1000)
|
||||
(with-output-to-string (*debug-io*)
|
||||
(sb-debug:print-backtrace :count 10))))))))
|
||||
(wait-for-threads threads)))
|
||||
|
||||
|
||||
|
||||
(defun subtypep-hash-cache-test ()
|
||||
(dotimes (i 10000)
|
||||
(let ((type1 (random-type 500))
|
||||
(type2 (random-type 500)))
|
||||
(let ((a (subtypep type1 type2)))
|
||||
(dotimes (i 100)
|
||||
(assert (eq (subtypep type1 type2) a))))))
|
||||
(write-char #\.)
|
||||
(force-output))
|
||||
|
||||
(with-test (:name (:hash-cache subtypep))
|
||||
(mapc #'join-thread
|
||||
;; this didn't "reliably fail" with a small number of threads.
|
||||
;; 30 is a compromise between running time and confidence in the result.
|
||||
(loop repeat 30
|
||||
collect (make-thread #'subtypep-hash-cache-test)))
|
||||
(terpri))
|
||||
|
||||
;;;; FUNCTIONAL TESTS
|
||||
|
||||
(with-test (:name (:parallel defclass))
|
||||
(write-line "WARNING, WILL HANG ON FAILURE!")
|
||||
(defclass test-1 () ((a :initform :orig-a)))
|
||||
(defclass test-2 () ((b :initform :orig-b)))
|
||||
(defclass test-3 (test-1 test-2) ((c :initform :orig-c)))
|
||||
;; This test is more likely to pass on Windows with the FORCE-OUTPUT
|
||||
;; calls disabled in the folloving code. (As seen on a Server 2012
|
||||
;; installation.) Clearly, this sort of workaround in a test is
|
||||
;; cheating, and might be hiding the underlying bug that the test is
|
||||
;; exposing. Let's review this later.
|
||||
(let* ((run t)
|
||||
(output nil)
|
||||
(d1 (sb-thread:make-thread (lambda ()
|
||||
(loop while run
|
||||
do (defclass test-1 () ((a :initform :new-a)))
|
||||
(when output (write-char #\1))
|
||||
#-win32 (force-output)))
|
||||
:name "d1"))
|
||||
(d2 (sb-thread:make-thread (lambda ()
|
||||
(loop while run
|
||||
do (defclass test-2 () ((b :initform :new-b)))
|
||||
(when output (write-char #\2))
|
||||
#-win32 (force-output)))
|
||||
:name "d2"))
|
||||
(d3 (sb-thread:make-thread (lambda ()
|
||||
(loop while run
|
||||
do (defclass test-3 (test-1 test-2) ((c :initform :new-c)))
|
||||
(when output (write-char #\3))
|
||||
#-win32 (force-output)))
|
||||
:name "d3"))
|
||||
(i (sb-thread:make-thread (lambda ()
|
||||
(loop while run
|
||||
do (let ((i (make-instance 'test-3)))
|
||||
(assert (member (slot-value i 'a) '(:orig-a :new-a)))
|
||||
(assert (member (slot-value i 'b) '(:orig-b :new-b)))
|
||||
(assert (member (slot-value i 'c) '(:orig-c :new-c))))
|
||||
(when output (write-char #\i))
|
||||
#-win32 (force-output)))
|
||||
:name "i")))
|
||||
(format t "~%sleeping!~%")
|
||||
(sleep 2.0)
|
||||
(format t "~%stopping!~%")
|
||||
(setf run nil)
|
||||
(mapc (lambda (th)
|
||||
(sb-thread:join-thread th)
|
||||
(format t "~&joined ~S~%" (sb-thread:thread-name th)))
|
||||
(list d1 d2 d3 i))
|
||||
(force-output)))
|
||||
|
||||
(with-test (:name :spinlock-api)
|
||||
(handler-bind ((warning #'error))
|
||||
(destructuring-bind (with make get release)
|
||||
(assert-signal
|
||||
(list (compile nil `(lambda (lock)
|
||||
(sb-thread::with-spinlock (lock)
|
||||
t)))
|
||||
(compile nil `(lambda ()
|
||||
(sb-thread::make-spinlock :name "foo")))
|
||||
(compile nil `(lambda (lock)
|
||||
(sb-thread::get-spinlock lock)))
|
||||
(compile nil `(lambda (lock)
|
||||
(sb-thread::release-spinlock lock))))
|
||||
early-deprecation-warning 4)
|
||||
(let ((lock (funcall make)))
|
||||
(funcall get lock)
|
||||
(funcall release lock)
|
||||
(assert (eq t (funcall with lock)))))))
|
||||
|
||||
(with-test (:name :interrupt-io-unnamed-pipe
|
||||
:broken-on :win32)
|
||||
(let (result)
|
||||
(labels
|
||||
((reader (fd)
|
||||
(let ((stream (sb-sys:make-fd-stream fd
|
||||
:element-type :default
|
||||
:serve-events nil)))
|
||||
(time
|
||||
(let ((ok (handler-case
|
||||
(catch 'stop
|
||||
(progn
|
||||
(read-char stream)
|
||||
(sleep 0.1)
|
||||
(sleep 0.1)
|
||||
(sleep 0.1)))
|
||||
(error (c)
|
||||
c))))
|
||||
(setf result ok)
|
||||
(progn
|
||||
(format *trace-output* "~&=> ~A~%" ok)
|
||||
(force-output *trace-output*))))
|
||||
(sleep 2)
|
||||
(ignore-errors (close stream))))
|
||||
|
||||
(writer ()
|
||||
(multiple-value-bind (read write)
|
||||
(sb-unix:unix-pipe)
|
||||
(let* ((reader (sb-thread:make-thread (lambda () (reader read))))
|
||||
(stream (sb-sys:make-fd-stream write
|
||||
:output t
|
||||
:element-type :default
|
||||
:serve-events nil))
|
||||
(ok :ok))
|
||||
(sleep 1)
|
||||
(sb-thread:interrupt-thread reader (lambda ()
|
||||
(print :throwing)
|
||||
(force-output)
|
||||
(throw 'stop ok)))
|
||||
(sleep 1)
|
||||
(setf ok :not-ok)
|
||||
(write-char #\x stream)
|
||||
(close stream)
|
||||
(sb-thread:join-thread reader)))))
|
||||
(writer))
|
||||
(assert (eq result :ok))))
|
||||
|
||||
(with-test (:name :thread-alloca)
|
||||
(unless (probe-file "alloca.so")
|
||||
(sb-ext:run-program "sh"
|
||||
'("run-compiler.sh" "-sbcl-pic" "-sbcl-shared"
|
||||
"alloca.c" "-o" "alloca.so")
|
||||
:search t))
|
||||
(load-shared-object (truename "alloca.so"))
|
||||
(alien-funcall (extern-alien "alloca_test" (function void)))
|
||||
(sb-thread:join-thread
|
||||
(sb-thread:make-thread
|
||||
(lambda ()
|
||||
(alien-funcall (extern-alien "alloca_test" (function void)))))))
|
||||
|
||||
(with-test (:name :fp-mode-inheritance-threads)
|
||||
(labels ((fp-mode ()
|
||||
(let ((reserved-bits #+x86 (ash #b1110000011000000 16)
|
||||
#-x86 0))
|
||||
(logandc2 (dpb 0 sb-vm:float-sticky-bits (sb-vm:floating-point-modes))
|
||||
reserved-bits)))
|
||||
(test ()
|
||||
(let* ((fp-mode (fp-mode))
|
||||
(thread-fp-mode
|
||||
(sb-thread:join-thread
|
||||
(sb-thread:make-thread
|
||||
(lambda ()
|
||||
(fp-mode))))))
|
||||
(assert (= fp-mode thread-fp-mode)))))
|
||||
(test)
|
||||
(sb-int:with-float-traps-masked (:divide-by-zero)
|
||||
(test))
|
||||
(setf (sb-vm:floating-point-modes)
|
||||
(dpb sb-vm:float-divide-by-zero-trap-bit
|
||||
sb-vm:float-traps-byte
|
||||
(sb-vm:floating-point-modes)))
|
||||
(test)))
|
||||
|
|
@ -191,26 +191,6 @@
|
|||
(with-test (:name (join-thread :self-join))
|
||||
(assert-error (join-thread *current-thread*) join-thread-error))
|
||||
|
||||
;;; For one of the interupt-thread tests, we want a foreign function
|
||||
;;; that does not make syscalls
|
||||
|
||||
#-win32
|
||||
(progn
|
||||
;; When running from a read-only filesystem, and/or under a test scaffold in which
|
||||
;; no C compiler exists, we'll trust that the extra "test data file" was prepared
|
||||
;; already. Moreover we have to assume that it can't get out-of-date with respect
|
||||
;; to this lisp file. i.e. it always contains at least the one C function neccesary.
|
||||
;; (There's logically no "make clean ; make")
|
||||
(unless (probe-file "threads-foreign.so")
|
||||
(with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede)
|
||||
(format o "void loop_forever() { while(1) ; }~%"))
|
||||
(sb-ext:run-program "/bin/sh"
|
||||
'("run-compiler.sh" "-sbcl-pic" "-sbcl-shared"
|
||||
"-o" "threads-foreign.so" "threads-foreign.c"))
|
||||
(delete-file "threads-foreign.c"))
|
||||
(sb-alien:load-shared-object (truename "threads-foreign.so"))
|
||||
(sb-alien:define-alien-routine loop-forever sb-alien:void))
|
||||
|
||||
;;; elementary "can we get a lock and release it again"
|
||||
(with-test (:name (:mutex :basics))
|
||||
(let ((l (make-mutex :name "foo"))
|
||||
|
|
@ -391,543 +371,3 @@
|
|||
:deadline))))))
|
||||
'nil)))))
|
||||
|
||||
;;; semaphores
|
||||
|
||||
(defmacro raises-timeout-p (&body body)
|
||||
`(handler-case (progn (progn ,@body) nil)
|
||||
(sb-ext:timeout () t)))
|
||||
|
||||
(with-test (:name (semaphore :wait-forever)
|
||||
:skipped-on (:and :sb-safepoint :linux)) ; hangs
|
||||
(let ((sem (make-semaphore :count 0)))
|
||||
(assert (raises-timeout-p
|
||||
(sb-ext:with-timeout 0.1
|
||||
(wait-on-semaphore sem))))))
|
||||
|
||||
(with-test (:name (semaphore :initial-count))
|
||||
(let ((sem (make-semaphore :count 1)))
|
||||
(sb-ext:with-timeout 0.1
|
||||
(assert (= 0 (wait-on-semaphore sem))))))
|
||||
|
||||
(with-test (:name (semaphore :wait-then-signal))
|
||||
(let ((sem (make-semaphore))
|
||||
(signalled-p nil))
|
||||
(make-join-thread (lambda ()
|
||||
(sleep 0.1)
|
||||
(setq signalled-p t)
|
||||
(signal-semaphore sem)))
|
||||
(assert (= 0 (wait-on-semaphore sem)))
|
||||
(assert signalled-p)))
|
||||
|
||||
(with-test (:name (semaphore :signal-then-wait))
|
||||
(let ((sem (make-semaphore))
|
||||
(signalled-p nil))
|
||||
(make-join-thread (lambda ()
|
||||
(signal-semaphore sem)
|
||||
(setq signalled-p t)))
|
||||
(loop until signalled-p)
|
||||
(assert (= 0 (wait-on-semaphore sem)))
|
||||
(assert signalled-p)))
|
||||
|
||||
(defun test-semaphore-multiple-signals (wait-on-semaphore)
|
||||
(let* ((sem (make-semaphore :count 5))
|
||||
(threads (loop repeat 20 collecting
|
||||
(make-join-thread (lambda ()
|
||||
(funcall wait-on-semaphore sem))))))
|
||||
(flet ((count-live-threads ()
|
||||
(count-if #'thread-alive-p threads)))
|
||||
(sleep 0.5)
|
||||
(assert (= 15 (count-live-threads)))
|
||||
(signal-semaphore sem 10)
|
||||
(sleep 0.5)
|
||||
(assert (= 5 (count-live-threads)))
|
||||
(signal-semaphore sem 3)
|
||||
(sleep 0.5)
|
||||
(assert (= 2 (count-live-threads)))
|
||||
(signal-semaphore sem 4)
|
||||
(sleep 0.5)
|
||||
(assert (= 0 (count-live-threads))))))
|
||||
|
||||
(with-test (:name (semaphore :multiple-signals))
|
||||
(test-semaphore-multiple-signals #'wait-on-semaphore))
|
||||
|
||||
(with-test (:name (try-semaphore :trivial-fail))
|
||||
(assert (eq (try-semaphore (make-semaphore :count 0)) 'nil)))
|
||||
|
||||
(with-test (:name (try-semaphore :trivial-success))
|
||||
(let ((sem (make-semaphore :count 1)))
|
||||
(assert (= 0 (try-semaphore sem)))
|
||||
(assert (zerop (semaphore-count sem)))))
|
||||
|
||||
(with-test (:name (try-semaphore :trivial-fail :n>1))
|
||||
(assert (eq (try-semaphore (make-semaphore :count 1) 2) 'nil)))
|
||||
|
||||
(with-test (:name (try-semaphore :trivial-success :n>1))
|
||||
(let ((sem (make-semaphore :count 10)))
|
||||
(assert (= 5 (try-semaphore sem 5)))
|
||||
(assert (= 0 (try-semaphore sem 5)))
|
||||
(assert (zerop (semaphore-count sem)))))
|
||||
|
||||
(with-test (:name (try-semaphore :emulate-wait-on-semaphore))
|
||||
(flet ((busy-wait-on-semaphore (sem)
|
||||
(loop until (try-semaphore sem) do (sleep 0.001))))
|
||||
(test-semaphore-multiple-signals #'busy-wait-on-semaphore)))
|
||||
|
||||
;;; Here we test that interrupting TRY-SEMAPHORE does not leave a
|
||||
;;; semaphore in a bad state.
|
||||
(with-test (:name (try-semaphore :interrupt-safe)
|
||||
:broken-on :win32)
|
||||
(flet ((make-threads (count fn)
|
||||
(loop repeat count collect (make-thread fn)))
|
||||
(kill-thread (thread)
|
||||
(when (thread-alive-p thread)
|
||||
(ignore-errors (terminate-thread thread))))
|
||||
(count-live-threads (threads)
|
||||
(count-if #'thread-alive-p threads)))
|
||||
;; WAITERS will already be waiting on the semaphore while
|
||||
;; threads-being-interrupted will perform TRY-SEMAPHORE on that
|
||||
;; semaphore, and MORE-WAITERS are new threads trying to wait on
|
||||
;; the semaphore during the interruption-fire.
|
||||
(let* ((sem (make-semaphore :count 100))
|
||||
(waiters (make-threads 20 #'(lambda ()
|
||||
(wait-on-semaphore sem))))
|
||||
(triers (make-threads 40 #'(lambda ()
|
||||
(sleep (random 0.01))
|
||||
(try-semaphore sem (1+ (random 5))))))
|
||||
(more-waiters
|
||||
(loop repeat 10
|
||||
do (kill-thread (nth (random 40) triers))
|
||||
collect (make-thread #'(lambda () (wait-on-semaphore sem)))
|
||||
do (kill-thread (nth (random 40) triers)))))
|
||||
(sleep 0.5)
|
||||
;; Now ensure that the waiting threads will all be waked up,
|
||||
;; i.e. that the semaphore is still working.
|
||||
(loop repeat (+ (count-live-threads waiters)
|
||||
(count-live-threads more-waiters))
|
||||
do (signal-semaphore sem))
|
||||
(sleep 0.5)
|
||||
(assert (zerop (count-live-threads triers)))
|
||||
(assert (zerop (count-live-threads waiters)))
|
||||
(assert (zerop (count-live-threads more-waiters))))))
|
||||
|
||||
;; At some point %DECREMENT-SEMAPHORE did not adjust the remaining
|
||||
;; timeout after spurious wakeups, potentially leading to
|
||||
;; longer/infinite waiting despite the specified timeout.
|
||||
(with-test (:name (semaphore :timeout :spurious-wakeup))
|
||||
(let* ((semaphore (make-semaphore))
|
||||
(done nil)
|
||||
(thread (make-thread (lambda ()
|
||||
(let ((mutex (sb-thread::semaphore-mutex semaphore))
|
||||
(queue (sb-thread::semaphore-queue semaphore)))
|
||||
(loop :until done :do
|
||||
(with-mutex (mutex)
|
||||
(condition-notify queue))))))))
|
||||
(assert (eq nil (wait-on-semaphore semaphore :timeout .5)))
|
||||
(setf done t)
|
||||
(join-thread thread)))
|
||||
|
||||
;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
|
||||
;; (d) waiting on a lock, (e) some code which we hope is likely to be
|
||||
;; in pseudo-atomic
|
||||
|
||||
(with-test (:name (interrupt-thread :more-basics)
|
||||
:broken-on :win32)
|
||||
(let ((child (test-interrupt (lambda () (loop)))))
|
||||
(terminate-thread child)))
|
||||
|
||||
(with-test (:name (interrupt-thread :interrupt-foreign-loop)
|
||||
;; This feature is explicitly unsupported on Win32.
|
||||
:broken-on :win32)
|
||||
(test-interrupt #'loop-forever :quit))
|
||||
|
||||
(with-test (:name (interrupt-thread :interrupt-sleep)
|
||||
:broken-on :win32)
|
||||
(let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
|
||||
(terminate-thread child)
|
||||
(wait-for-threads (list child))))
|
||||
|
||||
(defvar *runningp* nil)
|
||||
|
||||
(with-test (:name (interrupt-thread :no-nesting) :broken-on :win32)
|
||||
(let ((thread (make-thread (lambda ()
|
||||
(catch 'xxx
|
||||
(loop))))))
|
||||
(declare (special runningp))
|
||||
(sleep 0.2)
|
||||
(interrupt-thread thread (lambda ()
|
||||
(let ((*runningp* t))
|
||||
(sleep 1))))
|
||||
(sleep 0.2)
|
||||
(interrupt-thread thread (lambda ()
|
||||
(throw 'xxx *runningp*)))
|
||||
(assert (not (join-thread thread)))))
|
||||
|
||||
(with-test (:name (interrupt-thread :nesting) :broken-on :win32)
|
||||
(let ((thread (make-thread (lambda ()
|
||||
(catch 'xxx
|
||||
(loop))))))
|
||||
(declare (special runningp))
|
||||
(sleep 0.2)
|
||||
(interrupt-thread thread (lambda ()
|
||||
(let ((*runningp* t))
|
||||
(sb-sys:with-interrupts
|
||||
(sleep 1)))))
|
||||
(sleep 0.2)
|
||||
(interrupt-thread thread (lambda ()
|
||||
(throw 'xxx *runningp*)))
|
||||
(assert (join-thread thread))))
|
||||
|
||||
(with-test (:name :all-threads-have-abort-restart
|
||||
:broken-on :win32)
|
||||
;; This test can fail with without the extra semaphore.
|
||||
;; See also TEST-INTERRUPT in test-util for further explanation.
|
||||
(let* ((sem (make-semaphore))
|
||||
(thread (make-kill-thread
|
||||
(lambda ()
|
||||
(signal-semaphore sem)
|
||||
(sleep 100000000)))))
|
||||
(wait-on-semaphore sem)
|
||||
(interrupt-thread thread (lambda ()
|
||||
(assert (find-restart 'abort))))
|
||||
(process-all-interrupts thread)))
|
||||
|
||||
(sb-ext:gc :full t)
|
||||
|
||||
;; expose thread creation races by exiting quickly
|
||||
(with-test (:name (:no-thread-creation-race :light))
|
||||
(make-join-thread (lambda ())))
|
||||
|
||||
(with-test (:name (:no-thread-creation-race :heavy))
|
||||
(loop repeat 20 do
|
||||
(wait-for-threads
|
||||
(loop for i below 100 collect
|
||||
(make-thread (lambda ()))))))
|
||||
|
||||
;; interrupt handlers are per-thread with pthreads, make sure the
|
||||
;; handler installed in one thread is global
|
||||
(with-test (:name (:global-interrupt-handler))
|
||||
(make-join-thread
|
||||
(lambda ()
|
||||
(sb-ext:run-program "sleep" '("1") :search t :wait nil))))
|
||||
|
||||
;;;; Binding stack safety
|
||||
|
||||
(defparameter *x* nil)
|
||||
(defparameter *n-gcs-requested* 0)
|
||||
(defparameter *n-gcs-done* 0)
|
||||
|
||||
(let ((counter 0))
|
||||
(defun make-something-big ()
|
||||
(let ((x (make-string 32000)))
|
||||
(incf counter)
|
||||
(let ((counter counter))
|
||||
(sb-ext:finalize x (lambda () (format t " ~S" counter)
|
||||
(force-output)))))))
|
||||
|
||||
(defmacro wait-for-gc ()
|
||||
`(progn
|
||||
(incf *n-gcs-requested*)
|
||||
(loop while (< *n-gcs-done* *n-gcs-requested*))))
|
||||
|
||||
(defun send-gc ()
|
||||
(loop until (< *n-gcs-done* *n-gcs-requested*))
|
||||
(format t "G")
|
||||
(force-output)
|
||||
(sb-ext:gc)
|
||||
(incf *n-gcs-done*))
|
||||
|
||||
#+(or x86 x86-64 riscv loongarch64) ;the only platforms with a *binding-stack-pointer* variable
|
||||
(defun exercise-binding ()
|
||||
(loop
|
||||
(let ((*x* (make-something-big)))
|
||||
(let ((*x* 42))
|
||||
;; at this point the binding stack looks like this:
|
||||
;; NO-TLS-VALUE-MARKER, *x*, SOMETHING, *x*
|
||||
t))
|
||||
(wait-for-gc)
|
||||
;; sig_stop_for_gc_handler binds FREE_INTERRUPT_CONTEXT_INDEX. By
|
||||
;; now SOMETHING is gc'ed and the binding stack looks like this: 0,
|
||||
;; 0, SOMETHING, 0 (because the symbol slots are zeroed on
|
||||
;; unbinding but values are not).
|
||||
(let ((*x* nil)
|
||||
(binding-pointer-delta (ash 2 (- sb-vm:word-shift sb-vm:n-fixnum-tag-bits))))
|
||||
;; bump bsp as if a BIND had just started
|
||||
(incf sb-vm::*binding-stack-pointer* binding-pointer-delta)
|
||||
(wait-for-gc)
|
||||
(decf sb-vm::*binding-stack-pointer* binding-pointer-delta))))
|
||||
|
||||
#+(or x86 x86-64 riscv loongarch64) ;the only platforms with a *binding-stack-pointer* variable
|
||||
(with-test (:name (:binding-stack-gc-safety)
|
||||
:broken-on :win32)
|
||||
(let (threads)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(push (make-kill-thread #'exercise-binding) threads)
|
||||
(push (make-kill-thread (lambda ()
|
||||
(loop
|
||||
(sleep 0.1)
|
||||
(send-gc))))
|
||||
threads)
|
||||
(sleep 3))
|
||||
(mapc #'terminate-thread threads))))
|
||||
|
||||
(with-test (:name :test-%thread-local-references)
|
||||
(let ((mysym (gensym))
|
||||
(fool1 (cons 1 2))
|
||||
(fool2 (cons 2 3)))
|
||||
(progv (list mysym) '(nil)
|
||||
(let* ((i (sb-kernel:symbol-tls-index mysym))
|
||||
(j (+ i sb-vm:n-word-bytes)))
|
||||
(assert (eql (sap-ref-word (sb-thread::current-thread-sap) j)
|
||||
sb-vm:no-tls-value-marker))
|
||||
(setf (sap-ref-lispobj (sb-thread::current-thread-sap) i) fool1
|
||||
(sap-ref-lispobj (sb-thread::current-thread-sap) j) fool2)
|
||||
;; assert that my pointer arithmetic worked as expected
|
||||
(assert (eq (symbol-value mysym) fool1))
|
||||
;; assert that FOOL1 is found by the TLS scan and that FOOL2 is not.
|
||||
(let ((list (sb-thread::%thread-local-references)))
|
||||
(assert (not (find sb-vm:no-tls-value-marker list
|
||||
:key #'sb-kernel:get-lisp-obj-address)))
|
||||
(assert (member fool1 list))
|
||||
(assert (not (member fool2 list))))
|
||||
;; repair the TLS entry that was corrupted by the test
|
||||
(setf (sap-ref-word (sb-thread::current-thread-sap) j)
|
||||
sb-vm:no-tls-value-marker)))))
|
||||
|
||||
|
||||
#| ;; a cll post from eric marsden
|
||||
| (defun crash ()
|
||||
| (setq *debugger-hook*
|
||||
| (lambda (condition old-debugger-hook)
|
||||
| (debug:backtrace 10)
|
||||
| (unix:unix-exit 2)))
|
||||
| #+live-dangerously
|
||||
| (mp::start-sigalrm-yield)
|
||||
| (flet ((roomy () (loop (with-output-to-string (*standard-output*) (room)))))
|
||||
| (mp:make-process #'roomy)
|
||||
| (mp:make-process #'roomy)))
|
||||
|#
|
||||
|
||||
;;; Make sure that a deadline handler is not invoked twice in a row in
|
||||
;;; CONDITION-WAIT. See LP #512914 for a detailed explanation.
|
||||
;;;
|
||||
(with-test (:name (condition-wait :deadlines :LP-512914))
|
||||
(let ((n 2) ; was empirically enough to trigger the bug
|
||||
(mutex (make-mutex))
|
||||
(waitq (make-waitqueue))
|
||||
(threads nil)
|
||||
(deadline-handler-run-twice? nil))
|
||||
(dotimes (i n)
|
||||
(let ((child
|
||||
(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)
|
||||
(with-mutex (mutex)
|
||||
(condition-wait waitq mutex))))))))
|
||||
(push child threads)))
|
||||
(mapc #'join-thread threads)
|
||||
(assert (not deadline-handler-run-twice?))))
|
||||
|
||||
;; You have to shoehorn this arbitrary sexpr into a feature expression
|
||||
;; to have the test summary show that a test was disabled.
|
||||
(unless (eql (extern-alien "verify_gens" int)
|
||||
(+ sb-vm:+highest-normal-generation+ 2))
|
||||
(pushnew :verify-gens *features*))
|
||||
|
||||
(with-test (:name :backtrace :broken-on :verify-gens)
|
||||
;; 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
|
||||
;; thread-safe for only doing FIND-SYMBOL, and while printing
|
||||
;; backtraces a loot of symbol lookups need to be done due to
|
||||
;; *PRINT-ESCAPE*.
|
||||
(let* ((threads (loop repeat 10
|
||||
collect (make-thread
|
||||
(lambda ()
|
||||
(dotimes (i 1000)
|
||||
(with-output-to-string (*debug-io*)
|
||||
(sb-debug:print-backtrace :count 10))))))))
|
||||
(wait-for-threads threads)))
|
||||
|
||||
|
||||
|
||||
(defun subtypep-hash-cache-test ()
|
||||
(dotimes (i 10000)
|
||||
(let ((type1 (random-type 500))
|
||||
(type2 (random-type 500)))
|
||||
(let ((a (subtypep type1 type2)))
|
||||
(dotimes (i 100)
|
||||
(assert (eq (subtypep type1 type2) a))))))
|
||||
(write-char #\.)
|
||||
(force-output))
|
||||
|
||||
(with-test (:name (:hash-cache subtypep))
|
||||
(mapc #'join-thread
|
||||
;; this didn't "reliably fail" with a small number of threads.
|
||||
;; 30 is a compromise between running time and confidence in the result.
|
||||
(loop repeat 30
|
||||
collect (make-thread #'subtypep-hash-cache-test)))
|
||||
(terpri))
|
||||
|
||||
;;;; FUNCTIONAL TESTS
|
||||
|
||||
(with-test (:name (:parallel defclass))
|
||||
(write-line "WARNING, WILL HANG ON FAILURE!")
|
||||
(defclass test-1 () ((a :initform :orig-a)))
|
||||
(defclass test-2 () ((b :initform :orig-b)))
|
||||
(defclass test-3 (test-1 test-2) ((c :initform :orig-c)))
|
||||
;; This test is more likely to pass on Windows with the FORCE-OUTPUT
|
||||
;; calls disabled in the folloving code. (As seen on a Server 2012
|
||||
;; installation.) Clearly, this sort of workaround in a test is
|
||||
;; cheating, and might be hiding the underlying bug that the test is
|
||||
;; exposing. Let's review this later.
|
||||
(let* ((run t)
|
||||
(output nil)
|
||||
(d1 (sb-thread:make-thread (lambda ()
|
||||
(loop while run
|
||||
do (defclass test-1 () ((a :initform :new-a)))
|
||||
(when output (write-char #\1))
|
||||
#-win32 (force-output)))
|
||||
:name "d1"))
|
||||
(d2 (sb-thread:make-thread (lambda ()
|
||||
(loop while run
|
||||
do (defclass test-2 () ((b :initform :new-b)))
|
||||
(when output (write-char #\2))
|
||||
#-win32 (force-output)))
|
||||
:name "d2"))
|
||||
(d3 (sb-thread:make-thread (lambda ()
|
||||
(loop while run
|
||||
do (defclass test-3 (test-1 test-2) ((c :initform :new-c)))
|
||||
(when output (write-char #\3))
|
||||
#-win32 (force-output)))
|
||||
:name "d3"))
|
||||
(i (sb-thread:make-thread (lambda ()
|
||||
(loop while run
|
||||
do (let ((i (make-instance 'test-3)))
|
||||
(assert (member (slot-value i 'a) '(:orig-a :new-a)))
|
||||
(assert (member (slot-value i 'b) '(:orig-b :new-b)))
|
||||
(assert (member (slot-value i 'c) '(:orig-c :new-c))))
|
||||
(when output (write-char #\i))
|
||||
#-win32 (force-output)))
|
||||
:name "i")))
|
||||
(format t "~%sleeping!~%")
|
||||
(sleep 2.0)
|
||||
(format t "~%stopping!~%")
|
||||
(setf run nil)
|
||||
(mapc (lambda (th)
|
||||
(sb-thread:join-thread th)
|
||||
(format t "~&joined ~S~%" (sb-thread:thread-name th)))
|
||||
(list d1 d2 d3 i))
|
||||
(force-output)))
|
||||
|
||||
(with-test (:name :spinlock-api)
|
||||
(handler-bind ((warning #'error))
|
||||
(destructuring-bind (with make get release)
|
||||
(assert-signal
|
||||
(list (compile nil `(lambda (lock)
|
||||
(sb-thread::with-spinlock (lock)
|
||||
t)))
|
||||
(compile nil `(lambda ()
|
||||
(sb-thread::make-spinlock :name "foo")))
|
||||
(compile nil `(lambda (lock)
|
||||
(sb-thread::get-spinlock lock)))
|
||||
(compile nil `(lambda (lock)
|
||||
(sb-thread::release-spinlock lock))))
|
||||
early-deprecation-warning 4)
|
||||
(let ((lock (funcall make)))
|
||||
(funcall get lock)
|
||||
(funcall release lock)
|
||||
(assert (eq t (funcall with lock)))))))
|
||||
|
||||
(with-test (:name :interrupt-io-unnamed-pipe
|
||||
:broken-on :win32)
|
||||
(let (result)
|
||||
(labels
|
||||
((reader (fd)
|
||||
(let ((stream (sb-sys:make-fd-stream fd
|
||||
:element-type :default
|
||||
:serve-events nil)))
|
||||
(time
|
||||
(let ((ok (handler-case
|
||||
(catch 'stop
|
||||
(progn
|
||||
(read-char stream)
|
||||
(sleep 0.1)
|
||||
(sleep 0.1)
|
||||
(sleep 0.1)))
|
||||
(error (c)
|
||||
c))))
|
||||
(setf result ok)
|
||||
(progn
|
||||
(format *trace-output* "~&=> ~A~%" ok)
|
||||
(force-output *trace-output*))))
|
||||
(sleep 2)
|
||||
(ignore-errors (close stream))))
|
||||
|
||||
(writer ()
|
||||
(multiple-value-bind (read write)
|
||||
(sb-unix:unix-pipe)
|
||||
(let* ((reader (sb-thread:make-thread (lambda () (reader read))))
|
||||
(stream (sb-sys:make-fd-stream write
|
||||
:output t
|
||||
:element-type :default
|
||||
:serve-events nil))
|
||||
(ok :ok))
|
||||
(sleep 1)
|
||||
(sb-thread:interrupt-thread reader (lambda ()
|
||||
(print :throwing)
|
||||
(force-output)
|
||||
(throw 'stop ok)))
|
||||
(sleep 1)
|
||||
(setf ok :not-ok)
|
||||
(write-char #\x stream)
|
||||
(close stream)
|
||||
(sb-thread:join-thread reader)))))
|
||||
(writer))
|
||||
(assert (eq result :ok))))
|
||||
|
||||
(with-test (:name :thread-alloca)
|
||||
(unless (probe-file "alloca.so")
|
||||
(sb-ext:run-program "sh"
|
||||
'("run-compiler.sh" "-sbcl-pic" "-sbcl-shared"
|
||||
"alloca.c" "-o" "alloca.so")
|
||||
:search t))
|
||||
(load-shared-object (truename "alloca.so"))
|
||||
(alien-funcall (extern-alien "alloca_test" (function void)))
|
||||
(sb-thread:join-thread
|
||||
(sb-thread:make-thread
|
||||
(lambda ()
|
||||
(alien-funcall (extern-alien "alloca_test" (function void)))))))
|
||||
|
||||
(with-test (:name :fp-mode-inheritance-threads)
|
||||
(labels ((fp-mode ()
|
||||
(let ((reserved-bits #+x86 (ash #b1110000011000000 16)
|
||||
#-x86 0))
|
||||
(logandc2 (dpb 0 sb-vm:float-sticky-bits (sb-vm:floating-point-modes))
|
||||
reserved-bits)))
|
||||
(test ()
|
||||
(let* ((fp-mode (fp-mode))
|
||||
(thread-fp-mode
|
||||
(sb-thread:join-thread
|
||||
(sb-thread:make-thread
|
||||
(lambda ()
|
||||
(fp-mode))))))
|
||||
(assert (= fp-mode thread-fp-mode)))))
|
||||
(test)
|
||||
(sb-int:with-float-traps-masked (:divide-by-zero)
|
||||
(test))
|
||||
(setf (sb-vm:floating-point-modes)
|
||||
(dpb sb-vm:float-divide-by-zero-trap-bit
|
||||
sb-vm:float-traps-byte
|
||||
(sb-vm:floating-point-modes)))
|
||||
(test)))
|
||||
|
|
|
|||
11
tests/timing
11
tests/timing
|
|
@ -4,7 +4,7 @@
|
|||
("alloc-histo.impure" 509)
|
||||
("aprof.impure" 553)
|
||||
("arenaheapwaste.impure" 1400)
|
||||
("arith-2.pure" 408)
|
||||
("arith-2.pure" 6408)
|
||||
("alien.impure" 1174)
|
||||
("assembler.pure" 237)
|
||||
("autoclose-stream.impure" 163)
|
||||
|
|
@ -96,7 +96,7 @@
|
|||
("defstruct.impure" 1605)
|
||||
("fast-eval.impure" 86)
|
||||
("arith-combinations.pure" 13955)
|
||||
("dynamic-extent.pure" 1575)
|
||||
("dynamic-extent.pure" 2575)
|
||||
("filecompile.impure-cload" 86)
|
||||
("filecompile.impure" 145)
|
||||
("external-format.pure" 871)
|
||||
|
|
@ -181,7 +181,8 @@
|
|||
("mop-20.impure-cload" 147)
|
||||
("mop-21.impure-cload" 130)
|
||||
("mop-22.impure-cload" 137)
|
||||
("threads.impure" 24573)
|
||||
("threads.impure" 14573)
|
||||
("threads-2.impure" 14573)
|
||||
("mop-23.impure" 144)
|
||||
("mop-25.impure" 110)
|
||||
("mop-26.impure" 115)
|
||||
|
|
@ -203,7 +204,7 @@
|
|||
("lzcore.test" 2495)
|
||||
("mop.impure-cload" 135)
|
||||
("load.impure" 3994)
|
||||
("gethash-concurrency.pure" 25213)
|
||||
("gethash-concurrency.pure" 15213)
|
||||
("mop.pure" 213)
|
||||
("octets.pure" 184)
|
||||
("mop.impure" 351)
|
||||
|
|
@ -274,7 +275,7 @@
|
|||
("smoke.impure" 986)
|
||||
("stream.impure-cload" 124)
|
||||
("seq.pure" 1859)
|
||||
("stream.test" 98)
|
||||
("stream.test" 1198)
|
||||
("stream.pure" 210)
|
||||
("style-warnings.impure" 99)
|
||||
("string.pure" 191)
|
||||
|
|
|
|||
Loading…
Reference in a new issue