X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=2d72ec1f895e4bbbdb9c8dbc630f2ed28fb4897e;hb=c70733ce291ef0f5b0f2dc19f085dfdeb1896b81;hp=5aa51926051c96a92f2e18eacb56a88571d0ec02;hpb=a98bbf0cf10b8136707995a00a1c7240c05d02a9;p=sbcl.git diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 5aa5192..2d72ec1 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -13,6 +13,8 @@ (in-package "SB-THREAD") ; this is white-box testing, really +(use-package :test-util) + (defun wait-for-threads (threads) (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01))) @@ -97,8 +99,7 @@ (assert (eql (mutex-value l) nil) nil "5")) (labels ((ours-p (value) - (sb-vm:control-stack-pointer-valid-p - (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value))))) + (eq *current-thread* value))) (let ((l (make-mutex :name "rec"))) (assert (eql (mutex-value l) nil) nil "1") (sb-thread:with-recursive-lock (l) @@ -108,11 +109,15 @@ (assert (ours-p (mutex-value l)) nil "5")) (assert (eql (mutex-value l) nil) nil "6"))) -(let ((l (make-spinlock :name "spinlock")) - (p *current-thread*)) +(with-test (:name (:mutex :nesting-mutex-and-recursive-lock)) + (let ((l (make-mutex :name "a mutex"))) + (with-mutex (l) + (with-recursive-lock (l))))) + +(let ((l (make-spinlock :name "spinlock"))) (assert (eql (spinlock-value l) 0) nil "1") (with-spinlock (l) - (assert (eql (spinlock-value l) p) nil "2")) + (assert (eql (spinlock-value l) 1) nil "2")) (assert (eql (spinlock-value l) 0) nil "3")) ;; test that SLEEP actually sleeps for at least the given time, even @@ -149,8 +154,7 @@ (let ((queue (make-waitqueue :name "queue")) (lock (make-mutex :name "lock"))) (labels ((ours-p (value) - (sb-vm:control-stack-pointer-valid-p - (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value)))) + (eq *current-thread* value)) (in-new-thread () (with-recursive-lock (lock) (assert (ours-p (mutex-value lock))) @@ -174,7 +178,7 @@ (let ((me *current-thread*)) (dotimes (i 100) (with-mutex (mutex) - (sleep .1) + (sleep .03) (assert (eql (mutex-value mutex) me))) (assert (not (eql (mutex-value mutex) me)))) (format t "done ~A~%" *current-thread*)))) @@ -183,6 +187,64 @@ (format t "contention ~A ~A~%" kid1 kid2) (wait-for-threads (list kid1 kid2))))) +;;; semaphores + +(defmacro raises-timeout-p (&body body) + `(handler-case (progn (progn ,@body) nil) + (sb-ext:timeout () t))) + +(with-test (:name (:semaphore :wait-forever)) + (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 + (wait-on-semaphore sem)))) + +(with-test (:name (:semaphore :wait-then-signal)) + (let ((sem (make-semaphore)) + (signalled-p nil)) + (make-thread (lambda () + (sleep 0.1) + (setq signalled-p t) + (signal-semaphore sem))) + (wait-on-semaphore sem) + (assert signalled-p))) + +(with-test (:name (:semaphore :signal-then-wait)) + (let ((sem (make-semaphore)) + (signalled-p nil)) + (make-thread (lambda () + (signal-semaphore sem) + (setq signalled-p t))) + (loop until signalled-p) + (wait-on-semaphore sem) + (assert signalled-p))) + +(with-test (:name (:semaphore :multiple-signals)) + (let* ((sem (make-semaphore :count 5)) + (threads (loop repeat 20 + collect (make-thread (lambda () + (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)))))) + +(format t "~&semaphore tests done~%") + (defun test-interrupt (function-to-interrupt &optional quit-p) (let ((child (make-thread function-to-interrupt))) ;;(format t "gdb ./src/runtime/sbcl ~A~%attach ~A~%" child child) @@ -253,7 +315,7 @@ (interrupt-thread c (lambda () (princ ".") (force-output) - (assert (eq (thread-state *current-thread*) :running)) + (assert (thread-alive-p *current-thread*)) (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*))))) (terminate-thread c) (wait-for-threads (list c))) @@ -400,23 +462,103 @@ (format t "~&session lock test done~%") -(sb-ext:gc :full t) (loop repeat 20 do (wait-for-threads (loop for i below 100 collect - (sb-thread:make-thread (lambda ())))) - (sb-ext:gc :full t) - (princ "+") - (force-output)) + (sb-thread:make-thread (lambda ()))))) (format t "~&creation test done~%") -;; watch out for *current-thread* being the parent thread after exit -(let ((thread (sb-thread:make-thread (lambda ())))) - (wait-for-threads (list thread)) - (assert (null (symbol-value-in-thread 'sb-thread:*current-thread* - thread)))) - +;; interrupt handlers are per-thread with pthreads, make sure the +;; handler installed in one thread is global +(sb-thread:make-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*)) + +(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)) + ;; bump bsp as if a BIND had just started + (incf sb-vm::*binding-stack-pointer* 2) + (wait-for-gc) + (decf sb-vm::*binding-stack-pointer* 2)))) + +(with-test (:name (:binding-stack-gc-safety)) + (let (threads) + (unwind-protect + (progn + (push (sb-thread:make-thread #'exercise-binding) threads) + (push (sb-thread:make-thread (lambda () + (loop + (sleep 0.1) + (send-gc)))) + threads) + (sleep 4)) + (mapc #'sb-thread:terminate-thread threads)))) + +(format t "~&binding test done~%") + +;; Try to corrupt the NEXT-VECTOR. Operations on a hash table with a +;; cyclic NEXT-VECTOR can loop endlessly in a WITHOUT-GCING form +;; causing the next gc hang SBCL. +(with-test (:name (:hash-table-thread-safety)) + (let* ((hash (make-hash-table)) + (threads (list (sb-thread:make-thread + (lambda () + (loop + ;;(princ "1") (force-output) + (setf (gethash (random 100) hash) 'h)))) + (sb-thread:make-thread + (lambda () + (loop + ;;(princ "2") (force-output) + (remhash (random 100) hash)))) + (sb-thread:make-thread + (lambda () + (loop + (sleep (random 1.0)) + (sb-ext:gc :full t))))))) + (unwind-protect + (sleep 5) + (mapc #'sb-thread:terminate-thread threads)))) + +(format t "~&hash table test done~%") #| ;; a cll post from eric marsden | (defun crash () | (setq *debugger-hook* @@ -429,9 +571,3 @@ | (mp:make-process #'roomy) | (mp:make-process #'roomy))) |# - -;; give the other thread time to die before we leave, otherwise the -;; overall exit status is 0, not 104 -(sleep 2) - -(sb-ext:quit :unix-status 104)