+
;;;; miscellaneous tests of thread stuff
;;;; This software is part of the SBCL system. See the README file for
(with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede)
(format o "void loop_forever() { while(1) ; }~%"))
(sb-ext:run-program
- "cc"
- (or #+linux '("-shared" "-o" "threads-foreign.so" "threads-foreign.c")
+ #-sunos "cc" #+sunos "gcc"
+ (or #+(or linux freebsd sunos) '(#+x86-64 "-fPIC"
+ "-shared" "-o" "threads-foreign.so" "threads-foreign.c")
+ #+darwin '("-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")
(with-mutex (l)
(with-recursive-lock (l)))))
-(let ((l (make-spinlock :name "spinlock"))
- (p *current-thread*))
+(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
(lambda ()
(princ ".") (force-output)
(assert (thread-alive-p *current-thread*))
- (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
+ (assert
+ (not (logbitp 0 SB-KERNEL:*PSEUDO-ATOMIC-BITS*))))))
(terminate-thread c)
(wait-for-threads (list c)))
(defun send-gc ()
(loop until (< *n-gcs-done* *n-gcs-requested*))
- (format t "G" *n-gcs-requested* *n-gcs-done*)
+ (format t "G")
(force-output)
(sb-ext:gc)
(incf *n-gcs-done*))
(push (sb-thread:make-thread #'exercise-binding) threads)
(push (sb-thread:make-thread (lambda ()
(loop
+ (sleep 0.1)
(send-gc))))
threads)
(sleep 4))
(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*
| (mp:make-process #'roomy)
| (mp:make-process #'roomy)))
|#
+
+(with-test (:name (:condition-variable :notify-multiple))
+ (flet ((tester (notify-fun)
+ (let ((queue (make-waitqueue :name "queue"))
+ (lock (make-mutex :name "lock"))
+ (data nil))
+ (labels ((test (x)
+ (loop
+ (with-mutex (lock)
+ (format t "condition-wait ~a~%" x)
+ (force-output)
+ (condition-wait queue lock)
+ (format t "woke up ~a~%" x)
+ (force-output)
+ (push x data)))))
+ (let ((threads (loop for x from 1 to 10
+ collect
+ (let ((x x))
+ (sb-thread:make-thread (lambda ()
+ (test x)))))))
+ (sleep 5)
+ (with-mutex (lock)
+ (funcall notify-fun queue))
+ (sleep 5)
+ (mapcar #'terminate-thread threads)
+ ;; Check that all threads woke up at least once
+ (assert (= (length (remove-duplicates data)) 10)))))))
+ (tester (lambda (queue)
+ (format t "~&(condition-notify queue 10)~%")
+ (force-output)
+ (condition-notify queue 10)))
+ (tester (lambda (queue)
+ (format t "~&(condition-broadcast queue)~%")
+ (force-output)
+ (condition-broadcast queue)))))
+
+(format t "waitqueue wakeup tests done~%")
+
+(with-test (:name (:mutex :finalization))
+ (let ((a nil))
+ (dotimes (i 500000)
+ (setf a (make-mutex)))))
+
+(format t "mutex finalization test done~%")
+
+;;; Check that INFO is thread-safe, at least when we're just doing reads.
+
+(let* ((symbols (loop repeat 10000 collect (gensym)))
+ (functions (loop for (symbol . rest) on symbols
+ for next = (car rest)
+ for fun = (let ((next next))
+ (lambda (n)
+ (if next
+ (funcall next (1- n))
+ n)))
+ do (setf (symbol-function symbol) fun)
+ collect fun)))
+ (defun infodb-test ()
+ (funcall (car functions) 9999)))
+
+(with-test (:name (:infodb :read))
+ (let* ((ok t)
+ (threads (loop for i from 0 to 10
+ collect (sb-thread:make-thread
+ (let ((i i))
+ (lambda ()
+ (dotimes (j 100)
+ (write-char #\-)
+ (finish-output)
+ (let ((n (infodb-test)))
+ (unless (zerop n)
+ (setf ok nil)
+ (format t "N != 0 (~A)~%" n)
+ (quit))))))))))
+ (wait-for-threads threads)
+ (assert ok)))
+
+(format t "infodb test done~%")
+
+(with-test (:name (:backtrace))
+ ;; 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 (sb-thread:make-thread
+ (lambda ()
+ (dotimes (i 1000)
+ (with-output-to-string (*debug-io*)
+ (sb-debug::backtrace 10))))))))
+ (wait-for-threads threads)))
+
+(format t "backtrace test done~%")
+
+(format t "~&starting gc deadlock test: WARNING: THIS TEST WILL HANG ON FAILURE!~%")
+
+(with-test (:name (:gc-deadlock))
+ ;; Prior to 0.9.16.46 thread exit potentially deadlocked the
+ ;; GC due to *all-threads-lock* and session lock. On earlier
+ ;; versions and at least on one specific box this test is good enough
+ ;; to catch that typically well before the 1500th iteration.
+ (loop
+ with i = 0
+ with n = 3000
+ while (< i n)
+ do
+ (incf i)
+ (when (zerop (mod i 100))
+ (write-char #\.)
+ (force-output))
+ (handler-case
+ (if (oddp i)
+ (sb-thread:make-thread
+ (lambda ()
+ (sleep (random 0.001)))
+ :name (list :sleep i))
+ (sb-thread:make-thread
+ (lambda ()
+ ;; KLUDGE: what we are doing here is explicit,
+ ;; 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-session-lock (sb-thread::*session*)
+ (sb-ext:gc))))
+ :name (list :gc i)))
+ (error (e)
+ (format t "~%error creating thread ~D: ~A -- backing off for retry~%" i e)
+ (sleep 0.1)
+ (incf i)))))
+
+(format t "~&gc deadlock test done~%")