X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.pure.lisp;h=bc2b94cc152d2323749d208b2b478a0b5d577183;hb=1f03c7f326823245708a84af86b31ac72bdb1742;hp=8187b51f762d2cb308f0768a9dccfc9ea6038d03;hpb=9cbef67c0d16955fc77a555e7ad251d93e206524;p=sbcl.git diff --git a/tests/threads.pure.lisp b/tests/threads.pure.lisp index 8187b51..bc2b94c 100644 --- a/tests/threads.pure.lisp +++ b/tests/threads.pure.lisp @@ -20,6 +20,24 @@ (use-package :test-util) +(with-test (:name mutex-owner) + ;; Make sure basics are sane on unithreaded ports as well + (let ((mutex (make-mutex))) + (get-mutex mutex) + (assert (eq *current-thread* (mutex-value mutex))) + (handler-bind ((warning #'error)) + (release-mutex mutex)) + (assert (not (mutex-value mutex))))) + +(with-test (:name spinlock-owner) + ;; Make sure basics are sane on unithreaded ports as well + (let ((spinlock (sb-thread::make-spinlock))) + (sb-thread::get-spinlock spinlock) + (assert (eq *current-thread* (sb-thread::spinlock-value spinlock))) + (handler-bind ((warning #'error)) + (sb-thread::release-spinlock spinlock)) + (assert (not (sb-thread::spinlock-value spinlock))))) + ;;; Terminating a thread that's waiting for the terminal. #+sb-thread @@ -92,12 +110,12 @@ (values (loop for r from 0 below n collect - (let ((r r)) - (sb-thread:make-thread (lambda () - (let ((sem semaphore)) - (dotimes (s i) - (sb-thread:wait-on-semaphore sem)))) - :name "reader"))) + (sb-thread:make-thread + (lambda () + (let ((sem semaphore)) + (dotimes (s i) + (sb-thread:wait-on-semaphore sem)))) + :name "reader")) (* n i))) (make-writers (n readers i) (let ((j (* readers i))) @@ -106,12 +124,12 @@ (let ((writers (loop for w from 0 below n collect - (let ((w w)) - (sb-thread:make-thread (lambda () - (let ((sem semaphore)) - (dotimes (s k) - (sb-thread:signal-semaphore sem)))) - :name "writer"))))) + (sb-thread:make-thread + (lambda () + (let ((sem semaphore)) + (dotimes (s k) + (sb-thread:signal-semaphore sem)))) + :name "writer")))) (assert (zerop rem)) writers) (+ rem (* n k)))))) @@ -139,3 +157,138 @@ (sb-ext:timeout () :timeout))))))) +;;;; SYMBOL-VALUE-IN-THREAD + +(with-test (:name symbol-value-in-thread.1) + (let ((* (cons t t))) + (assert (eq * (symbol-value-in-thread '* *current-thread*))) + (setf (symbol-value-in-thread '* *current-thread*) 123) + (assert (= 123 (symbol-value-in-thread '* *current-thread*))) + (assert (= 123 *)))) + +#+sb-thread +(with-test (:name symbol-value-in-thread.2) + (let* ((parent *current-thread*) + (semaphore (make-semaphore)) + (child (make-thread (lambda () + (wait-on-semaphore semaphore) + (let ((old (symbol-value-in-thread 'this-is-new parent))) + (setf (symbol-value-in-thread 'this-is-new parent) :from-child) + old))))) + (progv '(this-is-new) '(42) + (signal-semaphore semaphore) + (assert (= 42 (join-thread child))) + (assert (eq :from-child (symbol-value 'this-is-new)))))) + +;;; Disabled on Darwin due to deadlocks caused by apparent OS specific deadlocks, +;;; wich _appear_ to be caused by malloc() and free() not being thread safe: an +;;; interrupted malloc in one thread can apparently block a free in another. There +;;; are also some indications that pthread_mutex_lock is not re-entrant. +#+(and sb-thread (not darwin)) +(with-test (:name symbol-value-in-thread.3) + (let* ((parent *current-thread*) + (semaphore (make-semaphore)) + (running t) + (noise (make-thread (lambda () + (loop while running + do (setf * (make-array 1024)) + ;; Busy-wait a bit so we don't TOTALLY flood the + ;; system with GCs: a GC occurring in the middle of + ;; S-V-I-T causes it to start over -- we want that + ;; to occur occasionally, but not _all_ the time. + (loop repeat (random 128) + do (setf ** *))))))) + (write-string "; ") + (dotimes (i 15000) + (when (zerop (mod i 200)) + (write-char #\.) + (force-output)) + (let* ((mom-mark (cons t t)) + (kid-mark (cons t t)) + (child (make-thread (lambda () + (wait-on-semaphore semaphore) + (let ((old (symbol-value-in-thread 'this-is-new parent))) + (setf (symbol-value-in-thread 'this-is-new parent) + (make-array 24 :initial-element kid-mark)) + old))))) + (progv '(this-is-new) (list (make-array 24 :initial-element mom-mark)) + (signal-semaphore semaphore) + (assert (eq mom-mark (aref (join-thread child) 0))) + (assert (eq kid-mark (aref (symbol-value 'this-is-new) 0)))))) + (setf running nil) + (join-thread noise))) + +#+sb-thread +(with-test (:name symbol-value-in-thread.4) + (let* ((parent *current-thread*) + (semaphore (make-semaphore)) + (child (make-thread (lambda () + (wait-on-semaphore semaphore) + (symbol-value-in-thread 'this-is-new parent nil))))) + (signal-semaphore semaphore) + (assert (equal '(nil nil) (multiple-value-list (join-thread child)))))) + +#+sb-thread +(with-test (:name symbol-value-in-thread.5) + (let* ((parent *current-thread*) + (semaphore (make-semaphore)) + (child (make-thread (lambda () + (wait-on-semaphore semaphore) + (handler-case + (symbol-value-in-thread 'this-is-new parent) + (symbol-value-in-thread-error (e) + (list (thread-error-thread e) + (cell-error-name e) + (sb-thread::symbol-value-in-thread-error-info e)))))))) + (signal-semaphore semaphore) + (assert (equal (list *current-thread* 'this-is-new (list :read :unbound-in-thread)) + (join-thread child))))) + +#+sb-thread +(with-test (:name symbol-value-in-thread.6) + (let* ((parent *current-thread*) + (semaphore (make-semaphore)) + (name (gensym)) + (child (make-thread (lambda () + (wait-on-semaphore semaphore) + (handler-case + (setf (symbol-value-in-thread name parent) t) + (symbol-value-in-thread-error (e) + (list (thread-error-thread e) + (cell-error-name e) + (sb-thread::symbol-value-in-thread-error-info e)))))))) + (signal-semaphore semaphore) + (let ((res (join-thread child)) + (want (list *current-thread* name (list :write :no-tls-value)))) + (unless (equal res want) + (error "wanted ~S, got ~S" want res))))) + +#+sb-thread +(with-test (:name symbol-value-in-thread.7) + (let ((child (make-thread (lambda ()))) + (error-occurred nil)) + (join-thread child) + (handler-case + (symbol-value-in-thread 'this-is-new child) + (symbol-value-in-thread-error (e) + (setf error-occurred t) + (assert (eq child (thread-error-thread e))) + (assert (eq 'this-is-new (cell-error-name e))) + (assert (equal (list :read :thread-dead) + (sb-thread::symbol-value-in-thread-error-info e))))) + (assert error-occurred))) + +#+sb-thread +(with-test (:name symbol-value-in-thread.8) + (let ((child (make-thread (lambda ()))) + (error-occurred nil)) + (join-thread child) + (handler-case + (setf (symbol-value-in-thread 'this-is-new child) t) + (symbol-value-in-thread-error (e) + (setf error-occurred t) + (assert (eq child (thread-error-thread e))) + (assert (eq 'this-is-new (cell-error-name e))) + (assert (equal (list :write :thread-dead) + (sb-thread::symbol-value-in-thread-error-info e))))) + (assert error-occurred)))