diff --git a/tests/input-manifest.lisp-expr b/tests/input-manifest.lisp-expr index 9babb3ec0..665aebf8e 100644 --- a/tests/input-manifest.lisp-expr +++ b/tests/input-manifest.lisp-expr @@ -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") diff --git a/tests/threads-2.impure.lisp b/tests/threads-2.impure.lisp new file mode 100644 index 000000000..115ac0c58 --- /dev/null +++ b/tests/threads-2.impure.lisp @@ -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))) diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 0d390906c..b223222ec 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -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))) diff --git a/tests/timing b/tests/timing index 99d354c76..8703981d3 100644 --- a/tests/timing +++ b/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)