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 (truename "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 ;;; HASH TABLES
 635
 636 (defvar *errors* nil)
 637
 638 (defun oops (e)
 639   (setf *errors* e)
 640   (format t "~&oops: ~A in ~S~%" e *current-thread*)
 641   (sb-debug:backtrace)
 642   (catch 'done))
 643
 644 (with-test (:name (:unsynchronized-hash-table))
 645   ;; We expect a (probable) error here: parellel readers and writers
 646   ;; on a hash-table are not expected to work -- but we also don't
 647   ;; expect this to corrupt the image.
 648   (let* ((hash (make-hash-table))
 649          (*errors* nil)
 650          (threads (list (sb-thread:make-thread
 651                          (lambda ()
 652                            (catch 'done
 653                              (handler-bind ((serious-condition 'oops))
 654                                (loop
 655                                  ;;(princ "1") (force-output)
 656                                  (setf (gethash (random 100) hash) 'h)))))
 657                          :name "writer")
 658                         (sb-thread:make-thread
 659                          (lambda ()
 660                            (catch 'done
 661                              (handler-bind ((serious-condition 'oops))
 662                                (loop
 663                                  ;;(princ "2") (force-output)
 664                                  (remhash (random 100) hash)))))
 665                          :name "reader")
 666                         (sb-thread:make-thread
 667                          (lambda ()
 668                            (catch 'done
 669                              (handler-bind ((serious-condition 'oops))
 670                                (loop
 671                                  (sleep (random 1.0))
 672                                  (sb-ext:gc :full t)))))
 673                          :name "collector"))))
 674     (unwind-protect
 675          (sleep 10)
 676       (mapc #'sb-thread:terminate-thread threads))))
 677
 678 (format t "~&unsynchronized hash table test done~%")
 679
 680 (with-test (:name (:synchronized-hash-table))
 681   (let* ((hash (make-hash-table :synchronized t))
 682          (*errors* nil)
 683          (threads (list (sb-thread:make-thread
 684                          (lambda ()
 685                            (catch 'done
 686                              (handler-bind ((serious-condition 'oops))
 687                                (loop
 688                                  ;;(princ "1") (force-output)
 689                                  (setf (gethash (random 100) hash) 'h)))))
 690                          :name "writer")
 691                         (sb-thread:make-thread
 692                          (lambda ()
 693                            (catch 'done
 694                              (handler-bind ((serious-condition 'oops))
 695                                (loop
 696                                  ;;(princ "2") (force-output)
 697                                  (remhash (random 100) hash)))))
 698                          :name "reader")
 699                         (sb-thread:make-thread
 700                          (lambda ()
 701                            (catch 'done
 702                              (handler-bind ((serious-condition 'oops))
 703                                (loop
 704                                  (sleep (random 1.0))
 705                                  (sb-ext:gc :full t)))))
 706                          :name "collector"))))
 707     (unwind-protect
 708          (sleep 10)
 709       (mapc #'sb-thread:terminate-thread threads))
 710     (assert (not *errors*))))
 711
 712 (format t "~&synchronized hash table test done~%")
 713
 714 (with-test (:name (:hash-table-parallel-readers))
 715   (let ((hash (make-hash-table))
 716         (*errors* nil))
 717     (loop repeat 50
 718           do (setf (gethash (random 100) hash) 'xxx))
 719     (let ((threads (list (sb-thread:make-thread
 720                           (lambda ()
 721                             (catch 'done
 722                               (handler-bind ((serious-condition 'oops))
 723                                 (loop
 724                                       until (eq t (gethash (random 100) hash))))))
 725                           :name "reader 1")
 726                          (sb-thread:make-thread
 727                           (lambda ()
 728                             (catch 'done
 729                               (handler-bind ((serious-condition 'oops))
 730                                 (loop
 731                                       until (eq t (gethash (random 100) hash))))))
 732                           :name "reader 2")
 733                          (sb-thread:make-thread
 734                           (lambda ()
 735                             (catch 'done
 736                               (handler-bind ((serious-condition 'oops))
 737                                 (loop
 738                                       until (eq t (gethash (random 100) hash))))))
 739                           :name "reader 3")
 740                          (sb-thread:make-thread
 741                           (lambda ()
 742                             (catch 'done
 743                               (handler-bind ((serious-condition 'oops))
 744                                (loop
 745                                  (sleep (random 1.0))
 746                                  (sb-ext:gc :full t)))))
 747                           :name "collector"))))
 748       (unwind-protect
 749            (sleep 10)
 750         (mapc #'sb-thread:terminate-thread threads))
 751       (assert (not *errors*)))))
 752
 753 (format t "~&multiple reader hash table test done~%")
 754
 755 (with-test (:name (:hash-table-single-accessor-parallel-gc))
 756   (let ((hash (make-hash-table))
 757         (*errors* nil))
 758     (let ((threads (list (sb-thread:make-thread
 759                           (lambda ()
 760                             (handler-bind ((serious-condition 'oops))
 761                               (loop
 762                                 (let ((n (random 100)))
 763                                   (if (gethash n hash)
 764                                       (remhash n hash)
 765                                       (setf (gethash n hash) 'h))))))
 766                           :name "accessor")
 767                          (sb-thread:make-thread
 768                           (lambda ()
 769                             (handler-bind ((serious-condition 'oops))
 770                               (loop
 771                                 (sleep (random 1.0))
 772                                 (sb-ext:gc :full t))))
 773                           :name "collector"))))
 774       (unwind-protect
 775            (sleep 10)
 776         (mapc #'sb-thread:terminate-thread threads))
 777       (assert (not *errors*)))))
 778
 779 (format t "~&single accessor hash table test~%")
 780
 781 #|  ;; a cll post from eric marsden
 782 | (defun crash ()
 783 |   (setq *debugger-hook*
 784 |         (lambda (condition old-debugger-hook)
 785 |           (debug:backtrace 10)
 786 |           (unix:unix-exit 2)))
 787 |   #+live-dangerously
 788 |   (mp::start-sigalrm-yield)
 789 |   (flet ((roomy () (loop (with-output-to-string (*standard-output*) (room)))))
 790 |     (mp:make-process #'roomy)
 791 |     (mp:make-process #'roomy)))
 792 |#
 793
 794 (with-test (:name (:condition-variable :notify-multiple))
 795   (flet ((tester (notify-fun)
 796            (let ((queue (make-waitqueue :name "queue"))
 797                  (lock (make-mutex :name "lock"))
 798                  (data nil))
 799              (labels ((test (x)
 800                         (loop
 801                            (with-mutex (lock)
 802                              (format t "condition-wait ~a~%" x)
 803                              (force-output)
 804                              (condition-wait queue lock)
 805                              (format t "woke up ~a~%" x)
 806                              (force-output)
 807                              (push x data)))))
 808                (let ((threads (loop for x from 1 to 10
 809                                     collect
 810                                     (let ((x x))
 811                                       (sb-thread:make-thread (lambda ()
 812                                                                (test x)))))))
 813                  (sleep 5)
 814                  (with-mutex (lock)
 815                    (funcall notify-fun queue))
 816                  (sleep 5)
 817                  (mapcar #'terminate-thread threads)
 818                  ;; Check that all threads woke up at least once
 819                  (assert (= (length (remove-duplicates data)) 10)))))))
 820     (tester (lambda (queue)
 821               (format t "~&(condition-notify queue 10)~%")
 822               (force-output)
 823               (condition-notify queue 10)))
 824     (tester (lambda (queue)
 825               (format t "~&(condition-broadcast queue)~%")
 826               (force-output)
 827               (condition-broadcast queue)))))
 828
 829 (format t "waitqueue wakeup tests done~%")
 830
 831 (with-test (:name (:mutex :finalization))
 832   (let ((a nil))
 833     (dotimes (i 500000)
 834       (setf a (make-mutex)))))
 835
 836 (format t "mutex finalization test done~%")
 837
 838 ;;; Check that INFO is thread-safe, at least when we're just doing reads.
 839
 840 (let* ((symbols (loop repeat 10000 collect (gensym)))
 841        (functions (loop for (symbol . rest) on symbols
 842                         for next = (car rest)
 843                         for fun = (let ((next next))
 844                                     (lambda (n)
 845                                       (if next
 846                                           (funcall next (1- n))
 847                                           n)))
 848                         do (setf (symbol-function symbol) fun)
 849                         collect fun)))
 850   (defun infodb-test ()
 851     (funcall (car functions) 9999)))
 852
 853 (with-test (:name (:infodb :read))
 854   (let* ((ok t)
 855          (threads (loop for i from 0 to 10
 856                         collect (sb-thread:make-thread
 857                                  (lambda ()
 858                                    (dotimes (j 100)
 859                                      (write-char #\-)
 860                                      (finish-output)
 861                                      (let ((n (infodb-test)))
 862                                        (unless (zerop n)
 863                                          (setf ok nil)
 864                                          (format t "N != 0 (~A)~%" n)
 865                                          (sb-ext:quit)))))))))
 866     (wait-for-threads threads)
 867     (assert ok)))
 868
 869 (format t "infodb test done~%")
 870
 871 (with-test (:name (:backtrace))
 872   ;; Printing backtraces from several threads at once used to hang the
 873   ;; whole SBCL process (discovered by accident due to a timer.impure
 874   ;; test misbehaving). The cause was that packages weren't even
 875   ;; thread-safe for only doing FIND-SYMBOL, and while printing
 876   ;; backtraces a loot of symbol lookups need to be done due to
 877   ;; *PRINT-ESCAPE*.
 878   (let* ((threads (loop repeat 10
 879                         collect (sb-thread:make-thread
 880                                  (lambda ()
 881                                    (dotimes (i 1000)
 882                                      (with-output-to-string (*debug-io*)
 883                                        (sb-debug::backtrace 10))))))))
 884     (wait-for-threads threads)))
 885
 886 (format t "backtrace test done~%")
 887
 888 (format t "~&starting gc deadlock test: WARNING: THIS TEST WILL HANG ON FAILURE!~%")
 889
 890 (with-test (:name (:gc-deadlock))
 891   ;; Prior to 0.9.16.46 thread exit potentially deadlocked the
 892   ;; GC due to *all-threads-lock* and session lock. On earlier
 893   ;; versions and at least on one specific box this test is good enough
 894   ;; to catch that typically well before the 1500th iteration.
 895   (loop
 896      with i = 0
 897      with n = 3000
 898      while (< i n)
 899      do
 900        (incf i)
 901        (when (zerop (mod i 100))
 902          (write-char #\.)
 903          (force-output))
 904        (handler-case
 905            (if (oddp i)
 906                (sb-thread:make-thread
 907                 (lambda ()
 908                   (sleep (random 0.001)))
 909                 :name (list :sleep i))
 910                (sb-thread:make-thread
 911                 (lambda ()
 912                   ;; KLUDGE: what we are doing here is explicit,
 913                   ;; but the same can happen because of a regular
 914                   ;; MAKE-THREAD or LIST-ALL-THREADS, and various
 915                   ;; session functions.
 916                   (sb-thread:with-mutex (sb-thread::*all-threads-lock*)
 917                     (sb-thread::with-session-lock (sb-thread::*session*)
 918                       (sb-ext:gc))))
 919                 :name (list :gc i)))
 920          (error (e)
 921            (format t "~%error creating thread ~D: ~A -- backing off for retry~%" i e)
 922            (sleep 0.1)
 923            (incf i)))))
 924
 925 (format t "~&gc deadlock test done~%")
 926 \f
 927 (let ((count (make-array 8 :initial-element 0)))
 928   (defun closure-one ()
 929     (declare (optimize safety))
 930     (values (incf (aref count 0)) (incf (aref count 1))
 931             (incf (aref count 2)) (incf (aref count 3))
 932             (incf (aref count 4)) (incf (aref count 5))
 933             (incf (aref count 6)) (incf (aref count 7))))
 934   (defun no-optimizing-away-closure-one ()
 935     (setf count (make-array 8 :initial-element 0))))
 936
 937 (defstruct box
 938   (count 0))
 939
 940 (let ((one (make-box))
 941       (two (make-box))
 942       (three (make-box)))
 943   (defun closure-two ()
 944     (declare (optimize safety))
 945     (values (incf (box-count one)) (incf (box-count two)) (incf (box-count three))))
 946   (defun no-optimizing-away-closure-two ()
 947     (setf one (make-box)
 948           two (make-box)
 949           three (make-box))))
 950
 951 (with-test (:name (:funcallable-instances))
 952   ;; the funcallable-instance implementation used not to be threadsafe
 953   ;; against setting the funcallable-instance function to a closure
 954   ;; (because the code and lexenv were set separately).
 955   (let ((fun (sb-kernel:%make-funcallable-instance 0))
 956         (condition nil))
 957     (setf (sb-kernel:funcallable-instance-fun fun) #'closure-one)
 958     (flet ((changer ()
 959              (loop (setf (sb-kernel:funcallable-instance-fun fun) #'closure-one)
 960                    (setf (sb-kernel:funcallable-instance-fun fun) #'closure-two)))
 961            (test ()
 962              (handler-case (loop (funcall fun))
 963                (serious-condition (c) (setf condition c)))))
 964       (let ((changer (make-thread #'changer))
 965             (test (make-thread #'test)))
 966         (handler-case
 967             (progn
 968               ;; The two closures above are fairly carefully crafted
 969               ;; so that if given the wrong lexenv they will tend to
 970               ;; do some serious damage, but it is of course difficult
 971               ;; to predict where the various bits and pieces will be
 972               ;; allocated.  Five seconds failed fairly reliably on
 973               ;; both my x86 and x86-64 systems.  -- CSR, 2006-09-27.
 974               (sb-ext:with-timeout 5
 975                 (wait-for-threads (list test)))
 976               (error "~@<test thread got condition:~2I~_~A~@:>" condition))
 977           (sb-ext:timeout ()
 978             (terminate-thread changer)
 979             (terminate-thread test)
 980             (wait-for-threads (list changer test))))))))
 981
 982 (format t "~&funcallable-instance test done~%")
 983
 984 (defun random-type (n)
 985   `(integer ,(random n) ,(+ n (random n))))
 986
 987 (defun subtypep-hash-cache-test ()
 988   (dotimes (i 10000)
 989     (let ((type1 (random-type 500))
 990           (type2 (random-type 500)))
 991       (let ((a (subtypep type1 type2)))
 992         (dotimes (i 100)
 993           (assert (eq (subtypep type1 type2) a))))))
 994   (format t "ok~%")
 995   (force-output))
 996
 997 (with-test (:name '(:hash-cache :subtypep))
 998   (dotimes (i 10)
 999     (sb-thread:make-thread #'subtypep-hash-cache-test)))
1000
1001 (format t "hash-cache tests done~%")