tests/threads.impure.lisp

   1 ;;;; miscellaneous tests of thread stuff
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absoluely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (in-package "SB-THREAD") ; this is white-box testing, really
  15
  16 (use-package :test-util)
  17 (use-package "ASSERTOID")
  18
  19 (setf sb-unix::*on-dangerous-select* :error)
  20
  21 (defun wait-for-threads (threads)
  22   (mapc (lambda (thread) (sb-thread:join-thread thread :default nil)) threads)
  23   (assert (not (some #'sb-thread:thread-alive-p threads))))
  24
  25 (assert (eql 1 (length (list-all-threads))))
  26
  27 (assert (eq *current-thread*
  28             (find (thread-name *current-thread*) (list-all-threads)
  29                   :key #'thread-name :test #'equal)))
  30
  31 (assert (thread-alive-p *current-thread*))
  32
  33 (let ((a 0))
  34   (interrupt-thread *current-thread* (lambda () (setq a 1)))
  35   (assert (eql a 1)))
  36
  37 (let ((spinlock (make-spinlock)))
  38   (with-spinlock (spinlock)))
  39
  40 (let ((mutex (make-mutex)))
  41   (with-mutex (mutex)
  42     mutex))
  43
  44 #-sb-thread (sb-ext:quit :unix-status 104)
  45
  46 ;;; compare-and-swap
  47
  48 (defmacro defincf (name accessor &rest args)
  49   `(defun ,name (x)
  50      (let* ((old (,accessor x ,@args))
  51          (new (1+ old)))
  52     (loop until (eq old (sb-ext:compare-and-swap (,accessor x ,@args) old new))
  53        do (setf old (,accessor x ,@args)
  54                 new (1+ old)))
  55     new)))
  56
  57 (defstruct cas-struct (slot 0))
  58
  59 (defincf incf-car car)
  60 (defincf incf-cdr cdr)
  61 (defincf incf-slot cas-struct-slot)
  62 (defincf incf-symbol-value symbol-value)
  63 (defincf incf-svref/1 svref 1)
  64 (defincf incf-svref/0 svref 0)
  65
  66 (defmacro def-test-cas (name init incf op)
  67   `(progn
  68      (defun ,name (n)
  69        (declare (fixnum n))
  70        (let* ((x ,init)
  71               (run nil)
  72               (threads
  73                (loop repeat 10
  74                      collect (sb-thread:make-thread
  75                               (lambda ()
  76                                 (loop until run
  77                                    do (sb-thread:thread-yield))
  78                                 (loop repeat n do (,incf x)))))))
  79          (setf run t)
  80          (dolist (th threads)
  81            (sb-thread:join-thread th))
  82          (assert (= (,op x) (* 10 n)))))
  83      (,name 200000)))
  84
  85 (def-test-cas test-cas-car (cons 0 nil) incf-car car)
  86 (def-test-cas test-cas-cdr (cons nil 0) incf-cdr cdr)
  87 (def-test-cas test-cas-slot (make-cas-struct) incf-slot cas-struct-slot)
  88 (def-test-cas test-cas-value (let ((x '.x.))
  89                                (set x 0)
  90                                x)
  91   incf-symbol-value symbol-value)
  92 (def-test-cas test-cas-svref/0 (vector 0 nil) incf-svref/0 (lambda (x)
  93                                                              (svref x 0)))
  94 (def-test-cas test-cas-svref/1 (vector nil 0) incf-svref/1 (lambda (x)
  95                                                              (svref x 1)))
  96 (format t "~&compare-and-swap tests done~%")
  97
  98 (let ((old-threads (list-all-threads))
  99       (thread (make-thread (lambda ()
 100                              (assert (find *current-thread* *all-threads*))
 101                              (sleep 2))))
 102       (new-threads (list-all-threads)))
 103   (assert (thread-alive-p thread))
 104   (assert (eq thread (first new-threads)))
 105   (assert (= (1+ (length old-threads)) (length new-threads)))
 106   (sleep 3)
 107   (assert (not (thread-alive-p thread))))
 108
 109 (with-test (:name '(:join-thread :nlx :default))
 110   (let ((sym (gensym)))
 111     (assert (eq sym (join-thread (make-thread (lambda () (sb-ext:quit)))
 112                                  :default sym)))))
 113
 114 (with-test (:name '(:join-thread :nlx :error))
 115   (raises-error? (join-thread (make-thread (lambda () (sb-ext:quit))))))
 116
 117 (with-test (:name '(:join-thread :multiple-values))
 118   (assert (equal '(1 2 3)
 119                  (multiple-value-list
 120                   (join-thread (make-thread (lambda () (values 1 2 3))))))))
 121
 122 ;;; We had appalling scaling properties for a while.  Make sure they
 123 ;;; don't reappear.
 124 (defun scaling-test (function &optional (nthreads 5))
 125   "Execute FUNCTION with NTHREADS lurking to slow it down."
 126   (let ((queue (sb-thread:make-waitqueue))
 127         (mutex (sb-thread:make-mutex)))
 128     ;; Start NTHREADS idle threads.
 129     (dotimes (i nthreads)
 130       (sb-thread:make-thread (lambda ()
 131                                (with-mutex (mutex)
 132                                  (sb-thread:condition-wait queue mutex))
 133                                (sb-ext:quit))))
 134     (let ((start-time (get-internal-run-time)))
 135       (funcall function)
 136       (prog1 (- (get-internal-run-time) start-time)
 137         (sb-thread:condition-broadcast queue)))))
 138 (defun fact (n)
 139   "A function that does work with the CPU."
 140   (if (zerop n) 1 (* n (fact (1- n)))))
 141 (let ((work (lambda () (fact 15000))))
 142   (let ((zero (scaling-test work 0))
 143         (four (scaling-test work 4)))
 144     ;; a slightly weak assertion, but good enough for starters.
 145     (assert (< four (* 1.5 zero)))))
 146
 147 ;;; For one of the interupt-thread tests, we want a foreign function
 148 ;;; that does not make syscalls
 149
 150 (with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede)
 151   (format o "void loop_forever() { while(1) ; }~%"))
 152 (sb-ext:run-program
 153  #-sunos "cc" #+sunos "gcc"
 154  (or #+(or linux freebsd sunos) '(#+x86-64 "-fPIC"
 155                                   "-shared" "-o" "threads-foreign.so" "threads-foreign.c")
 156      #+darwin '(#+x86-64 "-arch" #+x86-64 "x86_64"
 157                 "-dynamiclib" "-o" "threads-foreign.so" "threads-foreign.c")
 158      (error "Missing shared library compilation options for this platform"))
 159  :search t)
 160 (sb-alien:load-shared-object "threads-foreign.so")
 161 (sb-alien:define-alien-routine loop-forever sb-alien:void)
 162 (delete-file "threads-foreign.c")
 163
 164 ;;; elementary "can we get a lock and release it again"
 165 (let ((l (make-mutex :name "foo"))
 166       (p *current-thread*))
 167   (assert (eql (mutex-value l) nil) nil "1")
 168   (sb-thread:get-mutex l)
 169   (assert (eql (mutex-value l) p) nil "3")
 170   (sb-thread:release-mutex l)
 171   (assert (eql (mutex-value l) nil) nil "5"))
 172
 173 (labels ((ours-p (value)
 174            (eq *current-thread* value)))
 175   (let ((l (make-mutex :name "rec")))
 176     (assert (eql (mutex-value l) nil) nil "1")
 177     (sb-thread:with-recursive-lock (l)
 178       (assert (ours-p (mutex-value l)) nil "3")
 179       (sb-thread:with-recursive-lock (l)
 180         (assert (ours-p (mutex-value l)) nil "4"))
 181       (assert (ours-p (mutex-value l)) nil "5"))
 182     (assert (eql (mutex-value l) nil) nil "6")))
 183
 184 (labels ((ours-p (value)
 185            (eq *current-thread* value)))
 186   (let ((l (make-spinlock :name "rec")))
 187     (assert (eql (spinlock-value l) nil) nil "1")
 188     (with-recursive-spinlock (l)
 189       (assert (ours-p (spinlock-value l)) nil "3")
 190       (with-recursive-spinlock (l)
 191         (assert (ours-p (spinlock-value l)) nil "4"))
 192       (assert (ours-p (spinlock-value l)) nil "5"))
 193     (assert (eql (spinlock-value l) nil) nil "6")))
 194
 195 (with-test (:name (:mutex :nesting-mutex-and-recursive-lock))
 196   (let ((l (make-mutex :name "a mutex")))
 197     (with-mutex (l)
 198       (with-recursive-lock (l)))))
 199
 200 (with-test (:name (:spinlock :nesting-spinlock-and-recursive-spinlock))
 201   (let ((l (make-spinlock :name "a spinlock")))
 202     (with-spinlock (l)
 203       (with-recursive-spinlock (l)))))
 204
 205 (let ((l (make-spinlock :name "spinlock")))
 206   (assert (eql (spinlock-value l) nil) ((spinlock-value l))
 207           "spinlock not free (1)")
 208   (with-spinlock (l)
 209     (assert (eql (spinlock-value l) *current-thread*) ((spinlock-value l))
 210             "spinlock not taken"))
 211   (assert (eql (spinlock-value l) nil) ((spinlock-value l))
 212           "spinlock not free (2)"))
 213
 214 ;; test that SLEEP actually sleeps for at least the given time, even
 215 ;; if interrupted by another thread exiting/a gc/anything
 216 (let ((start-time (get-universal-time)))
 217   (make-thread (lambda () (sleep 1) (sb-ext:gc :full t)))
 218   (sleep 5)
 219   (assert (>= (get-universal-time) (+ 5 start-time))))
 220
 221
 222 (let ((queue (make-waitqueue :name "queue"))
 223       (lock (make-mutex :name "lock"))
 224       (n 0))
 225   (labels ((in-new-thread ()
 226              (with-mutex (lock)
 227                (assert (eql (mutex-value lock) *current-thread*))
 228                (format t "~A got mutex~%" *current-thread*)
 229                ;; now drop it and sleep
 230                (condition-wait queue lock)
 231                ;; after waking we should have the lock again
 232                (assert (eql (mutex-value lock) *current-thread*))
 233                (assert (eql n 1))
 234                (decf n))))
 235     (make-thread #'in-new-thread)
 236     (sleep 2)                           ; give it  a chance to start
 237     ;; check the lock is free while it's asleep
 238     (format t "parent thread ~A~%" *current-thread*)
 239     (assert (eql (mutex-value lock) nil))
 240     (with-mutex (lock)
 241       (incf n)
 242       (condition-notify queue))
 243     (sleep 1)))
 244
 245 (let ((queue (make-waitqueue :name "queue"))
 246       (lock (make-mutex :name "lock")))
 247   (labels ((ours-p (value)
 248              (eq *current-thread* value))
 249            (in-new-thread ()
 250              (with-recursive-lock (lock)
 251                (assert (ours-p (mutex-value lock)))
 252                (format t "~A got mutex~%" (mutex-value lock))
 253                ;; now drop it and sleep
 254                (condition-wait queue lock)
 255                ;; after waking we should have the lock again
 256                (format t "woken, ~A got mutex~%" (mutex-value lock))
 257                (assert (ours-p (mutex-value lock))))))
 258     (make-thread #'in-new-thread)
 259     (sleep 2)                           ; give it  a chance to start
 260     ;; check the lock is free while it's asleep
 261     (format t "parent thread ~A~%" *current-thread*)
 262     (assert (eql (mutex-value lock) nil))
 263     (with-recursive-lock (lock)
 264       (condition-notify queue))
 265     (sleep 1)))
 266
 267 (let ((mutex (make-mutex :name "contended")))
 268   (labels ((run ()
 269              (let ((me *current-thread*))
 270                (dotimes (i 100)
 271                  (with-mutex (mutex)
 272                    (sleep .03)
 273                    (assert (eql (mutex-value mutex) me)))
 274                  (assert (not (eql (mutex-value mutex) me))))
 275                (format t "done ~A~%" *current-thread*))))
 276     (let ((kid1 (make-thread #'run))
 277           (kid2 (make-thread #'run)))
 278       (format t "contention ~A ~A~%" kid1 kid2)
 279       (wait-for-threads (list kid1 kid2)))))
 280
 281 ;;; semaphores
 282
 283 (defmacro raises-timeout-p (&body body)
 284   `(handler-case (progn (progn ,@body) nil)
 285     (sb-ext:timeout () t)))
 286
 287 (with-test (:name (:semaphore :wait-forever))
 288   (let ((sem (make-semaphore :count 0)))
 289     (assert (raises-timeout-p
 290               (sb-ext:with-timeout 0.1
 291                 (wait-on-semaphore sem))))))
 292
 293 (with-test (:name (:semaphore :initial-count))
 294   (let ((sem (make-semaphore :count 1)))
 295     (sb-ext:with-timeout 0.1
 296       (wait-on-semaphore sem))))
 297
 298 (with-test (:name (:semaphore :wait-then-signal))
 299   (let ((sem (make-semaphore))
 300         (signalled-p nil))
 301     (make-thread (lambda ()
 302                    (sleep 0.1)
 303                    (setq signalled-p t)
 304                    (signal-semaphore sem)))
 305     (wait-on-semaphore sem)
 306     (assert signalled-p)))
 307
 308 (with-test (:name (:semaphore :signal-then-wait))
 309   (let ((sem (make-semaphore))
 310         (signalled-p nil))
 311     (make-thread (lambda ()
 312                    (signal-semaphore sem)
 313                    (setq signalled-p t)))
 314     (loop until signalled-p)
 315     (wait-on-semaphore sem)
 316     (assert signalled-p)))
 317
 318 (with-test (:name (:semaphore :multiple-signals))
 319   (let* ((sem (make-semaphore :count 5))
 320          (threads (loop repeat 20
 321                         collect (make-thread (lambda ()
 322                                                (wait-on-semaphore sem))))))
 323     (flet ((count-live-threads ()
 324              (count-if #'thread-alive-p threads)))
 325       (sleep 0.5)
 326       (assert (= 15 (count-live-threads)))
 327       (signal-semaphore sem 10)
 328       (sleep 0.5)
 329       (assert (= 5 (count-live-threads)))
 330       (signal-semaphore sem 3)
 331       (sleep 0.5)
 332       (assert (= 2 (count-live-threads)))
 333       (signal-semaphore sem 4)
 334       (sleep 0.5)
 335       (assert (= 0 (count-live-threads))))))
 336
 337 (format t "~&semaphore tests done~%")
 338
 339 (defun test-interrupt (function-to-interrupt &optional quit-p)
 340   (let ((child  (make-thread function-to-interrupt)))
 341     ;;(format t "gdb ./src/runtime/sbcl ~A~%attach ~A~%" child child)
 342     (sleep 2)
 343     (format t "interrupting child ~A~%" child)
 344     (interrupt-thread child
 345                       (lambda ()
 346                         (format t "child pid ~A~%" *current-thread*)
 347                         (when quit-p (sb-ext:quit))))
 348     (sleep 1)
 349     child))
 350
 351 ;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
 352 ;; (d) waiting on a lock, (e) some code which we hope is likely to be
 353 ;; in pseudo-atomic
 354
 355 (let ((child (test-interrupt (lambda () (loop)))))  (terminate-thread child))
 356
 357 (test-interrupt #'loop-forever :quit)
 358
 359 (let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
 360   (terminate-thread child)
 361   (wait-for-threads (list child)))
 362
 363 (let ((lock (make-mutex :name "loctite"))
 364       child)
 365   (with-mutex (lock)
 366     (setf child (test-interrupt
 367                  (lambda ()
 368                    (with-mutex (lock)
 369                      (assert (eql (mutex-value lock) *current-thread*)))
 370                    (assert (not (eql (mutex-value lock) *current-thread*)))
 371                    (sleep 10))))
 372     ;;hold onto lock for long enough that child can't get it immediately
 373     (sleep 5)
 374     (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock))))
 375     (format t "parent releasing lock~%"))
 376   (terminate-thread child)
 377   (wait-for-threads (list child)))
 378
 379 (format t "~&locking test done~%")
 380
 381 (defun alloc-stuff () (copy-list '(1 2 3 4 5)))
 382
 383 (progn
 384   (let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff))))))
 385     (let ((killers
 386            (loop repeat 4 collect
 387                  (sb-thread:make-thread
 388                   (lambda ()
 389                     (loop repeat 25 do
 390                           (sleep (random 0.1d0))
 391                           (princ ".")
 392                           (force-output)
 393                           (sb-thread:interrupt-thread thread (lambda ()))))))))
 394       (wait-for-threads killers)
 395       (sb-thread:terminate-thread thread)
 396       (wait-for-threads (list thread))))
 397   (sb-ext:gc :full t))
 398
 399 (format t "~&multi interrupt test done~%")
 400
 401 (let ((c (make-thread (lambda () (loop (alloc-stuff))))))
 402   ;; NB this only works on x86: other ports don't have a symbol for
 403   ;; pseudo-atomic atomicity
 404   (dotimes (i 100)
 405     (sleep (random 0.1d0))
 406     (interrupt-thread c
 407                       (lambda ()
 408                         (princ ".") (force-output)
 409                         (assert (thread-alive-p *current-thread*))
 410                         (assert
 411                          (not (logbitp 0 SB-KERNEL:*PSEUDO-ATOMIC-BITS*))))))
 412   (terminate-thread c)
 413   (wait-for-threads (list c)))
 414
 415 (format t "~&interrupt test done~%")
 416
 417 (defparameter *interrupt-count* 0)
 418
 419 (declaim (notinline check-interrupt-count))
 420 (defun check-interrupt-count (i)
 421   (declare (optimize (debug 1) (speed 1)))
 422   ;; This used to lose if eflags were not restored after an interrupt.
 423   (unless (typep i 'fixnum)
 424     (error "!!!!!!!!!!!")))
 425
 426 (let ((c (make-thread
 427           (lambda ()
 428             (handler-bind ((error #'(lambda (cond)
 429                                       (princ cond)
 430                                       (sb-debug:backtrace
 431                                        most-positive-fixnum))))
 432               (loop (check-interrupt-count *interrupt-count*)))))))
 433   (let ((func (lambda ()
 434                 (princ ".")
 435                 (force-output)
 436                 (sb-impl::atomic-incf/symbol *interrupt-count*))))
 437     (setq *interrupt-count* 0)
 438     (dotimes (i 100)
 439       (sleep (random 0.1d0))
 440       (interrupt-thread c func))
 441     (loop until (= *interrupt-count* 100) do (sleep 0.1))
 442     (terminate-thread c)
 443     (wait-for-threads (list c))))
 444
 445 (format t "~&interrupt count test done~%")
 446
 447 (let (a-done b-done)
 448   (make-thread (lambda ()
 449                  (dotimes (i 100)
 450                    (sb-ext:gc) (princ "\\") (force-output))
 451                  (setf a-done t)))
 452   (make-thread (lambda ()
 453                  (dotimes (i 25)
 454                    (sb-ext:gc :full t)
 455                    (princ "/") (force-output))
 456                  (setf b-done t)))
 457   (loop
 458    (when (and a-done b-done) (return))
 459    (sleep 1)))
 460
 461 (terpri)
 462
 463 (defun waste (&optional (n 100000))
 464   (loop repeat n do (make-string 16384)))
 465
 466 (loop for i below 100 do
 467       (princ "!")
 468       (force-output)
 469       (sb-thread:make-thread
 470        #'(lambda ()
 471            (waste)))
 472       (waste)
 473       (sb-ext:gc))
 474
 475 (terpri)
 476
 477 (defparameter *aaa* nil)
 478 (loop for i below 100 do
 479       (princ "!")
 480       (force-output)
 481       (sb-thread:make-thread
 482        #'(lambda ()
 483            (let ((*aaa* (waste)))
 484              (waste))))
 485       (let ((*aaa* (waste)))
 486         (waste))
 487       (sb-ext:gc))
 488
 489 (format t "~&gc test done~%")
 490
 491 ;; this used to deadlock on session-lock
 492 (sb-thread:make-thread (lambda () (sb-ext:gc)))
 493 ;; expose thread creation races by exiting quickly
 494 (sb-thread:make-thread (lambda ()))
 495
 496 (defun exercise-syscall (fn reference-errno)
 497   (sb-thread:make-thread
 498    (lambda ()
 499      (loop do
 500           (funcall fn)
 501           (let ((errno (sb-unix::get-errno)))
 502             (sleep (random 0.1d0))
 503             (unless (eql errno reference-errno)
 504               (format t "Got errno: ~A (~A) instead of ~A~%"
 505                       errno
 506                       (sb-unix::strerror)
 507                       reference-errno)
 508               (force-output)
 509               (sb-ext:quit :unix-status 1)))))))
 510
 511 ;; (nanosleep -1 0) does not fail on FreeBSD
 512 (let* (#-freebsd
 513        (nanosleep-errno (progn
 514                           (sb-unix:nanosleep -1 0)
 515                           (sb-unix::get-errno)))
 516        (open-errno (progn
 517                      (open "no-such-file"
 518                            :if-does-not-exist nil)
 519                      (sb-unix::get-errno)))
 520        (threads
 521         (list
 522          #-freebsd
 523          (exercise-syscall (lambda () (sb-unix:nanosleep -1 0)) nanosleep-errno)
 524          (exercise-syscall (lambda () (open "no-such-file"
 525                                             :if-does-not-exist nil))
 526                            open-errno)
 527          (sb-thread:make-thread (lambda () (loop (sb-ext:gc) (sleep 1)))))))
 528   (sleep 10)
 529   (princ "terminating threads")
 530   (dolist (thread threads)
 531     (sb-thread:terminate-thread thread)))
 532
 533 (format t "~&errno test done~%")
 534
 535 (loop repeat 100 do
 536       (let ((thread (sb-thread:make-thread (lambda () (sleep 0.1)))))
 537         (sb-thread:interrupt-thread
 538          thread
 539          (lambda ()
 540            (assert (find-restart 'sb-thread:terminate-thread))))))
 541
 542 (sb-ext:gc :full t)
 543
 544 (format t "~&thread startup sigmask test done~%")
 545
 546 ;; FIXME: What is this supposed to test?
 547 (sb-debug::enable-debugger)
 548 (let* ((main-thread *current-thread*)
 549        (interruptor-thread
 550         (make-thread (lambda ()
 551                        (sleep 2)
 552                        (interrupt-thread main-thread #'break)
 553                        (sleep 2)
 554                        (interrupt-thread main-thread #'continue))
 555                      :name "interruptor")))
 556   (with-session-lock (*session*)
 557     (sleep 3))
 558   (loop while (thread-alive-p interruptor-thread)))
 559
 560 (format t "~&session lock test done~%")
 561
 562 (loop repeat 20 do
 563       (wait-for-threads
 564        (loop for i below 100 collect
 565              (sb-thread:make-thread (lambda ())))))
 566
 567 (format t "~&creation test done~%")
 568
 569 ;; interrupt handlers are per-thread with pthreads, make sure the
 570 ;; handler installed in one thread is global
 571 (sb-thread:make-thread
 572  (lambda ()
 573    (sb-ext:run-program "sleep" '("1") :search t :wait nil)))
 574
 575 ;;;; Binding stack safety
 576
 577 (defparameter *x* nil)
 578 (defparameter *n-gcs-requested* 0)
 579 (defparameter *n-gcs-done* 0)
 580
 581 (let ((counter 0))
 582   (defun make-something-big ()
 583     (let ((x (make-string 32000)))
 584       (incf counter)
 585       (let ((counter counter))
 586         (sb-ext:finalize x (lambda () (format t " ~S" counter)
 587                                    (force-output)))))))
 588
 589 (defmacro wait-for-gc ()
 590   `(progn
 591      (incf *n-gcs-requested*)
 592      (loop while (< *n-gcs-done* *n-gcs-requested*))))
 593
 594 (defun send-gc ()
 595   (loop until (< *n-gcs-done* *n-gcs-requested*))
 596   (format t "G")
 597   (force-output)
 598   (sb-ext:gc)
 599   (incf *n-gcs-done*))
 600
 601 (defun exercise-binding ()
 602   (loop
 603    (let ((*x* (make-something-big)))
 604      (let ((*x* 42))
 605        ;; at this point the binding stack looks like this:
 606        ;; NO-TLS-VALUE-MARKER, *x*, SOMETHING, *x*
 607        t))
 608    (wait-for-gc)
 609    ;; sig_stop_for_gc_handler binds FREE_INTERRUPT_CONTEXT_INDEX. By
 610    ;; now SOMETHING is gc'ed and the binding stack looks like this: 0,
 611    ;; 0, SOMETHING, 0 (because the symbol slots are zeroed on
 612    ;; unbinding but values are not).
 613    (let ((*x* nil))
 614      ;; bump bsp as if a BIND had just started
 615      (incf sb-vm::*binding-stack-pointer* 2)
 616      (wait-for-gc)
 617      (decf sb-vm::*binding-stack-pointer* 2))))
 618
 619 (with-test (:name (:binding-stack-gc-safety))
 620   (let (threads)
 621     (unwind-protect
 622          (progn
 623            (push (sb-thread:make-thread #'exercise-binding) threads)
 624            (push (sb-thread:make-thread (lambda ()
 625                                           (loop
 626                                            (sleep 0.1)
 627                                            (send-gc))))
 628                  threads)
 629            (sleep 4))
 630       (mapc #'sb-thread:terminate-thread threads))))
 631
 632 (format t "~&binding test done~%")
 633
 634 ;; Try to corrupt the NEXT-VECTOR. Operations on a hash table with a
 635 ;; cyclic NEXT-VECTOR can loop endlessly in a WITHOUT-GCING form
 636 ;; causing the next gc hang SBCL.
 637 (with-test (:name (:hash-table-thread-safety))
 638   (let* ((hash (make-hash-table))
 639          (threads (list (sb-thread:make-thread
 640                          (lambda ()
 641                            (loop
 642                             ;;(princ "1") (force-output)
 643                             (setf (gethash (random 100) hash) 'h))))
 644                         (sb-thread:make-thread
 645                          (lambda ()
 646                            (loop
 647                             ;;(princ "2") (force-output)
 648                             (remhash (random 100) hash))))
 649                         (sb-thread:make-thread
 650                          (lambda ()
 651                            (loop
 652                             (sleep (random 1.0))
 653                             (sb-ext:gc :full t)))))))
 654     (unwind-protect
 655          (sleep 5)
 656       (mapc #'sb-thread:terminate-thread threads))))
 657
 658 (format t "~&hash table test done~%")
 659 #|  ;; a cll post from eric marsden
 660 | (defun crash ()
 661 |   (setq *debugger-hook*
 662 |         (lambda (condition old-debugger-hook)
 663 |           (debug:backtrace 10)
 664 |           (unix:unix-exit 2)))
 665 |   #+live-dangerously
 666 |   (mp::start-sigalrm-yield)
 667 |   (flet ((roomy () (loop (with-output-to-string (*standard-output*) (room)))))
 668 |     (mp:make-process #'roomy)
 669 |     (mp:make-process #'roomy)))
 670 |#
 671
 672 (with-test (:name (:condition-variable :notify-multiple))
 673   (flet ((tester (notify-fun)
 674            (let ((queue (make-waitqueue :name "queue"))
 675                  (lock (make-mutex :name "lock"))
 676                  (data nil))
 677              (labels ((test (x)
 678                         (loop
 679                            (with-mutex (lock)
 680                              (format t "condition-wait ~a~%" x)
 681                              (force-output)
 682                              (condition-wait queue lock)
 683                              (format t "woke up ~a~%" x)
 684                              (force-output)
 685                              (push x data)))))
 686                (let ((threads (loop for x from 1 to 10
 687                                     collect
 688                                     (let ((x x))
 689                                       (sb-thread:make-thread (lambda ()
 690                                                                (test x)))))))
 691                  (sleep 5)
 692                  (with-mutex (lock)
 693                    (funcall notify-fun queue))
 694                  (sleep 5)
 695                  (mapcar #'terminate-thread threads)
 696                  ;; Check that all threads woke up at least once
 697                  (assert (= (length (remove-duplicates data)) 10)))))))
 698     (tester (lambda (queue)
 699               (format t "~&(condition-notify queue 10)~%")
 700               (force-output)
 701               (condition-notify queue 10)))
 702     (tester (lambda (queue)
 703               (format t "~&(condition-broadcast queue)~%")
 704               (force-output)
 705               (condition-broadcast queue)))))
 706
 707 (format t "waitqueue wakeup tests done~%")
 708
 709 (with-test (:name (:mutex :finalization))
 710   (let ((a nil))
 711     (dotimes (i 500000)
 712       (setf a (make-mutex)))))
 713
 714 (format t "mutex finalization test done~%")
 715
 716 ;;; Check that INFO is thread-safe, at least when we're just doing reads.
 717
 718 (let* ((symbols (loop repeat 10000 collect (gensym)))
 719        (functions (loop for (symbol . rest) on symbols
 720                         for next = (car rest)
 721                         for fun = (let ((next next))
 722                                     (lambda (n)
 723                                       (if next
 724                                           (funcall next (1- n))
 725                                           n)))
 726                         do (setf (symbol-function symbol) fun)
 727                         collect fun)))
 728   (defun infodb-test ()
 729     (funcall (car functions) 9999)))
 730
 731 (with-test (:name (:infodb :read))
 732   (let* ((ok t)
 733          (threads (loop for i from 0 to 10
 734                         collect (sb-thread:make-thread
 735                                  (lambda ()
 736                                    (dotimes (j 100)
 737                                      (write-char #\-)
 738                                      (finish-output)
 739                                      (let ((n (infodb-test)))
 740                                        (unless (zerop n)
 741                                          (setf ok nil)
 742                                          (format t "N != 0 (~A)~%" n)
 743                                          (sb-ext:quit)))))))))
 744     (wait-for-threads threads)
 745     (assert ok)))
 746
 747 (format t "infodb test done~%")
 748
 749 (with-test (:name (:backtrace))
 750   ;; Printing backtraces from several threads at once used to hang the
 751   ;; whole SBCL process (discovered by accident due to a timer.impure
 752   ;; test misbehaving). The cause was that packages weren't even
 753   ;; thread-safe for only doing FIND-SYMBOL, and while printing
 754   ;; backtraces a loot of symbol lookups need to be done due to
 755   ;; *PRINT-ESCAPE*.
 756   (let* ((threads (loop repeat 10
 757                         collect (sb-thread:make-thread
 758                                  (lambda ()
 759                                    (dotimes (i 1000)
 760                                      (with-output-to-string (*debug-io*)
 761                                        (sb-debug::backtrace 10))))))))
 762     (wait-for-threads threads)))
 763
 764 (format t "backtrace test done~%")
 765
 766 (format t "~&starting gc deadlock test: WARNING: THIS TEST WILL HANG ON FAILURE!~%")
 767
 768 (with-test (:name (:gc-deadlock))
 769   ;; Prior to 0.9.16.46 thread exit potentially deadlocked the
 770   ;; GC due to *all-threads-lock* and session lock. On earlier
 771   ;; versions and at least on one specific box this test is good enough
 772   ;; to catch that typically well before the 1500th iteration.
 773   (loop
 774      with i = 0
 775      with n = 3000
 776      while (< i n)
 777      do
 778        (incf i)
 779        (when (zerop (mod i 100))
 780          (write-char #\.)
 781          (force-output))
 782        (handler-case
 783            (if (oddp i)
 784                (sb-thread:make-thread
 785                 (lambda ()
 786                   (sleep (random 0.001)))
 787                 :name (list :sleep i))
 788                (sb-thread:make-thread
 789                 (lambda ()
 790                   ;; KLUDGE: what we are doing here is explicit,
 791                   ;; but the same can happen because of a regular
 792                   ;; MAKE-THREAD or LIST-ALL-THREADS, and various
 793                   ;; session functions.
 794                   (sb-thread:with-mutex (sb-thread::*all-threads-lock*)
 795                     (sb-thread::with-session-lock (sb-thread::*session*)
 796                       (sb-ext:gc))))
 797                 :name (list :gc i)))
 798          (error (e)
 799            (format t "~%error creating thread ~D: ~A -- backing off for retry~%" i e)
 800            (sleep 0.1)
 801            (incf i)))))
 802
 803 (format t "~&gc deadlock test done~%")
 804 \f
 805 (let ((count (make-array 8 :initial-element 0)))
 806   (defun closure-one ()
 807     (declare (optimize safety))
 808     (values (incf (aref count 0)) (incf (aref count 1))
 809             (incf (aref count 2)) (incf (aref count 3))
 810             (incf (aref count 4)) (incf (aref count 5))
 811             (incf (aref count 6)) (incf (aref count 7))))
 812   (defun no-optimizing-away-closure-one ()
 813     (setf count (make-array 8 :initial-element 0))))
 814
 815 (defstruct box
 816   (count 0))
 817
 818 (let ((one (make-box))
 819       (two (make-box))
 820       (three (make-box)))
 821   (defun closure-two ()
 822     (declare (optimize safety))
 823     (values (incf (box-count one)) (incf (box-count two)) (incf (box-count three))))
 824   (defun no-optimizing-away-closure-two ()
 825     (setf one (make-box)
 826           two (make-box)
 827           three (make-box))))
 828
 829 (with-test (:name (:funcallable-instances))
 830   ;; the funcallable-instance implementation used not to be threadsafe
 831   ;; against setting the funcallable-instance function to a closure
 832   ;; (because the code and lexenv were set separately).
 833   (let ((fun (sb-kernel:%make-funcallable-instance 0))
 834         (condition nil))
 835     (setf (sb-kernel:funcallable-instance-fun fun) #'closure-one)
 836     (flet ((changer ()
 837              (loop (setf (sb-kernel:funcallable-instance-fun fun) #'closure-one)
 838                    (setf (sb-kernel:funcallable-instance-fun fun) #'closure-two)))
 839            (test ()
 840              (handler-case (loop (funcall fun))
 841                (serious-condition (c) (setf condition c)))))
 842       (let ((changer (make-thread #'changer))
 843             (test (make-thread #'test)))
 844         (handler-case
 845             (progn
 846               ;; The two closures above are fairly carefully crafted
 847               ;; so that if given the wrong lexenv they will tend to
 848               ;; do some serious damage, but it is of course difficult
 849               ;; to predict where the various bits and pieces will be
 850               ;; allocated.  Five seconds failed fairly reliably on
 851               ;; both my x86 and x86-64 systems.  -- CSR, 2006-09-27.
 852               (sb-ext:with-timeout 5
 853                 (wait-for-threads (list test)))
 854               (error "~@<test thread got condition:~2I~_~A~@:>" condition))
 855           (sb-ext:timeout ()
 856             (terminate-thread changer)
 857             (terminate-thread test)
 858             (wait-for-threads (list changer test))))))))
 859
 860 (format t "~&funcallable-instance test done~%")
 861
 862 (defun random-type (n)
 863   `(integer ,(random n) ,(+ n (random n))))
 864
 865 (defun subtypep-hash-cache-test ()
 866   (dotimes (i 10000)
 867     (let ((type1 (random-type 500))
 868           (type2 (random-type 500)))
 869       (let ((a (subtypep type1 type2)))
 870         (dotimes (i 100)
 871           (assert (eq (subtypep type1 type2) a))))))
 872   (format t "ok~%")
 873   (force-output))
 874
 875 (with-test (:name '(:hash-cache :subtypep))
 876   (dotimes (i 10)
 877     (sb-thread:make-thread #'subtypep-hash-cache-test)))
 878
 879 (format t "hash-cache tests done~%")