tests/threads.impure.lisp

   1
   2 ;;;; miscellaneous tests of thread stuff
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; While most of SBCL is derived from the CMU CL system, the test
   8 ;;;; files (like this one) were written from scratch after the fork
   9 ;;;; from CMU CL.
  10 ;;;
  11 ;;;; This software is in the public domain and is provided with
  12 ;;;; absoluely no warranty. See the COPYING and CREDITS files for
  13 ;;;; more information.
  14
  15 (in-package "SB-THREAD") ; this is white-box testing, really
  16
  17 (use-package :test-util)
  18
  19 (defun wait-for-threads (threads)
  20   (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
  21
  22 (assert (eql 1 (length (list-all-threads))))
  23
  24 (assert (eq *current-thread*
  25             (find (thread-name *current-thread*) (list-all-threads)
  26                   :key #'thread-name :test #'equal)))
  27
  28 (assert (thread-alive-p *current-thread*))
  29
  30 (let ((a 0))
  31   (interrupt-thread *current-thread* (lambda () (setq a 1)))
  32   (assert (eql a 1)))
  33
  34 (let ((spinlock (make-spinlock)))
  35   (with-spinlock (spinlock)))
  36
  37 (let ((mutex (make-mutex)))
  38   (with-mutex (mutex)
  39     mutex))
  40
  41 #-sb-thread (sb-ext:quit :unix-status 104)
  42
  43 (let ((old-threads (list-all-threads))
  44       (thread (make-thread (lambda ()
  45                              (assert (find *current-thread* *all-threads*))
  46                              (sleep 2))))
  47       (new-threads (list-all-threads)))
  48   (assert (thread-alive-p thread))
  49   (assert (eq thread (first new-threads)))
  50   (assert (= (1+ (length old-threads)) (length new-threads)))
  51   (sleep 3)
  52   (assert (not (thread-alive-p thread))))
  53
  54 ;;; We had appalling scaling properties for a while.  Make sure they
  55 ;;; don't reappear.
  56 (defun scaling-test (function &optional (nthreads 5))
  57   "Execute FUNCTION with NTHREADS lurking to slow it down."
  58   (let ((queue (sb-thread:make-waitqueue))
  59         (mutex (sb-thread:make-mutex)))
  60     ;; Start NTHREADS idle threads.
  61     (dotimes (i nthreads)
  62       (sb-thread:make-thread (lambda ()
  63                                (with-mutex (mutex)
  64                                  (sb-thread:condition-wait queue mutex))
  65                                (sb-ext:quit))))
  66     (let ((start-time (get-internal-run-time)))
  67       (funcall function)
  68       (prog1 (- (get-internal-run-time) start-time)
  69         (sb-thread:condition-broadcast queue)))))
  70 (defun fact (n)
  71   "A function that does work with the CPU."
  72   (if (zerop n) 1 (* n (fact (1- n)))))
  73 (let ((work (lambda () (fact 15000))))
  74   (let ((zero (scaling-test work 0))
  75         (four (scaling-test work 4)))
  76     ;; a slightly weak assertion, but good enough for starters.
  77     (assert (< four (* 1.5 zero)))))
  78
  79 ;;; For one of the interupt-thread tests, we want a foreign function
  80 ;;; that does not make syscalls
  81
  82 (with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede)
  83   (format o "void loop_forever() { while(1) ; }~%"))
  84 (sb-ext:run-program
  85  #-sunos "cc" #+sunos "gcc"
  86  (or #+(or linux freebsd sunos) '(#+x86-64 "-fPIC"
  87                                   "-shared" "-o" "threads-foreign.so" "threads-foreign.c")
  88      #+darwin '("-dynamiclib" "-o" "threads-foreign.so" "threads-foreign.c")
  89      (error "Missing shared library compilation options for this platform"))
  90  :search t)
  91 (sb-alien:load-shared-object "threads-foreign.so")
  92 (sb-alien:define-alien-routine loop-forever sb-alien:void)
  93
  94
  95 ;;; elementary "can we get a lock and release it again"
  96 (let ((l (make-mutex :name "foo"))
  97       (p *current-thread*))
  98   (assert (eql (mutex-value l) nil) nil "1")
  99   (sb-thread:get-mutex l)
 100   (assert (eql (mutex-value l) p) nil "3")
 101   (sb-thread:release-mutex l)
 102   (assert (eql (mutex-value l) nil) nil "5"))
 103
 104 (labels ((ours-p (value)
 105            (eq *current-thread* value)))
 106   (let ((l (make-mutex :name "rec")))
 107     (assert (eql (mutex-value l) nil) nil "1")
 108     (sb-thread:with-recursive-lock (l)
 109       (assert (ours-p (mutex-value l)) nil "3")
 110       (sb-thread:with-recursive-lock (l)
 111         (assert (ours-p (mutex-value l)) nil "4"))
 112       (assert (ours-p (mutex-value l)) nil "5"))
 113     (assert (eql (mutex-value l) nil) nil "6")))
 114
 115 (with-test (:name (:mutex :nesting-mutex-and-recursive-lock))
 116   (let ((l (make-mutex :name "a mutex")))
 117     (with-mutex (l)
 118       (with-recursive-lock (l)))))
 119
 120 (let ((l (make-spinlock :name "spinlock")))
 121   (assert (eql (spinlock-value l) 0) nil "1")
 122   (with-spinlock (l)
 123     (assert (eql (spinlock-value l) 1) nil "2"))
 124   (assert (eql (spinlock-value l) 0) nil "3"))
 125
 126 ;; test that SLEEP actually sleeps for at least the given time, even
 127 ;; if interrupted by another thread exiting/a gc/anything
 128 (let ((start-time (get-universal-time)))
 129   (make-thread (lambda () (sleep 1) (sb-ext:gc :full t)))
 130   (sleep 5)
 131   (assert (>= (get-universal-time) (+ 5 start-time))))
 132
 133
 134 (let ((queue (make-waitqueue :name "queue"))
 135       (lock (make-mutex :name "lock"))
 136       (n 0))
 137   (labels ((in-new-thread ()
 138              (with-mutex (lock)
 139                (assert (eql (mutex-value lock) *current-thread*))
 140                (format t "~A got mutex~%" *current-thread*)
 141                ;; now drop it and sleep
 142                (condition-wait queue lock)
 143                ;; after waking we should have the lock again
 144                (assert (eql (mutex-value lock) *current-thread*))
 145                (assert (eql n 1))
 146                (decf n))))
 147     (make-thread #'in-new-thread)
 148     (sleep 2)                           ; give it  a chance to start
 149     ;; check the lock is free while it's asleep
 150     (format t "parent thread ~A~%" *current-thread*)
 151     (assert (eql (mutex-value lock) nil))
 152     (with-mutex (lock)
 153       (incf n)
 154       (condition-notify queue))
 155     (sleep 1)))
 156
 157 (let ((queue (make-waitqueue :name "queue"))
 158       (lock (make-mutex :name "lock")))
 159   (labels ((ours-p (value)
 160              (eq *current-thread* value))
 161            (in-new-thread ()
 162              (with-recursive-lock (lock)
 163                (assert (ours-p (mutex-value lock)))
 164                (format t "~A got mutex~%" (mutex-value lock))
 165                ;; now drop it and sleep
 166                (condition-wait queue lock)
 167                ;; after waking we should have the lock again
 168                (format t "woken, ~A got mutex~%" (mutex-value lock))
 169                (assert (ours-p (mutex-value lock))))))
 170     (make-thread #'in-new-thread)
 171     (sleep 2)                           ; give it  a chance to start
 172     ;; check the lock is free while it's asleep
 173     (format t "parent thread ~A~%" *current-thread*)
 174     (assert (eql (mutex-value lock) nil))
 175     (with-recursive-lock (lock)
 176       (condition-notify queue))
 177     (sleep 1)))
 178
 179 (let ((mutex (make-mutex :name "contended")))
 180   (labels ((run ()
 181              (let ((me *current-thread*))
 182                (dotimes (i 100)
 183                  (with-mutex (mutex)
 184                    (sleep .03)
 185                    (assert (eql (mutex-value mutex) me)))
 186                  (assert (not (eql (mutex-value mutex) me))))
 187                (format t "done ~A~%" *current-thread*))))
 188     (let ((kid1 (make-thread #'run))
 189           (kid2 (make-thread #'run)))
 190       (format t "contention ~A ~A~%" kid1 kid2)
 191       (wait-for-threads (list kid1 kid2)))))
 192
 193 ;;; semaphores
 194
 195 (defmacro raises-timeout-p (&body body)
 196   `(handler-case (progn (progn ,@body) nil)
 197     (sb-ext:timeout () t)))
 198
 199 (with-test (:name (:semaphore :wait-forever))
 200   (let ((sem (make-semaphore :count 0)))
 201     (assert (raises-timeout-p
 202               (sb-ext:with-timeout 0.1
 203                 (wait-on-semaphore sem))))))
 204
 205 (with-test (:name (:semaphore :initial-count))
 206   (let ((sem (make-semaphore :count 1)))
 207     (sb-ext:with-timeout 0.1
 208       (wait-on-semaphore sem))))
 209
 210 (with-test (:name (:semaphore :wait-then-signal))
 211   (let ((sem (make-semaphore))
 212         (signalled-p nil))
 213     (make-thread (lambda ()
 214                    (sleep 0.1)
 215                    (setq signalled-p t)
 216                    (signal-semaphore sem)))
 217     (wait-on-semaphore sem)
 218     (assert signalled-p)))
 219
 220 (with-test (:name (:semaphore :signal-then-wait))
 221   (let ((sem (make-semaphore))
 222         (signalled-p nil))
 223     (make-thread (lambda ()
 224                    (signal-semaphore sem)
 225                    (setq signalled-p t)))
 226     (loop until signalled-p)
 227     (wait-on-semaphore sem)
 228     (assert signalled-p)))
 229
 230 (with-test (:name (:semaphore :multiple-signals))
 231   (let* ((sem (make-semaphore :count 5))
 232          (threads (loop repeat 20
 233                         collect (make-thread (lambda ()
 234                                                (wait-on-semaphore sem))))))
 235     (flet ((count-live-threads ()
 236              (count-if #'thread-alive-p threads)))
 237       (sleep 0.5)
 238       (assert (= 15 (count-live-threads)))
 239       (signal-semaphore sem 10)
 240       (sleep 0.5)
 241       (assert (= 5 (count-live-threads)))
 242       (signal-semaphore sem 3)
 243       (sleep 0.5)
 244       (assert (= 2 (count-live-threads)))
 245       (signal-semaphore sem 4)
 246       (sleep 0.5)
 247       (assert (= 0 (count-live-threads))))))
 248
 249 (format t "~&semaphore tests done~%")
 250
 251 (defun test-interrupt (function-to-interrupt &optional quit-p)
 252   (let ((child  (make-thread function-to-interrupt)))
 253     ;;(format t "gdb ./src/runtime/sbcl ~A~%attach ~A~%" child child)
 254     (sleep 2)
 255     (format t "interrupting child ~A~%" child)
 256     (interrupt-thread child
 257                       (lambda ()
 258                         (format t "child pid ~A~%" *current-thread*)
 259                         (when quit-p (sb-ext:quit))))
 260     (sleep 1)
 261     child))
 262
 263 ;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
 264 ;; (d) waiting on a lock, (e) some code which we hope is likely to be
 265 ;; in pseudo-atomic
 266
 267 (let ((child (test-interrupt (lambda () (loop)))))  (terminate-thread child))
 268
 269 (test-interrupt #'loop-forever :quit)
 270
 271 (let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
 272   (terminate-thread child)
 273   (wait-for-threads (list child)))
 274
 275 (let ((lock (make-mutex :name "loctite"))
 276       child)
 277   (with-mutex (lock)
 278     (setf child (test-interrupt
 279                  (lambda ()
 280                    (with-mutex (lock)
 281                      (assert (eql (mutex-value lock) *current-thread*)))
 282                    (assert (not (eql (mutex-value lock) *current-thread*)))
 283                    (sleep 10))))
 284     ;;hold onto lock for long enough that child can't get it immediately
 285     (sleep 5)
 286     (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock))))
 287     (format t "parent releasing lock~%"))
 288   (terminate-thread child)
 289   (wait-for-threads (list child)))
 290
 291 (format t "~&locking test done~%")
 292
 293 (defun alloc-stuff () (copy-list '(1 2 3 4 5)))
 294
 295 (progn
 296   (let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff))))))
 297     (let ((killers
 298            (loop repeat 4 collect
 299                  (sb-thread:make-thread
 300                   (lambda ()
 301                     (loop repeat 25 do
 302                           (sleep (random 0.1d0))
 303                           (princ ".")
 304                           (force-output)
 305                           (sb-thread:interrupt-thread thread (lambda ()))))))))
 306       (wait-for-threads killers)
 307       (sb-thread:terminate-thread thread)
 308       (wait-for-threads (list thread))))
 309   (sb-ext:gc :full t))
 310
 311 (format t "~&multi interrupt test done~%")
 312
 313 (let ((c (make-thread (lambda () (loop (alloc-stuff))))))
 314   ;; NB this only works on x86: other ports don't have a symbol for
 315   ;; pseudo-atomic atomicity
 316   (dotimes (i 100)
 317     (sleep (random 0.1d0))
 318     (interrupt-thread c
 319                       (lambda ()
 320                         (princ ".") (force-output)
 321                         (assert (thread-alive-p *current-thread*))
 322                         (assert
 323                          (not (logbitp 0 SB-KERNEL:*PSEUDO-ATOMIC-BITS*))))))
 324   (terminate-thread c)
 325   (wait-for-threads (list c)))
 326
 327 (format t "~&interrupt test done~%")
 328
 329 (defparameter *interrupt-count* 0)
 330
 331 (declaim (notinline check-interrupt-count))
 332 (defun check-interrupt-count (i)
 333   (declare (optimize (debug 1) (speed 1)))
 334   ;; This used to lose if eflags were not restored after an interrupt.
 335   (unless (typep i 'fixnum)
 336     (error "!!!!!!!!!!!")))
 337
 338 (let ((c (make-thread
 339           (lambda ()
 340             (handler-bind ((error #'(lambda (cond)
 341                                       (princ cond)
 342                                       (sb-debug:backtrace
 343                                        most-positive-fixnum))))
 344               (loop (check-interrupt-count *interrupt-count*)))))))
 345   (let ((func (lambda ()
 346                 (princ ".")
 347                 (force-output)
 348                 (sb-impl::atomic-incf/symbol *interrupt-count*))))
 349     (setq *interrupt-count* 0)
 350     (dotimes (i 100)
 351       (sleep (random 0.1d0))
 352       (interrupt-thread c func))
 353     (loop until (= *interrupt-count* 100) do (sleep 0.1))
 354     (terminate-thread c)
 355     (wait-for-threads (list c))))
 356
 357 (format t "~&interrupt count test done~%")
 358
 359 (let (a-done b-done)
 360   (make-thread (lambda ()
 361                  (dotimes (i 100)
 362                    (sb-ext:gc) (princ "\\") (force-output))
 363                  (setf a-done t)))
 364   (make-thread (lambda ()
 365                  (dotimes (i 25)
 366                    (sb-ext:gc :full t)
 367                    (princ "/") (force-output))
 368                  (setf b-done t)))
 369   (loop
 370    (when (and a-done b-done) (return))
 371    (sleep 1)))
 372
 373 (terpri)
 374
 375 (defun waste (&optional (n 100000))
 376   (loop repeat n do (make-string 16384)))
 377
 378 (loop for i below 100 do
 379       (princ "!")
 380       (force-output)
 381       (sb-thread:make-thread
 382        #'(lambda ()
 383            (waste)))
 384       (waste)
 385       (sb-ext:gc))
 386
 387 (terpri)
 388
 389 (defparameter *aaa* nil)
 390 (loop for i below 100 do
 391       (princ "!")
 392       (force-output)
 393       (sb-thread:make-thread
 394        #'(lambda ()
 395            (let ((*aaa* (waste)))
 396              (waste))))
 397       (let ((*aaa* (waste)))
 398         (waste))
 399       (sb-ext:gc))
 400
 401 (format t "~&gc test done~%")
 402
 403 ;; this used to deadlock on session-lock
 404 (sb-thread:make-thread (lambda () (sb-ext:gc)))
 405 ;; expose thread creation races by exiting quickly
 406 (sb-thread:make-thread (lambda ()))
 407
 408 (defun exercise-syscall (fn reference-errno)
 409   (sb-thread:make-thread
 410    (lambda ()
 411      (loop do
 412           (funcall fn)
 413           (let ((errno (sb-unix::get-errno)))
 414             (sleep (random 0.1d0))
 415             (unless (eql errno reference-errno)
 416               (format t "Got errno: ~A (~A) instead of ~A~%"
 417                       errno
 418                       (sb-unix::strerror)
 419                       reference-errno)
 420               (force-output)
 421               (sb-ext:quit :unix-status 1)))))))
 422
 423 (let* ((nanosleep-errno (progn
 424                           (sb-unix:nanosleep -1 0)
 425                           (sb-unix::get-errno)))
 426        (open-errno (progn
 427                      (open "no-such-file"
 428                            :if-does-not-exist nil)
 429                      (sb-unix::get-errno)))
 430        (threads
 431         (list
 432          (exercise-syscall (lambda () (sb-unix:nanosleep -1 0)) nanosleep-errno)
 433          (exercise-syscall (lambda () (open "no-such-file"
 434                                             :if-does-not-exist nil))
 435                            open-errno)
 436          (sb-thread:make-thread (lambda () (loop (sb-ext:gc) (sleep 1)))))))
 437   (sleep 10)
 438   (princ "terminating threads")
 439   (dolist (thread threads)
 440     (sb-thread:terminate-thread thread)))
 441
 442 (format t "~&errno test done~%")
 443
 444 (loop repeat 100 do
 445       (let ((thread (sb-thread:make-thread (lambda () (sleep 0.1)))))
 446         (sb-thread:interrupt-thread
 447          thread
 448          (lambda ()
 449            (assert (find-restart 'sb-thread:terminate-thread))))))
 450
 451 (sb-ext:gc :full t)
 452
 453 (format t "~&thread startup sigmask test done~%")
 454
 455 (sb-debug::enable-debugger)
 456 (let* ((main-thread *current-thread*)
 457        (interruptor-thread
 458         (make-thread (lambda ()
 459                        (sleep 2)
 460                        (interrupt-thread main-thread #'break)
 461                        (sleep 2)
 462                        (interrupt-thread main-thread #'continue)))))
 463   (with-session-lock (*session*)
 464     (sleep 3))
 465   (loop while (thread-alive-p interruptor-thread)))
 466
 467 (format t "~&session lock test done~%")
 468
 469 (loop repeat 20 do
 470       (wait-for-threads
 471        (loop for i below 100 collect
 472              (sb-thread:make-thread (lambda ())))))
 473
 474 (format t "~&creation test done~%")
 475
 476 ;; interrupt handlers are per-thread with pthreads, make sure the
 477 ;; handler installed in one thread is global
 478 (sb-thread:make-thread
 479  (lambda ()
 480    (sb-ext:run-program "sleep" '("1") :search t :wait nil)))
 481
 482 ;;;; Binding stack safety
 483
 484 (defparameter *x* nil)
 485 (defparameter *n-gcs-requested* 0)
 486 (defparameter *n-gcs-done* 0)
 487
 488 (let ((counter 0))
 489   (defun make-something-big ()
 490     (let ((x (make-string 32000)))
 491       (incf counter)
 492       (let ((counter counter))
 493         (sb-ext:finalize x (lambda () (format t " ~S" counter)
 494                                    (force-output)))))))
 495
 496 (defmacro wait-for-gc ()
 497   `(progn
 498      (incf *n-gcs-requested*)
 499      (loop while (< *n-gcs-done* *n-gcs-requested*))))
 500
 501 (defun send-gc ()
 502   (loop until (< *n-gcs-done* *n-gcs-requested*))
 503   (format t "G")
 504   (force-output)
 505   (sb-ext:gc)
 506   (incf *n-gcs-done*))
 507
 508 (defun exercise-binding ()
 509   (loop
 510    (let ((*x* (make-something-big)))
 511      (let ((*x* 42))
 512        ;; at this point the binding stack looks like this:
 513        ;; NO-TLS-VALUE-MARKER, *x*, SOMETHING, *x*
 514        t))
 515    (wait-for-gc)
 516    ;; sig_stop_for_gc_handler binds FREE_INTERRUPT_CONTEXT_INDEX. By
 517    ;; now SOMETHING is gc'ed and the binding stack looks like this: 0,
 518    ;; 0, SOMETHING, 0 (because the symbol slots are zeroed on
 519    ;; unbinding but values are not).
 520    (let ((*x* nil))
 521      ;; bump bsp as if a BIND had just started
 522      (incf sb-vm::*binding-stack-pointer* 2)
 523      (wait-for-gc)
 524      (decf sb-vm::*binding-stack-pointer* 2))))
 525
 526 (with-test (:name (:binding-stack-gc-safety))
 527   (let (threads)
 528     (unwind-protect
 529          (progn
 530            (push (sb-thread:make-thread #'exercise-binding) threads)
 531            (push (sb-thread:make-thread (lambda ()
 532                                           (loop
 533                                            (sleep 0.1)
 534                                            (send-gc))))
 535                  threads)
 536            (sleep 4))
 537       (mapc #'sb-thread:terminate-thread threads))))
 538
 539 (format t "~&binding test done~%")
 540
 541 ;; Try to corrupt the NEXT-VECTOR. Operations on a hash table with a
 542 ;; cyclic NEXT-VECTOR can loop endlessly in a WITHOUT-GCING form
 543 ;; causing the next gc hang SBCL.
 544 (with-test (:name (:hash-table-thread-safety))
 545   (let* ((hash (make-hash-table))
 546          (threads (list (sb-thread:make-thread
 547                          (lambda ()
 548                            (loop
 549                             ;;(princ "1") (force-output)
 550                             (setf (gethash (random 100) hash) 'h))))
 551                         (sb-thread:make-thread
 552                          (lambda ()
 553                            (loop
 554                             ;;(princ "2") (force-output)
 555                             (remhash (random 100) hash))))
 556                         (sb-thread:make-thread
 557                          (lambda ()
 558                            (loop
 559                             (sleep (random 1.0))
 560                             (sb-ext:gc :full t)))))))
 561     (unwind-protect
 562          (sleep 5)
 563       (mapc #'sb-thread:terminate-thread threads))))
 564
 565 (format t "~&hash table test done~%")
 566 #|  ;; a cll post from eric marsden
 567 | (defun crash ()
 568 |   (setq *debugger-hook*
 569 |         (lambda (condition old-debugger-hook)
 570 |           (debug:backtrace 10)
 571 |           (unix:unix-exit 2)))
 572 |   #+live-dangerously
 573 |   (mp::start-sigalrm-yield)
 574 |   (flet ((roomy () (loop (with-output-to-string (*standard-output*) (room)))))
 575 |     (mp:make-process #'roomy)
 576 |     (mp:make-process #'roomy)))
 577 |#
 578
 579 (with-test (:name (:condition-variable :notify-multiple))
 580   (flet ((tester (notify-fun)
 581            (let ((queue (make-waitqueue :name "queue"))
 582                  (lock (make-mutex :name "lock"))
 583                  (data nil))
 584              (labels ((test (x)
 585                         (loop
 586                            (with-mutex (lock)
 587                              (format t "condition-wait ~a~%" x)
 588                              (force-output)
 589                              (condition-wait queue lock)
 590                              (format t "woke up ~a~%" x)
 591                              (force-output)
 592                              (push x data)))))
 593                (let ((threads (loop for x from 1 to 10
 594                                     collect
 595                                     (let ((x x))
 596                                       (sb-thread:make-thread (lambda ()
 597                                                                (test x)))))))
 598                  (sleep 5)
 599                  (with-mutex (lock)
 600                    (funcall notify-fun queue))
 601                  (sleep 5)
 602                  (mapcar #'terminate-thread threads)
 603                  ;; Check that all threads woke up at least once
 604                  (assert (= (length (remove-duplicates data)) 10)))))))
 605     (tester (lambda (queue)
 606               (format t "~&(condition-notify queue 10)~%")
 607               (force-output)
 608               (condition-notify queue 10)))
 609     (tester (lambda (queue)
 610               (format t "~&(condition-broadcast queue)~%")
 611               (force-output)
 612               (condition-broadcast queue)))))
 613
 614 (format t "waitqueue wakeup tests done~%")
 615
 616 (with-test (:name (:mutex :finalization))
 617   (let ((a nil))
 618     (dotimes (i 500000)
 619       (setf a (make-mutex)))))
 620
 621 (format t "mutex finalization test done~%")
 622
 623 ;;; Check that INFO is thread-safe, at least when we're just doing reads.
 624
 625 (let* ((symbols (loop repeat 10000 collect (gensym)))
 626        (functions (loop for (symbol . rest) on symbols
 627                         for next = (car rest)
 628                         for fun = (let ((next next))
 629                                     (lambda (n)
 630                                       (if next
 631                                           (funcall next (1- n))
 632                                           n)))
 633                         do (setf (symbol-function symbol) fun)
 634                         collect fun)))
 635   (defun infodb-test ()
 636     (funcall (car functions) 9999)))
 637
 638 (with-test (:name (:infodb :read))
 639   (let* ((ok t)
 640          (threads (loop for i from 0 to 10
 641                         collect (sb-thread:make-thread
 642                                  (let ((i i))
 643                                    (lambda ()
 644                                      (dotimes (j 100)
 645                                        (write-char #\-)
 646                                        (finish-output)
 647                                        (let ((n (infodb-test)))
 648                                          (unless (zerop n)
 649                                            (setf ok nil)
 650                                            (format t "N != 0 (~A)~%" n)
 651                                            (quit))))))))))
 652     (wait-for-threads threads)
 653     (assert ok)))
 654
 655 (format t "infodb test done~%")
 656
 657 (with-test (:name (:backtrace))
 658   ;; Printing backtraces from several threads at once used to hang the
 659   ;; whole SBCL process (discovered by accident due to a timer.impure
 660   ;; test misbehaving). The cause was that packages weren't even
 661   ;; thread-safe for only doing FIND-SYMBOL, and while printing
 662   ;; backtraces a loot of symbol lookups need to be done due to
 663   ;; *PRINT-ESCAPE*.
 664   (let* ((threads (loop repeat 10
 665                         collect (sb-thread:make-thread
 666                                  (lambda ()
 667                                    (dotimes (i 1000)
 668                                      (with-output-to-string (*debug-io*)
 669                                        (sb-debug::backtrace 10))))))))
 670     (wait-for-threads threads)))
 671
 672 (format t "backtrace test done~%")