;;;; absoluely no warranty. See the COPYING and CREDITS files for
;;;; more information.
-(in-package "SB-THREAD") ; this is white-box testing, really
+; WHITE-BOX TESTS
+
+(in-package "SB-THREAD")
+(use-package :test-util)
+(use-package "ASSERTOID")
+
+(setf sb-unix::*on-dangerous-select* :error)
+
+(defun wait-for-threads (threads)
+ (mapc (lambda (thread) (sb-thread:join-thread thread :default nil)) threads)
+ (assert (not (some #'sb-thread:thread-alive-p threads))))
+
+(assert (eql 1 (length (list-all-threads))))
+
+(assert (eq *current-thread*
+ (find (thread-name *current-thread*) (list-all-threads)
+ :key #'thread-name :test #'equal)))
+
+(assert (thread-alive-p *current-thread*))
+
+(let ((a 0))
+ (interrupt-thread *current-thread* (lambda () (setq a 1)))
+ (assert (eql a 1)))
+
+(let ((spinlock (make-spinlock)))
+ (with-spinlock (spinlock)))
+
+(let ((mutex (make-mutex)))
+ (with-mutex (mutex)
+ mutex))
+
+(sb-alien:define-alien-routine "check_deferrables_blocked_or_lose"
+ void
+ (where sb-alien:unsigned-long))
+(sb-alien:define-alien-routine "check_deferrables_unblocked_or_lose"
+ void
+ (where sb-alien:unsigned-long))
+
+(with-test (:name (:interrupt-thread :deferrables-blocked))
+ (sb-thread:interrupt-thread sb-thread:*current-thread*
+ (lambda ()
+ (check-deferrables-blocked-or-lose 0))))
+
+(with-test (:name (:interrupt-thread :deferrables-unblocked))
+ (sb-thread:interrupt-thread sb-thread:*current-thread*
+ (lambda ()
+ (with-interrupts
+ (check-deferrables-unblocked-or-lose 0)))))
+
+(with-test (:name (:interrupt-thread :nlx))
+ (catch 'xxx
+ (sb-thread:interrupt-thread sb-thread:*current-thread*
+ (lambda ()
+ (check-deferrables-blocked-or-lose 0)
+ (throw 'xxx nil))))
+ (check-deferrables-unblocked-or-lose 0))
+
+#-sb-thread (sb-ext:quit :unix-status 104)
+
+(with-test (:name (:interrupt-thread :deferrables-unblocked-by-spinlock))
+ (let ((spinlock (sb-thread::make-spinlock))
+ (thread (sb-thread:make-thread (lambda ()
+ (loop (sleep 1))))))
+ (sb-thread::get-spinlock spinlock)
+ (sb-thread:interrupt-thread thread
+ (lambda ()
+ (check-deferrables-blocked-or-lose 0)
+ (sb-thread::get-spinlock spinlock)
+ (check-deferrables-unblocked-or-lose 0)
+ (sb-ext:quit)))
+ (sleep 1)
+ (sb-thread::release-spinlock spinlock)))
;;; compare-and-swap
(defmacro defincf (name accessor &rest args)
`(defun ,name (x)
(let* ((old (,accessor x ,@args))
- (new (1+ old)))
+ (new (1+ old)))
(loop until (eq old (sb-ext:compare-and-swap (,accessor x ,@args) old new))
do (setf old (,accessor x ,@args)
- new (1+ old)))
+ new (1+ old)))
new)))
(defstruct cas-struct (slot 0))
(defun ,name (n)
(declare (fixnum n))
(let* ((x ,init)
- (run nil)
- (threads
- (loop repeat 10
- collect (sb-thread:make-thread
- (lambda ()
- (loop until run)
- (loop repeat n do (,incf x)))))))
- (setf run t)
- (dolist (th threads)
- (sb-thread:join-thread th))
- (assert (= (,op x) (* 10 n)))))
+ (run nil)
+ (threads
+ (loop repeat 10
+ collect (sb-thread:make-thread
+ (lambda ()
+ (loop until run
+ do (sb-thread:thread-yield))
+ (loop repeat n do (,incf x)))))))
+ (setf run t)
+ (dolist (th threads)
+ (sb-thread:join-thread th))
+ (assert (= (,op x) (* 10 n)))))
(,name 200000)))
(def-test-cas test-cas-car (cons 0 nil) incf-car car)
(def-test-cas test-cas-cdr (cons nil 0) incf-cdr cdr)
(def-test-cas test-cas-slot (make-cas-struct) incf-slot cas-struct-slot)
(def-test-cas test-cas-value (let ((x '.x.))
- (set x 0)
- x)
+ (set x 0)
+ x)
incf-symbol-value symbol-value)
(def-test-cas test-cas-svref/0 (vector 0 nil) incf-svref/0 (lambda (x)
- (svref x 0)))
+ (svref x 0)))
(def-test-cas test-cas-svref/1 (vector nil 0) incf-svref/1 (lambda (x)
- (svref x 1)))
+ (svref x 1)))
(format t "~&compare-and-swap tests done~%")
-(use-package :test-util)
-(use-package "ASSERTOID")
-
-(setf sb-unix::*on-dangerous-select* :error)
-
-(defun wait-for-threads (threads)
- (mapc (lambda (thread) (sb-thread:join-thread thread :default nil)) threads)
- (assert (not (some #'sb-thread:thread-alive-p threads))))
-
-(assert (eql 1 (length (list-all-threads))))
-
-(assert (eq *current-thread*
- (find (thread-name *current-thread*) (list-all-threads)
- :key #'thread-name :test #'equal)))
-
-(assert (thread-alive-p *current-thread*))
-
-(let ((a 0))
- (interrupt-thread *current-thread* (lambda () (setq a 1)))
- (assert (eql a 1)))
-
-(let ((spinlock (make-spinlock)))
- (with-spinlock (spinlock)))
-
-(let ((mutex (make-mutex)))
- (with-mutex (mutex)
- mutex))
-
-#-sb-thread (sb-ext:quit :unix-status 104)
-
(let ((old-threads (list-all-threads))
(thread (make-thread (lambda ()
(assert (find *current-thread* *all-threads*))
:default sym)))))
(with-test (:name '(:join-thread :nlx :error))
- (raises-error? (join-thread (make-thread (lambda () (sb-ext:quit))))))
+ (raises-error? (join-thread (make-thread (lambda () (sb-ext:quit))))
+ join-thread-error))
(with-test (:name '(:join-thread :multiple-values))
(assert (equal '(1 2 3)
"-dynamiclib" "-o" "threads-foreign.so" "threads-foreign.c")
(error "Missing shared library compilation options for this platform"))
:search t)
-(sb-alien:load-shared-object "threads-foreign.so")
+(sb-alien:load-shared-object (truename "threads-foreign.so"))
(sb-alien:define-alien-routine loop-forever sb-alien:void)
(delete-file "threads-foreign.c")
(wait-on-semaphore sem)
(assert signalled-p)))
-(with-test (:name (:semaphore :multiple-signals))
+(defun test-semaphore-multiple-signals (wait-on-semaphore)
(let* ((sem (make-semaphore :count 5))
- (threads (loop repeat 20
- collect (make-thread (lambda ()
- (wait-on-semaphore sem))))))
+ (threads (loop repeat 20 collecting
+ (make-thread (lambda ()
+ (funcall wait-on-semaphore sem))))))
(flet ((count-live-threads ()
(count-if #'thread-alive-p threads)))
(sleep 0.5)
(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 (try-semaphore sem))
+ (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))
+ (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 50))
+ (waiters (make-threads 20 #'(lambda ()
+ (wait-on-semaphore sem))))
+ (triers (make-threads 40 #'(lambda ()
+ (sleep (random 0.01))
+ (try-semaphore sem))))
+ (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))))))
+
+
+
(format t "~&semaphore tests done~%")
(defun test-interrupt (function-to-interrupt &optional quit-p)
(format t "~&interrupt test done~%")
-(defparameter *interrupt-count* 0)
+(defstruct counter (n 0 :type sb-vm:word))
+(defvar *interrupt-counter* (make-counter))
(declaim (notinline check-interrupt-count))
(defun check-interrupt-count (i)
(princ cond)
(sb-debug:backtrace
most-positive-fixnum))))
- (loop (check-interrupt-count *interrupt-count*)))))))
+ (loop (check-interrupt-count (counter-n *interrupt-counter*))))))))
(let ((func (lambda ()
(princ ".")
(force-output)
- (sb-impl::atomic-incf/symbol *interrupt-count*))))
- (setq *interrupt-count* 0)
+ (sb-ext:atomic-incf (counter-n *interrupt-counter*)))))
+ (setf (counter-n *interrupt-counter*) 0)
(dotimes (i 100)
(sleep (random 0.1d0))
(interrupt-thread c func))
- (loop until (= *interrupt-count* 100) do (sleep 0.1))
+ (loop until (= (counter-n *interrupt-counter*) 100) do (sleep 0.1))
(terminate-thread c)
(wait-for-threads (list c))))
(format t "~&interrupt count test done~%")
+(defvar *runningp* nil)
+
+(with-test (:name (:interrupt-thread :no-nesting))
+ (let ((thread (sb-thread:make-thread
+ (lambda ()
+ (catch 'xxx
+ (loop))))))
+ (declare (special runningp))
+ (sleep 0.2)
+ (sb-thread:interrupt-thread thread
+ (lambda ()
+ (let ((*runningp* t))
+ (sleep 1))))
+ (sleep 0.2)
+ (sb-thread:interrupt-thread thread
+ (lambda ()
+ (throw 'xxx *runningp*)))
+ (assert (not (sb-thread:join-thread thread)))))
+
+(with-test (:name (:interrupt-thread :nesting))
+ (let ((thread (sb-thread:make-thread
+ (lambda ()
+ (catch 'xxx
+ (loop))))))
+ (declare (special runningp))
+ (sleep 0.2)
+ (sb-thread:interrupt-thread thread
+ (lambda ()
+ (let ((*runningp* t))
+ (sb-sys:with-interrupts
+ (sleep 1)))))
+ (sleep 0.2)
+ (sb-thread:interrupt-thread thread
+ (lambda ()
+ (throw 'xxx *runningp*)))
+ (assert (sb-thread:join-thread thread))))
+
(let (a-done b-done)
(make-thread (lambda ()
(dotimes (i 100)
(interruptor-thread
(make-thread (lambda ()
(sleep 2)
- (interrupt-thread main-thread #'break)
+ (interrupt-thread main-thread
+ (lambda ()
+ (with-interrupts
+ (break))))
(sleep 2)
(interrupt-thread main-thread #'continue))
:name "interruptor")))
(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))
+;;; HASH TABLES
+
+(defvar *errors* nil)
+
+(defun oops (e)
+ (setf *errors* e)
+ (format t "~&oops: ~A in ~S~%" e *current-thread*)
+ (sb-debug:backtrace)
+ (catch 'done))
+
+(with-test (:name (:unsynchronized-hash-table))
+ ;; We expect a (probable) error here: parellel readers and writers
+ ;; on a hash-table are not expected to work -- but we also don't
+ ;; expect this to corrupt the image.
(let* ((hash (make-hash-table))
+ (*errors* nil)
(threads (list (sb-thread:make-thread
(lambda ()
- (loop
- ;;(princ "1") (force-output)
- (setf (gethash (random 100) hash) 'h))))
+ (catch 'done
+ (handler-bind ((serious-condition 'oops))
+ (loop
+ ;;(princ "1") (force-output)
+ (setf (gethash (random 100) hash) 'h)))))
+ :name "writer")
(sb-thread:make-thread
(lambda ()
- (loop
- ;;(princ "2") (force-output)
- (remhash (random 100) hash))))
+ (catch 'done
+ (handler-bind ((serious-condition 'oops))
+ (loop
+ ;;(princ "2") (force-output)
+ (remhash (random 100) hash)))))
+ :name "reader")
(sb-thread:make-thread
(lambda ()
- (loop
- (sleep (random 1.0))
- (sb-ext:gc :full t)))))))
+ (catch 'done
+ (handler-bind ((serious-condition 'oops))
+ (loop
+ (sleep (random 1.0))
+ (sb-ext:gc :full t)))))
+ :name "collector"))))
(unwind-protect
- (sleep 5)
+ (sleep 10)
(mapc #'sb-thread:terminate-thread threads))))
-(format t "~&hash table test done~%")
+(format t "~&unsynchronized hash table test done~%")
+
+(with-test (:name (:synchronized-hash-table))
+ (let* ((hash (make-hash-table :synchronized t))
+ (*errors* nil)
+ (threads (list (sb-thread:make-thread
+ (lambda ()
+ (catch 'done
+ (handler-bind ((serious-condition 'oops))
+ (loop
+ ;;(princ "1") (force-output)
+ (setf (gethash (random 100) hash) 'h)))))
+ :name "writer")
+ (sb-thread:make-thread
+ (lambda ()
+ (catch 'done
+ (handler-bind ((serious-condition 'oops))
+ (loop
+ ;;(princ "2") (force-output)
+ (remhash (random 100) hash)))))
+ :name "reader")
+ (sb-thread:make-thread
+ (lambda ()
+ (catch 'done
+ (handler-bind ((serious-condition 'oops))
+ (loop
+ (sleep (random 1.0))
+ (sb-ext:gc :full t)))))
+ :name "collector"))))
+ (unwind-protect
+ (sleep 10)
+ (mapc #'sb-thread:terminate-thread threads))
+ (assert (not *errors*))))
+
+(format t "~&synchronized hash table test done~%")
+
+(with-test (:name (:hash-table-parallel-readers))
+ (let ((hash (make-hash-table))
+ (*errors* nil))
+ (loop repeat 50
+ do (setf (gethash (random 100) hash) 'xxx))
+ (let ((threads (list (sb-thread:make-thread
+ (lambda ()
+ (catch 'done
+ (handler-bind ((serious-condition 'oops))
+ (loop
+ until (eq t (gethash (random 100) hash))))))
+ :name "reader 1")
+ (sb-thread:make-thread
+ (lambda ()
+ (catch 'done
+ (handler-bind ((serious-condition 'oops))
+ (loop
+ until (eq t (gethash (random 100) hash))))))
+ :name "reader 2")
+ (sb-thread:make-thread
+ (lambda ()
+ (catch 'done
+ (handler-bind ((serious-condition 'oops))
+ (loop
+ until (eq t (gethash (random 100) hash))))))
+ :name "reader 3")
+ (sb-thread:make-thread
+ (lambda ()
+ (catch 'done
+ (handler-bind ((serious-condition 'oops))
+ (loop
+ (sleep (random 1.0))
+ (sb-ext:gc :full t)))))
+ :name "collector"))))
+ (unwind-protect
+ (sleep 10)
+ (mapc #'sb-thread:terminate-thread threads))
+ (assert (not *errors*)))))
+
+(format t "~&multiple reader hash table test done~%")
+
+(with-test (:name (:hash-table-single-accessor-parallel-gc))
+ (let ((hash (make-hash-table))
+ (*errors* nil))
+ (let ((threads (list (sb-thread:make-thread
+ (lambda ()
+ (handler-bind ((serious-condition 'oops))
+ (loop
+ (let ((n (random 100)))
+ (if (gethash n hash)
+ (remhash n hash)
+ (setf (gethash n hash) 'h))))))
+ :name "accessor")
+ (sb-thread:make-thread
+ (lambda ()
+ (handler-bind ((serious-condition 'oops))
+ (loop
+ (sleep (random 1.0))
+ (sb-ext:gc :full t))))
+ :name "collector"))))
+ (unwind-protect
+ (sleep 10)
+ (mapc #'sb-thread:terminate-thread threads))
+ (assert (not *errors*)))))
+
+(format t "~&single accessor hash table test~%")
+
#| ;; a cll post from eric marsden
| (defun crash ()
| (setq *debugger-hook*
| (mp:make-process #'roomy)))
|#
+;;; KLUDGE: No deadlines while waiting on lutex-based condition variables. This test
+;;; would just hang.
+#-sb-lutex
+(with-test (:name (:condition-variable :wait-multiple))
+ (loop repeat 40 do
+ (let ((waitqueue (sb-thread:make-waitqueue :name "Q"))
+ (mutex (sb-thread:make-mutex :name "M"))
+ (failedp nil))
+ (format t ".")
+ (finish-output t)
+ (let ((threads (loop repeat 200
+ collect
+ (sb-thread:make-thread
+ (lambda ()
+ (handler-case
+ (sb-sys:with-deadline (:seconds 0.01)
+ (sb-thread:with-mutex (mutex)
+ (sb-thread:condition-wait waitqueue
+ mutex)
+ (setq failedp t)))
+ (sb-sys:deadline-timeout (c)
+ (declare (ignore c)))))))))
+ (mapc #'sb-thread:join-thread threads)
+ (assert (not failedp))))))
+
(with-test (:name (:condition-variable :notify-multiple))
(flet ((tester (notify-fun)
(let ((queue (make-waitqueue :name "queue"))
(format t "waitqueue wakeup tests done~%")
+;;; Make sure that a deadline handler is not invoked twice in a row in
+;;; CONDITION-WAIT. See LP #512914 for a detailed explanation.
+;;;
+#-sb-lutex ; See KLUDGE above: no deadlines for condition-wait+lutexes.
+(with-test (:name (:condition-wait :deadlines :LP-512914))
+ (let ((n 2) ; was empirically enough to trigger the bug
+ (mutex (sb-thread:make-mutex))
+ (waitq (sb-thread:make-waitqueue))
+ (threads nil)
+ (deadline-handler-run-twice? nil))
+ (dotimes (i n)
+ (let ((child
+ (sb-thread: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)
+ (sb-thread:with-mutex (mutex)
+ (sb-thread:condition-wait waitq mutex))))))))
+ (push child threads)))
+ (mapc #'sb-thread:join-thread threads)
+ (assert (not deadline-handler-run-twice?))))
+
+(with-test (:name (:condition-wait :signal-deadline-with-interrupts-enabled))
+ (let ((mutex (sb-thread:make-mutex))
+ (waitq (sb-thread:make-waitqueue))
+ (A-holds? :unknown)
+ (B-holds? :unknown)
+ (A-interrupts-enabled? :unknown)
+ (B-interrupts-enabled? :unknown)
+ (A)
+ (B))
+ ;; W.L.O.G., we assume that A is executed first...
+ (setq A (sb-thread:make-thread
+ #'(lambda ()
+ (handler-bind
+ ((sb-sys:deadline-timeout
+ #'(lambda (c)
+ ;; We came here through the call to DECODE-TIMEOUT
+ ;; in CONDITION-WAIT; hence both here are supposed
+ ;; to evaluate to T.
+ (setq A-holds? (sb-thread:holding-mutex-p mutex))
+ (setq A-interrupts-enabled?
+ sb-sys:*interrupts-enabled*)
+ (sleep 0.2)
+ (sb-thread:condition-broadcast waitq)
+ (sb-sys:defer-deadline 10.0 c))))
+ (sb-sys:with-deadline (:seconds 0.1)
+ (sb-thread:with-mutex (mutex)
+ (sb-thread:condition-wait waitq mutex)))))))
+ (setq B (sb-thread:make-thread
+ #'(lambda ()
+ (thread-yield)
+ (handler-bind
+ ((sb-sys:deadline-timeout
+ #'(lambda (c)
+ ;; We came here through the call to GET-MUTEX
+ ;; in CONDITION-WAIT (contended case of
+ ;; reaquiring the mutex) - so the former will
+ ;; be NIL, but interrupts should still be enabled.
+ (setq B-holds? (sb-thread:holding-mutex-p mutex))
+ (setq B-interrupts-enabled?
+ sb-sys:*interrupts-enabled*)
+ (sleep 0.2)
+ (sb-thread:condition-broadcast waitq)
+ (sb-sys:defer-deadline 10.0 c))))
+ (sb-sys:with-deadline (:seconds 0.1)
+ (sb-thread:with-mutex (mutex)
+ (sb-thread:condition-wait waitq mutex)))))))
+ (sb-thread:join-thread A)
+ (sb-thread:join-thread B)
+ (let ((A-result (list A-holds? A-interrupts-enabled?))
+ (B-result (list B-holds? B-interrupts-enabled?)))
+ ;; We also check some subtle behaviour w.r.t. whether a deadline
+ ;; handler in CONDITION-WAIT got the mutex, or not. This is most
+ ;; probably very internal behaviour (so user should not depend
+ ;; on it) -- I added the testing here just to manifest current
+ ;; behaviour.
+ (cond ((equal A-result '(t t)) (assert (equal B-result '(nil t))))
+ ((equal B-result '(t t)) (assert (equal A-result '(nil t))))
+ (t (error "Failure: fall through."))))))
+
(with-test (:name (:mutex :finalization))
(let ((a nil))
(dotimes (i 500000)
;; but the same can happen because of a regular
;; MAKE-THREAD or LIST-ALL-THREADS, and various
;; session functions.
- (sb-thread:with-mutex (sb-thread::*all-threads-lock*)
+ (sb-thread::with-all-threads-lock
(sb-thread::with-session-lock (sb-thread::*session*)
(sb-ext:gc))))
:name (list :gc i)))
(with-test (:name '(:hash-cache :subtypep))
(dotimes (i 10)
(sb-thread:make-thread #'subtypep-hash-cache-test)))
-
(format t "hash-cache tests done~%")
+
+;;;; BLACK BOX TESTS
+
+(in-package :cl-user)
+(use-package :test-util)
+(use-package "ASSERTOID")
+
+(format t "parallel defclass test -- WARNING, WILL HANG ON FAILURE!~%")
+(with-test (:name :parallel-defclass)
+ (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)))
+ (let* ((run t)
+ (d1 (sb-thread:make-thread (lambda ()
+ (loop while run
+ do (defclass test-1 () ((a :initform :new-a)))
+ (write-char #\1)
+ (force-output)))
+ :name "d1"))
+ (d2 (sb-thread:make-thread (lambda ()
+ (loop while run
+ do (defclass test-2 () ((b :initform :new-b)))
+ (write-char #\2)
+ (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)))
+ (write-char #\3)
+ (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))))
+ (write-char #\i)
+ (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))))
+(format t "parallel defclass test done~%")
projects / sbcl.git / blobdiff