+(terpri)
+
+(defun waste (&optional (n 100000))
+ (loop repeat n do (make-string 16384)))
+
+(loop for i below 100 do
+ (princ "!")
+ (force-output)
+ (sb-thread:make-thread
+ #'(lambda ()
+ (waste)))
+ (waste)
+ (sb-ext:gc))
+
+(terpri)
+
+(defparameter *aaa* nil)
+(loop for i below 100 do
+ (princ "!")
+ (force-output)
+ (sb-thread:make-thread
+ #'(lambda ()
+ (let ((*aaa* (waste)))
+ (waste))))
+ (let ((*aaa* (waste)))
+ (waste))
+ (sb-ext:gc))
+
+(format t "~&gc test done~%")
+
+;; this used to deadlock on session-lock
+(sb-thread:make-thread (lambda () (sb-ext:gc)))
+;; expose thread creation races by exiting quickly
+(sb-thread:make-thread (lambda ()))
+
+(defun exercise-syscall (fn reference-errno)
+ (sb-thread:make-thread
+ (lambda ()
+ (loop do
+ (funcall fn)
+ (let ((errno (sb-unix::get-errno)))
+ (sleep (random 0.1d0))
+ (unless (eql errno reference-errno)
+ (format t "Got errno: ~A (~A) instead of ~A~%"
+ errno
+ (sb-unix::strerror)
+ reference-errno)
+ (force-output)
+ (sb-ext:quit :unix-status 1)))))))
+
+;; (nanosleep -1 0) does not fail on FreeBSD
+(let* (#-freebsd
+ (nanosleep-errno (progn
+ (sb-unix:nanosleep -1 0)
+ (sb-unix::get-errno)))
+ (open-errno (progn
+ (open "no-such-file"
+ :if-does-not-exist nil)
+ (sb-unix::get-errno)))
+ (threads
+ (list
+ #-freebsd
+ (exercise-syscall (lambda () (sb-unix:nanosleep -1 0)) nanosleep-errno)
+ (exercise-syscall (lambda () (open "no-such-file"
+ :if-does-not-exist nil))
+ open-errno)
+ (sb-thread:make-thread (lambda () (loop (sb-ext:gc) (sleep 1)))))))
+ (sleep 10)
+ (princ "terminating threads")
+ (dolist (thread threads)
+ (sb-thread:terminate-thread thread)))
+
+(format t "~&errno test done~%")
+
+(loop repeat 100 do
+ (let ((thread (sb-thread:make-thread (lambda () (sleep 0.1)))))
+ (sb-thread:interrupt-thread
+ thread
+ (lambda ()
+ (assert (find-restart 'sb-thread:terminate-thread))))))
+
+(sb-ext:gc :full t)
+
+(format t "~&thread startup sigmask test done~%")
+
+;; FIXME: What is this supposed to test?
+(sb-debug::enable-debugger)
+(let* ((main-thread *current-thread*)
+ (interruptor-thread
+ (make-thread (lambda ()
+ (sleep 2)
+ (interrupt-thread main-thread #'break)
+ (sleep 2)
+ (interrupt-thread main-thread #'continue))
+ :name "interruptor")))
+ (with-session-lock (*session*)
+ (sleep 3))
+ (loop while (thread-alive-p interruptor-thread)))
+
+(format t "~&session lock test done~%")
+
+(loop repeat 20 do
+ (wait-for-threads
+ (loop for i below 100 collect
+ (sb-thread:make-thread (lambda ())))))
+
+(format t "~&creation test done~%")
+
+;; 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~%")
+
+;;; 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 ()
+ (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))))
+
+(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*
+| (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)))
+|#
+
+(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
+ (lambda ()
+ (dotimes (j 100)
+ (write-char #\-)
+ (finish-output)
+ (let ((n (infodb-test)))
+ (unless (zerop n)
+ (setf ok nil)
+ (format t "N != 0 (~A)~%" n)
+ (sb-ext: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~%")
+\f
+(let ((count (make-array 8 :initial-element 0)))
+ (defun closure-one ()
+ (declare (optimize safety))
+ (values (incf (aref count 0)) (incf (aref count 1))
+ (incf (aref count 2)) (incf (aref count 3))
+ (incf (aref count 4)) (incf (aref count 5))
+ (incf (aref count 6)) (incf (aref count 7))))
+ (defun no-optimizing-away-closure-one ()
+ (setf count (make-array 8 :initial-element 0))))
+
+(defstruct box
+ (count 0))
+
+(let ((one (make-box))
+ (two (make-box))
+ (three (make-box)))
+ (defun closure-two ()
+ (declare (optimize safety))
+ (values (incf (box-count one)) (incf (box-count two)) (incf (box-count three))))
+ (defun no-optimizing-away-closure-two ()
+ (setf one (make-box)
+ two (make-box)
+ three (make-box))))
+
+(with-test (:name (:funcallable-instances))
+ ;; the funcallable-instance implementation used not to be threadsafe
+ ;; against setting the funcallable-instance function to a closure
+ ;; (because the code and lexenv were set separately).
+ (let ((fun (sb-kernel:%make-funcallable-instance 0))
+ (condition nil))
+ (setf (sb-kernel:funcallable-instance-fun fun) #'closure-one)
+ (flet ((changer ()
+ (loop (setf (sb-kernel:funcallable-instance-fun fun) #'closure-one)
+ (setf (sb-kernel:funcallable-instance-fun fun) #'closure-two)))
+ (test ()
+ (handler-case (loop (funcall fun))
+ (serious-condition (c) (setf condition c)))))
+ (let ((changer (make-thread #'changer))
+ (test (make-thread #'test)))
+ (handler-case
+ (progn
+ ;; The two closures above are fairly carefully crafted
+ ;; so that if given the wrong lexenv they will tend to
+ ;; do some serious damage, but it is of course difficult
+ ;; to predict where the various bits and pieces will be
+ ;; allocated. Five seconds failed fairly reliably on
+ ;; both my x86 and x86-64 systems. -- CSR, 2006-09-27.
+ (sb-ext:with-timeout 5
+ (wait-for-threads (list test)))
+ (error "~@<test thread got condition:~2I~_~A~@:>" condition))
+ (sb-ext:timeout ()
+ (terminate-thread changer)
+ (terminate-thread test)
+ (wait-for-threads (list changer test))))))))
+
+(format t "~&funcallable-instance test done~%")
+
+(defun random-type (n)
+ `(integer ,(random n) ,(+ n (random n))))
+
+(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))))))
+ (format t "ok~%")
+ (force-output))
+
+(with-test (:name '(:hash-cache :subtypep))
+ (dotimes (i 10)
+ (sb-thread:make-thread #'subtypep-hash-cache-test)))