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 ; WHITE-BOX TESTS
  15
  16 (in-package "SB-THREAD")
  17 (use-package :test-util)
  18 (use-package "ASSERTOID")
  19
  20 (setf sb-unix::*on-dangerous-wait* :error)
  21
  22 (defun wait-for-threads (threads)
  23   (mapc (lambda (thread) (sb-thread:join-thread thread :default nil)) threads)
  24   (assert (not (some #'sb-thread:thread-alive-p threads))))
  25
  26 (with-test (:name (:threads :trivia))
  27   (assert (eql 1 (length (list-all-threads))))
  28
  29   (assert (eq *current-thread*
  30               (find (thread-name *current-thread*) (list-all-threads)
  31                     :key #'thread-name :test #'equal)))
  32
  33   (assert (thread-alive-p *current-thread*)))
  34
  35 (with-test (:name (:with-mutex :basics))
  36   (let ((mutex (make-mutex)))
  37     (with-mutex (mutex)
  38       mutex)))
  39
  40 (with-test (:name (:with-spinlock :basics))
  41   (let ((spinlock (make-spinlock)))
  42     (with-spinlock (spinlock))))
  43
  44 (sb-alien:define-alien-routine "check_deferrables_blocked_or_lose"
  45     void
  46   (where sb-alien:unsigned-long))
  47 (sb-alien:define-alien-routine "check_deferrables_unblocked_or_lose"
  48     void
  49   (where sb-alien:unsigned-long))
  50
  51 (with-test (:name (:interrupt-thread :basics :no-unwinding))
  52   (let ((a 0))
  53     (interrupt-thread *current-thread* (lambda () (setq a 1)))
  54     (assert (eql a 1))))
  55
  56 (with-test (:name (:interrupt-thread :deferrables-blocked))
  57   (sb-thread:interrupt-thread sb-thread:*current-thread*
  58                               (lambda ()
  59                                 (check-deferrables-blocked-or-lose 0))))
  60
  61 (with-test (:name (:interrupt-thread :deferrables-unblocked))
  62   (sb-thread:interrupt-thread sb-thread:*current-thread*
  63                               (lambda ()
  64                                 (with-interrupts
  65                                   (check-deferrables-unblocked-or-lose 0)))))
  66
  67 (with-test (:name (:interrupt-thread :nlx))
  68   (catch 'xxx
  69     (sb-thread:interrupt-thread sb-thread:*current-thread*
  70                                 (lambda ()
  71                                   (check-deferrables-blocked-or-lose 0)
  72                                   (throw 'xxx nil))))
  73   (check-deferrables-unblocked-or-lose 0))
  74
  75 #-sb-thread (sb-ext:quit :unix-status 104)
  76
  77 ;;;; Now the real tests...
  78
  79 (with-test (:name (:interrupt-thread :deferrables-unblocked-by-spinlock))
  80   (let ((spinlock (sb-thread::make-spinlock))
  81         (thread (sb-thread:make-thread (lambda ()
  82                                          (loop (sleep 1))))))
  83     (sb-thread::get-spinlock spinlock)
  84     (sb-thread:interrupt-thread thread
  85                                 (lambda ()
  86                                   (check-deferrables-blocked-or-lose 0)
  87                                   (sb-thread::get-spinlock spinlock)
  88                                   (check-deferrables-unblocked-or-lose 0)
  89                                   (sb-ext:quit)))
  90     (sleep 1)
  91     (sb-thread::release-spinlock spinlock)))
  92
  93 ;;; compare-and-swap
  94
  95 (defmacro defincf (name accessor &rest args)
  96   `(defun ,name (x)
  97      (let* ((old (,accessor x ,@args))
  98          (new (1+ old)))
  99     (loop until (eq old (sb-ext:compare-and-swap (,accessor x ,@args) old new))
 100        do (setf old (,accessor x ,@args)
 101                 new (1+ old)))
 102     new)))
 103
 104 (defstruct cas-struct (slot 0))
 105
 106 (defincf incf-car car)
 107 (defincf incf-cdr cdr)
 108 (defincf incf-slot cas-struct-slot)
 109 (defincf incf-symbol-value symbol-value)
 110 (defincf incf-svref/1 svref 1)
 111 (defincf incf-svref/0 svref 0)
 112
 113 (defmacro def-test-cas (name init incf op)
 114   `(with-test (:name ,name)
 115      (flet ((,name (n)
 116               (declare (fixnum n))
 117               (let* ((x ,init)
 118                      (run nil)
 119                      (threads
 120                       (loop repeat 10
 121                             collect (sb-thread:make-thread
 122                                      (lambda ()
 123                                        (loop until run
 124                                              do (sb-thread:thread-yield))
 125                                        (loop repeat n do (,incf x)))))))
 126                 (setf run t)
 127                 (dolist (th threads)
 128                   (sb-thread:join-thread th))
 129                 (assert (= (,op x) (* 10 n))))))
 130        (,name 200000))))
 131
 132 (def-test-cas test-cas-car (cons 0 nil) incf-car car)
 133 (def-test-cas test-cas-cdr (cons nil 0) incf-cdr cdr)
 134 (def-test-cas test-cas-slot (make-cas-struct) incf-slot cas-struct-slot)
 135 (def-test-cas test-cas-value (let ((x '.x.))
 136                                (set x 0)
 137                                x)
 138   incf-symbol-value symbol-value)
 139 (def-test-cas test-cas-svref/0 (vector 0 nil) incf-svref/0 (lambda (x)
 140                                                              (svref x 0)))
 141 (def-test-cas test-cas-svref/1 (vector nil 0) incf-svref/1 (lambda (x)
 142                                                              (svref x 1)))
 143 (format t "~&compare-and-swap tests done~%")
 144
 145 (with-test (:name (:threads :more-trivia)))
 146 (let ((old-threads (list-all-threads))
 147       (thread (make-thread (lambda ()
 148                              (assert (find *current-thread* *all-threads*))
 149                              (sleep 2))))
 150       (new-threads (list-all-threads)))
 151   (assert (thread-alive-p thread))
 152   (assert (eq thread (first new-threads)))
 153   (assert (= (1+ (length old-threads)) (length new-threads)))
 154   (sleep 3)
 155   (assert (not (thread-alive-p thread))))
 156
 157 (with-test (:name (:join-thread :nlx :default))
 158   (let ((sym (gensym)))
 159     (assert (eq sym (join-thread (make-thread (lambda () (sb-ext:quit)))
 160                                  :default sym)))))
 161
 162 (with-test (:name (:join-thread :nlx :error))
 163   (raises-error? (join-thread (make-thread (lambda () (sb-ext:quit))))
 164                  join-thread-error))
 165
 166 (with-test (:name (:join-thread :multiple-values))
 167   (assert (equal '(1 2 3)
 168                  (multiple-value-list
 169                   (join-thread (make-thread (lambda () (values 1 2 3))))))))
 170
 171 ;;; We had appalling scaling properties for a while.  Make sure they
 172 ;;; don't reappear.
 173 (defun scaling-test (function &optional (nthreads 5))
 174   "Execute FUNCTION with NTHREADS lurking to slow it down."
 175   (let ((queue (sb-thread:make-waitqueue))
 176         (mutex (sb-thread:make-mutex)))
 177     ;; Start NTHREADS idle threads.
 178     (dotimes (i nthreads)
 179       (sb-thread:make-thread (lambda ()
 180                                (with-mutex (mutex)
 181                                  (sb-thread:condition-wait queue mutex))
 182                                (sb-ext:quit))))
 183     (let ((start-time (get-internal-run-time)))
 184       (funcall function)
 185       (prog1 (- (get-internal-run-time) start-time)
 186         (sb-thread:condition-broadcast queue)))))
 187 (defun fact (n)
 188   "A function that does work with the CPU."
 189   (if (zerop n) 1 (* n (fact (1- n)))))
 190 (let ((work (lambda () (fact 15000))))
 191   (let ((zero (scaling-test work 0))
 192         (four (scaling-test work 4)))
 193     ;; a slightly weak assertion, but good enough for starters.
 194     (assert (< four (* 1.5 zero)))))
 195
 196 ;;; For one of the interupt-thread tests, we want a foreign function
 197 ;;; that does not make syscalls
 198
 199 (with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede)
 200   (format o "void loop_forever() { while(1) ; }~%"))
 201 (sb-ext:run-program "/bin/sh"
 202                     '("run-compiler.sh" "-sbcl-pic" "-sbcl-shared"
 203                       "-o" "threads-foreign.so" "threads-foreign.c")
 204                     :environment (test-util::test-env))
 205 (sb-alien:load-shared-object (truename "threads-foreign.so"))
 206 (sb-alien:define-alien-routine loop-forever sb-alien:void)
 207 (delete-file "threads-foreign.c")
 208
 209
 210 ;;; elementary "can we get a lock and release it again"
 211 (with-test (:name (:mutex :basics))
 212   (let ((l (make-mutex :name "foo"))
 213         (p *current-thread*))
 214     (assert (eql (mutex-value l) nil) nil "1")
 215     (sb-thread:get-mutex l)
 216     (assert (eql (mutex-value l) p) nil "3")
 217     (sb-thread:release-mutex l)
 218     (assert (eql (mutex-value l) nil) nil "5")))
 219
 220 (with-test (:name (:with-recursive-lock :basics))
 221   (labels ((ours-p (value)
 222              (eq *current-thread* value)))
 223     (let ((l (make-mutex :name "rec")))
 224       (assert (eql (mutex-value l) nil) nil "1")
 225       (sb-thread:with-recursive-lock (l)
 226         (assert (ours-p (mutex-value l)) nil "3")
 227         (sb-thread:with-recursive-lock (l)
 228           (assert (ours-p (mutex-value l)) nil "4"))
 229         (assert (ours-p (mutex-value l)) nil "5"))
 230       (assert (eql (mutex-value l) nil) nil "6"))))
 231
 232 (with-test (:name (:with-recursive-spinlock :basics))
 233   (labels ((ours-p (value)
 234              (eq *current-thread* value)))
 235     (let ((l (make-spinlock :name "rec")))
 236       (assert (eql (spinlock-value l) nil) nil "1")
 237       (with-recursive-spinlock (l)
 238         (assert (ours-p (spinlock-value l)) nil "3")
 239         (with-recursive-spinlock (l)
 240           (assert (ours-p (spinlock-value l)) nil "4"))
 241         (assert (ours-p (spinlock-value l)) nil "5"))
 242       (assert (eql (spinlock-value l) nil) nil "6"))))
 243
 244 (with-test (:name (:mutex :nesting-mutex-and-recursive-lock))
 245   (let ((l (make-mutex :name "a mutex")))
 246     (with-mutex (l)
 247       (with-recursive-lock (l)))))
 248
 249 (with-test (:name (:spinlock :nesting-spinlock-and-recursive-spinlock))
 250   (let ((l (make-spinlock :name "a spinlock")))
 251     (with-spinlock (l)
 252       (with-recursive-spinlock (l)))))
 253
 254 (with-test (:name (:spinlock :more-basics))
 255   (let ((l (make-spinlock :name "spinlock")))
 256     (assert (eql (spinlock-value l) nil) ((spinlock-value l))
 257             "spinlock not free (1)")
 258     (with-spinlock (l)
 259       (assert (eql (spinlock-value l) *current-thread*) ((spinlock-value l))
 260               "spinlock not taken"))
 261     (assert (eql (spinlock-value l) nil) ((spinlock-value l))
 262             "spinlock not free (2)")))
 263
 264 ;; test that SLEEP actually sleeps for at least the given time, even
 265 ;; if interrupted by another thread exiting/a gc/anything
 266 (with-test (:name (:sleep :continue-sleeping-after-interrupt))
 267   (let ((start-time (get-universal-time)))
 268     (make-thread (lambda () (sleep 1) (sb-ext:gc :full t)))
 269     (sleep 5)
 270     (assert (>= (get-universal-time) (+ 5 start-time)))))
 271
 272
 273 (with-test (:name (:condition-wait :basics-1))
 274   (let ((queue (make-waitqueue :name "queue"))
 275         (lock (make-mutex :name "lock"))
 276         (n 0))
 277     (labels ((in-new-thread ()
 278                (with-mutex (lock)
 279                  (assert (eql (mutex-value lock) *current-thread*))
 280                  (format t "~A got mutex~%" *current-thread*)
 281                  ;; now drop it and sleep
 282                  (condition-wait queue lock)
 283                  ;; after waking we should have the lock again
 284                  (assert (eql (mutex-value lock) *current-thread*))
 285                  (assert (eql n 1))
 286                  (decf n))))
 287       (make-thread #'in-new-thread)
 288       (sleep 2)            ; give it  a chance to start
 289       ;; check the lock is free while it's asleep
 290       (format t "parent thread ~A~%" *current-thread*)
 291       (assert (eql (mutex-value lock) nil))
 292       (with-mutex (lock)
 293         (incf n)
 294         (condition-notify queue))
 295       (sleep 1))))
 296
 297 (with-test (:name (:condition-wait :basics-2))
 298   (let ((queue (make-waitqueue :name "queue"))
 299         (lock (make-mutex :name "lock")))
 300     (labels ((ours-p (value)
 301                (eq *current-thread* value))
 302              (in-new-thread ()
 303                (with-recursive-lock (lock)
 304                  (assert (ours-p (mutex-value lock)))
 305                  (format t "~A got mutex~%" (mutex-value lock))
 306                  ;; now drop it and sleep
 307                  (condition-wait queue lock)
 308                  ;; after waking we should have the lock again
 309                  (format t "woken, ~A got mutex~%" (mutex-value lock))
 310                  (assert (ours-p (mutex-value lock))))))
 311       (make-thread #'in-new-thread)
 312       (sleep 2)            ; give it  a chance to start
 313       ;; check the lock is free while it's asleep
 314       (format t "parent thread ~A~%" *current-thread*)
 315       (assert (eql (mutex-value lock) nil))
 316       (with-recursive-lock (lock)
 317         (condition-notify queue))
 318       (sleep 1))))
 319
 320 (with-test (:name (:mutex :contention))
 321   (let ((mutex (make-mutex :name "contended")))
 322     (labels ((run ()
 323                (let ((me *current-thread*))
 324                  (dotimes (i 100)
 325                    (with-mutex (mutex)
 326                      (sleep .03)
 327                      (assert (eql (mutex-value mutex) me)))
 328                    (assert (not (eql (mutex-value mutex) me))))
 329                  (format t "done ~A~%" *current-thread*))))
 330       (let ((kid1 (make-thread #'run))
 331             (kid2 (make-thread #'run)))
 332         (format t "contention ~A ~A~%" kid1 kid2)
 333         (wait-for-threads (list kid1 kid2))))))
 334
 335 ;;; GRAB-MUTEX
 336
 337 (with-test (:name (:grab-mutex :waitp nil))
 338   (let ((m (make-mutex)))
 339     (with-mutex (m)
 340       (assert (null (join-thread (make-thread
 341                                   #'(lambda ()
 342                                       (grab-mutex m :waitp nil)))))))))
 343
 344 (with-test (:name (:grab-mutex :timeout :acquisition-fail))
 345   (let ((m (make-mutex))
 346         (w (make-semaphore)))
 347     (with-mutex (m)
 348       (let ((th (make-thread
 349                  #'(lambda ()
 350                      (prog1
 351                          (grab-mutex m :timeout 0.1)
 352                        (signal-semaphore w))))))
 353         ;; Wait for it to -- otherwise the detect the deadlock chain
 354         ;; from JOIN-THREAD.
 355         (wait-on-semaphore w)
 356         (assert (null (join-thread th)))))))
 357
 358 (with-test (:name (:grab-mutex :timeout :acquisition-success))
 359   (let ((m (make-mutex))
 360         (child))
 361     (with-mutex (m)
 362       (setq child (make-thread #'(lambda () (grab-mutex m :timeout 1.0))))
 363       (sleep 0.2))
 364     (assert (eq (join-thread child) 't))))
 365
 366 (with-test (:name (:grab-mutex :timeout+deadline))
 367   (let ((m (make-mutex))
 368         (w (make-semaphore)))
 369     (with-mutex (m)
 370       (let ((th (make-thread #'(lambda ()
 371                                  (sb-sys:with-deadline (:seconds 0.0)
 372                                    (handler-case
 373                                        (grab-mutex m :timeout 0.0)
 374                                      (sb-sys:deadline-timeout ()
 375                                        (signal-semaphore w)
 376                                        :deadline)))))))
 377         (wait-on-semaphore w)
 378         (assert (eq (join-thread th) :deadline))))))
 379
 380 (with-test (:name (:grab-mutex :waitp+deadline))
 381   (let ((m (make-mutex)))
 382     (with-mutex (m)
 383       (assert (eq (join-thread
 384                    (make-thread #'(lambda ()
 385                                     (sb-sys:with-deadline (:seconds 0.0)
 386                                       (handler-case
 387                                           (grab-mutex m :waitp nil)
 388                                         (sb-sys:deadline-timeout ()
 389                                           :deadline))))))
 390                   'nil)))))
 391
 392 ;;; semaphores
 393
 394 (defmacro raises-timeout-p (&body body)
 395   `(handler-case (progn (progn ,@body) nil)
 396     (sb-ext:timeout () t)))
 397
 398 (with-test (:name (:semaphore :wait-forever))
 399   (let ((sem (make-semaphore :count 0)))
 400     (assert (raises-timeout-p
 401               (sb-ext:with-timeout 0.1
 402                 (wait-on-semaphore sem))))))
 403
 404 (with-test (:name (:semaphore :initial-count))
 405   (let ((sem (make-semaphore :count 1)))
 406     (sb-ext:with-timeout 0.1
 407       (wait-on-semaphore sem))))
 408
 409 (with-test (:name (:semaphore :wait-then-signal))
 410   (let ((sem (make-semaphore))
 411         (signalled-p nil))
 412     (make-thread (lambda ()
 413                    (sleep 0.1)
 414                    (setq signalled-p t)
 415                    (signal-semaphore sem)))
 416     (wait-on-semaphore sem)
 417     (assert signalled-p)))
 418
 419 (with-test (:name (:semaphore :signal-then-wait))
 420   (let ((sem (make-semaphore))
 421         (signalled-p nil))
 422     (make-thread (lambda ()
 423                    (signal-semaphore sem)
 424                    (setq signalled-p t)))
 425     (loop until signalled-p)
 426     (wait-on-semaphore sem)
 427     (assert signalled-p)))
 428
 429 (defun test-semaphore-multiple-signals (wait-on-semaphore)
 430   (let* ((sem (make-semaphore :count 5))
 431          (threads (loop repeat 20 collecting
 432                         (make-thread (lambda ()
 433                                        (funcall wait-on-semaphore sem))))))
 434     (flet ((count-live-threads ()
 435              (count-if #'thread-alive-p threads)))
 436       (sleep 0.5)
 437       (assert (= 15 (count-live-threads)))
 438       (signal-semaphore sem 10)
 439       (sleep 0.5)
 440       (assert (= 5 (count-live-threads)))
 441       (signal-semaphore sem 3)
 442       (sleep 0.5)
 443       (assert (= 2 (count-live-threads)))
 444       (signal-semaphore sem 4)
 445       (sleep 0.5)
 446       (assert (= 0 (count-live-threads))))))
 447
 448 (with-test (:name (:semaphore :multiple-signals))
 449   (test-semaphore-multiple-signals #'wait-on-semaphore))
 450
 451 (with-test (:name (:try-semaphore :trivial-fail))
 452   (assert (eq (try-semaphore (make-semaphore :count 0)) 'nil)))
 453
 454 (with-test (:name (:try-semaphore :trivial-success))
 455   (let ((sem (make-semaphore :count 1)))
 456     (assert (try-semaphore sem))
 457     (assert (zerop (semaphore-count sem)))))
 458
 459 (with-test (:name (:try-semaphore :trivial-fail :n>1))
 460   (assert (eq (try-semaphore (make-semaphore :count 1) 2) 'nil)))
 461
 462 (with-test (:name (:try-semaphore :trivial-success :n>1))
 463   (let ((sem (make-semaphore :count 10)))
 464     (assert (try-semaphore sem 5))
 465     (assert (try-semaphore sem 5))
 466     (assert (zerop (semaphore-count sem)))))
 467
 468 (with-test (:name (:try-semaphore :emulate-wait-on-semaphore))
 469   (flet ((busy-wait-on-semaphore (sem)
 470            (loop until (try-semaphore sem) do (sleep 0.001))))
 471     (test-semaphore-multiple-signals #'busy-wait-on-semaphore)))
 472
 473 ;;; Here we test that interrupting TRY-SEMAPHORE does not leave a
 474 ;;; semaphore in a bad state.
 475 (with-test (:name (:try-semaphore :interrupt-safe))
 476   (flet ((make-threads (count fn)
 477            (loop repeat count collect (make-thread fn)))
 478          (kill-thread (thread)
 479            (when (thread-alive-p thread)
 480              (ignore-errors (terminate-thread thread))))
 481          (count-live-threads (threads)
 482            (count-if #'thread-alive-p threads)))
 483     ;; WAITERS will already be waiting on the semaphore while
 484     ;; threads-being-interrupted will perform TRY-SEMAPHORE on that
 485     ;; semaphore, and MORE-WAITERS are new threads trying to wait on
 486     ;; the semaphore during the interruption-fire.
 487     (let* ((sem (make-semaphore :count 100))
 488            (waiters (make-threads 20 #'(lambda ()
 489                                          (wait-on-semaphore sem))))
 490            (triers  (make-threads 40 #'(lambda ()
 491                                          (sleep (random 0.01))
 492                                          (try-semaphore sem (1+ (random 5))))))
 493            (more-waiters
 494             (loop repeat 10
 495                   do (kill-thread (nth (random 40) triers))
 496                   collect (make-thread #'(lambda () (wait-on-semaphore sem)))
 497                   do (kill-thread (nth (random 40) triers)))))
 498       (sleep 0.5)
 499       ;; Now ensure that the waiting threads will all be waked up,
 500       ;; i.e. that the semaphore is still working.
 501       (loop repeat (+ (count-live-threads waiters)
 502                       (count-live-threads more-waiters))
 503             do (signal-semaphore sem))
 504       (sleep 0.5)
 505       (assert (zerop (count-live-threads triers)))
 506       (assert (zerop (count-live-threads waiters)))
 507       (assert (zerop (count-live-threads more-waiters))))))
 508
 509
 510
 511 (format t "~&semaphore tests done~%")
 512
 513 (defun test-interrupt (function-to-interrupt &optional quit-p)
 514   (let ((child  (make-thread function-to-interrupt)))
 515     ;;(format t "gdb ./src/runtime/sbcl ~A~%attach ~A~%" child child)
 516     (sleep 2)
 517     (format t "interrupting child ~A~%" child)
 518     (interrupt-thread child
 519                       (lambda ()
 520                         (format t "child pid ~A~%" *current-thread*)
 521                         (when quit-p (sb-ext:quit))))
 522     (sleep 1)
 523     child))
 524
 525 ;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
 526 ;; (d) waiting on a lock, (e) some code which we hope is likely to be
 527 ;; in pseudo-atomic
 528
 529 (with-test (:name (:interrupt-thread :more-basics))
 530   (let ((child (test-interrupt (lambda () (loop)))))
 531     (terminate-thread child)))
 532
 533 (with-test (:name (:interrupt-thread :interrupt-foreign-loop))
 534   (test-interrupt #'loop-forever :quit))
 535
 536 (with-test (:name (:interrupt-thread :interrupt-sleep))
 537   (let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
 538     (terminate-thread child)
 539     (wait-for-threads (list child))))
 540
 541 (with-test (:name (:interrupt-thread :interrupt-mutex-acquisition))
 542   (let ((lock (make-mutex :name "loctite"))
 543         child)
 544     (with-mutex (lock)
 545       (setf child (test-interrupt
 546                    (lambda ()
 547                      (with-mutex (lock)
 548                        (assert (eql (mutex-value lock) *current-thread*)))
 549                      (assert (not (eql (mutex-value lock) *current-thread*)))
 550                      (sleep 10))))
 551       ;;hold onto lock for long enough that child can't get it immediately
 552       (sleep 5)
 553       (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock))))
 554       (format t "parent releasing lock~%"))
 555     (terminate-thread child)
 556     (wait-for-threads (list child))))
 557
 558 (format t "~&locking test done~%")
 559
 560 (defun alloc-stuff () (copy-list '(1 2 3 4 5)))
 561
 562 (with-test (:name (:interrupt-thread :interrupt-consing-child)
 563             :broken-on :darwin)
 564   (let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff))))))
 565     (let ((killers
 566            (loop repeat 4 collect
 567                  (sb-thread:make-thread
 568                   (lambda ()
 569                     (loop repeat 25 do
 570                           (sleep (random 0.1d0))
 571                           (princ ".")
 572                           (force-output)
 573                           (sb-thread:interrupt-thread thread (lambda ()))))))))
 574       (wait-for-threads killers)
 575       (sb-thread:terminate-thread thread)
 576       (wait-for-threads (list thread))))
 577   (sb-ext:gc :full t))
 578
 579 (format t "~&multi interrupt test done~%")
 580
 581 #+(or x86 x86-64) ;; x86oid-only, see internal commentary.
 582 (with-test (:name (:interrupt-thread :interrupt-consing-child :again))
 583   (let ((c (make-thread (lambda () (loop (alloc-stuff))))))
 584     ;; NB this only works on x86: other ports don't have a symbol for
 585     ;; pseudo-atomic atomicity
 586     (dotimes (i 100)
 587       (sleep (random 0.1d0))
 588       (interrupt-thread c
 589                         (lambda ()
 590                           (princ ".") (force-output)
 591                           (assert (thread-alive-p *current-thread*))
 592                           (assert
 593                            (not (logbitp 0 SB-KERNEL:*PSEUDO-ATOMIC-BITS*))))))
 594     (terminate-thread c)
 595     (wait-for-threads (list c))))
 596
 597 (format t "~&interrupt test done~%")
 598
 599 (defstruct counter (n 0 :type sb-vm:word))
 600 (defvar *interrupt-counter* (make-counter))
 601
 602 (declaim (notinline check-interrupt-count))
 603 (defun check-interrupt-count (i)
 604   (declare (optimize (debug 1) (speed 1)))
 605   ;; This used to lose if eflags were not restored after an interrupt.
 606   (unless (typep i 'fixnum)
 607     (error "!!!!!!!!!!!")))
 608
 609 (with-test (:name (:interrupt-thread :interrupt-ATOMIC-INCF))
 610   (let ((c (make-thread
 611             (lambda ()
 612               (handler-bind ((error #'(lambda (cond)
 613                                         (princ cond)
 614                                         (sb-debug:backtrace
 615                                          most-positive-fixnum))))
 616                 (loop (check-interrupt-count
 617                        (counter-n *interrupt-counter*))))))))
 618     (let ((func (lambda ()
 619                   (princ ".")
 620                   (force-output)
 621                   (sb-ext:atomic-incf (counter-n *interrupt-counter*)))))
 622       (setf (counter-n *interrupt-counter*) 0)
 623       (dotimes (i 100)
 624         (sleep (random 0.1d0))
 625         (interrupt-thread c func))
 626       (loop until (= (counter-n *interrupt-counter*) 100) do (sleep 0.1))
 627       (terminate-thread c)
 628       (wait-for-threads (list c)))))
 629
 630 (format t "~&interrupt count test done~%")
 631
 632 (defvar *runningp* nil)
 633
 634 (with-test (:name (:interrupt-thread :no-nesting))
 635   (let ((thread (sb-thread:make-thread
 636                  (lambda ()
 637                    (catch 'xxx
 638                      (loop))))))
 639     (declare (special runningp))
 640     (sleep 0.2)
 641     (sb-thread:interrupt-thread thread
 642                                 (lambda ()
 643                                     (let ((*runningp* t))
 644                                       (sleep 1))))
 645     (sleep 0.2)
 646     (sb-thread:interrupt-thread thread
 647                                 (lambda ()
 648                                   (throw 'xxx *runningp*)))
 649     (assert (not (sb-thread:join-thread thread)))))
 650
 651 (with-test (:name (:interrupt-thread :nesting))
 652   (let ((thread (sb-thread:make-thread
 653                  (lambda ()
 654                    (catch 'xxx
 655                      (loop))))))
 656     (declare (special runningp))
 657     (sleep 0.2)
 658     (sb-thread:interrupt-thread thread
 659                                 (lambda ()
 660                                   (let ((*runningp* t))
 661                                     (sb-sys:with-interrupts
 662                                       (sleep 1)))))
 663     (sleep 0.2)
 664     (sb-thread:interrupt-thread thread
 665                                 (lambda ()
 666                                   (throw 'xxx *runningp*)))
 667     (assert (sb-thread:join-thread thread))))
 668
 669 (with-test (:name (:two-threads-running-gc))
 670   (let (a-done b-done)
 671     (make-thread (lambda ()
 672                    (dotimes (i 100)
 673                      (sb-ext:gc) (princ "\\") (force-output))
 674                    (setf a-done t)))
 675     (make-thread (lambda ()
 676                    (dotimes (i 25)
 677                      (sb-ext:gc :full t)
 678                      (princ "/") (force-output))
 679                    (setf b-done t)))
 680     (loop
 681       (when (and a-done b-done) (return))
 682       (sleep 1))))
 683
 684 (terpri)
 685
 686 (defun waste (&optional (n 100000))
 687   (loop repeat n do (make-string 16384)))
 688
 689 (with-test (:name (:one-thread-runs-gc-while-other-conses))
 690   (loop for i below 100 do
 691         (princ "!")
 692         (force-output)
 693         (sb-thread:make-thread
 694          #'(lambda ()
 695              (waste)))
 696         (waste)
 697         (sb-ext:gc)))
 698
 699 (terpri)
 700
 701 (defparameter *aaa* nil)
 702 (with-test (:name (:one-thread-runs-gc-while-other-conses :again))
 703   (loop for i below 100 do
 704         (princ "!")
 705         (force-output)
 706         (sb-thread:make-thread
 707          #'(lambda ()
 708              (let ((*aaa* (waste)))
 709                (waste))))
 710         (let ((*aaa* (waste)))
 711           (waste))
 712         (sb-ext:gc)))
 713
 714 (format t "~&gc test done~%")
 715
 716 ;; this used to deadlock on session-lock
 717 (with-test (:name (:no-session-deadlock))
 718   (sb-thread:make-thread (lambda () (sb-ext:gc))))
 719
 720 (defun exercise-syscall (fn reference-errno)
 721   (sb-thread:make-thread
 722    (lambda ()
 723      (loop do
 724           (funcall fn)
 725           (let ((errno (sb-unix::get-errno)))
 726             (sleep (random 0.1d0))
 727             (unless (eql errno reference-errno)
 728               (format t "Got errno: ~A (~A) instead of ~A~%"
 729                       errno
 730                       (sb-unix::strerror)
 731                       reference-errno)
 732               (force-output)
 733               (sb-ext:quit :unix-status 1)))))))
 734
 735 ;; (nanosleep -1 0) does not fail on FreeBSD
 736 (with-test (:name (:exercising-concurrent-syscalls))
 737   (let* (#-freebsd
 738          (nanosleep-errno (progn
 739                             (sb-unix:nanosleep -1 0)
 740                             (sb-unix::get-errno)))
 741          (open-errno (progn
 742                        (open "no-such-file"
 743                              :if-does-not-exist nil)
 744                        (sb-unix::get-errno)))
 745          (threads
 746           (list
 747            #-freebsd
 748            (exercise-syscall (lambda () (sb-unix:nanosleep -1 0)) nanosleep-errno)
 749            (exercise-syscall (lambda () (open "no-such-file"
 750                                               :if-does-not-exist nil))
 751                              open-errno)
 752            (sb-thread:make-thread (lambda () (loop (sb-ext:gc) (sleep 1)))))))
 753     (sleep 10)
 754     (princ "terminating threads")
 755     (dolist (thread threads)
 756       (sb-thread:terminate-thread thread))))
 757
 758 (format t "~&errno test done~%")
 759
 760 (with-test (:name (:terminate-thread-restart))
 761   (loop repeat 100 do
 762         (let ((thread (sb-thread:make-thread (lambda () (sleep 0.1)))))
 763           (sb-thread:interrupt-thread
 764            thread
 765            (lambda ()
 766              (assert (find-restart 'sb-thread:terminate-thread)))))))
 767
 768 (sb-ext:gc :full t)
 769
 770 (format t "~&thread startup sigmask test done~%")
 771
 772 (with-test (:name (:debugger-no-hang-on-session-lock-if-interrupted))
 773   (sb-debug::enable-debugger)
 774   (let* ((main-thread *current-thread*)
 775          (interruptor-thread
 776           (make-thread (lambda ()
 777                          (sleep 2)
 778                          (interrupt-thread main-thread
 779                                            (lambda ()
 780                                              (with-interrupts
 781                                                (break))))
 782                          (sleep 2)
 783                          (interrupt-thread main-thread #'continue))
 784                        :name "interruptor")))
 785     (with-session-lock (*session*)
 786       (sleep 3))
 787     (loop while (thread-alive-p interruptor-thread))))
 788
 789 (format t "~&session lock test done~%")
 790
 791 ;; expose thread creation races by exiting quickly
 792 (with-test (:name (:no-thread-creation-race :light))
 793   (sb-thread:make-thread (lambda ())))
 794
 795 (with-test (:name (:no-thread-creation-race :heavy))
 796   (loop repeat 20 do
 797         (wait-for-threads
 798          (loop for i below 100 collect
 799                (sb-thread:make-thread (lambda ()))))))
 800
 801 (format t "~&creation test done~%")
 802
 803 ;; interrupt handlers are per-thread with pthreads, make sure the
 804 ;; handler installed in one thread is global
 805 (with-test (:name (:global-interrupt-handler))
 806   (sb-thread:make-thread
 807    (lambda ()
 808      (sb-ext:run-program "sleep" '("1") :search t :wait nil))))
 809
 810 ;;;; Binding stack safety
 811
 812 (defparameter *x* nil)
 813 (defparameter *n-gcs-requested* 0)
 814 (defparameter *n-gcs-done* 0)
 815
 816 (let ((counter 0))
 817   (defun make-something-big ()
 818     (let ((x (make-string 32000)))
 819       (incf counter)
 820       (let ((counter counter))
 821         (sb-ext:finalize x (lambda () (format t " ~S" counter)
 822                                    (force-output)))))))
 823
 824 (defmacro wait-for-gc ()
 825   `(progn
 826      (incf *n-gcs-requested*)
 827      (loop while (< *n-gcs-done* *n-gcs-requested*))))
 828
 829 (defun send-gc ()
 830   (loop until (< *n-gcs-done* *n-gcs-requested*))
 831   (format t "G")
 832   (force-output)
 833   (sb-ext:gc)
 834   (incf *n-gcs-done*))
 835
 836 (defun exercise-binding ()
 837   (loop
 838    (let ((*x* (make-something-big)))
 839      (let ((*x* 42))
 840        ;; at this point the binding stack looks like this:
 841        ;; NO-TLS-VALUE-MARKER, *x*, SOMETHING, *x*
 842        t))
 843    (wait-for-gc)
 844    ;; sig_stop_for_gc_handler binds FREE_INTERRUPT_CONTEXT_INDEX. By
 845    ;; now SOMETHING is gc'ed and the binding stack looks like this: 0,
 846    ;; 0, SOMETHING, 0 (because the symbol slots are zeroed on
 847    ;; unbinding but values are not).
 848    (let ((*x* nil)
 849          (binding-pointer-delta (ash 2 (- sb-vm:word-shift sb-vm:n-fixnum-tag-bits))))
 850      ;; bump bsp as if a BIND had just started
 851      (incf sb-vm::*binding-stack-pointer* binding-pointer-delta)
 852      (wait-for-gc)
 853      (decf sb-vm::*binding-stack-pointer* binding-pointer-delta))))
 854
 855 (with-test (:name (:binding-stack-gc-safety))
 856   (let (threads)
 857     (unwind-protect
 858          (progn
 859            (push (sb-thread:make-thread #'exercise-binding) threads)
 860            (push (sb-thread:make-thread (lambda ()
 861                                           (loop
 862                                            (sleep 0.1)
 863                                            (send-gc))))
 864                  threads)
 865            (sleep 4))
 866       (mapc #'sb-thread:terminate-thread threads))))
 867
 868 (format t "~&binding test done~%")
 869
 870 ;;; HASH TABLES
 871
 872 (defvar *errors* nil)
 873
 874 (defun oops (e)
 875   (setf *errors* e)
 876   (format t "~&oops: ~A in ~S~%" e *current-thread*)
 877   (sb-debug:backtrace)
 878   (catch 'done))
 879
 880 (with-test (:name (:unsynchronized-hash-table)
 881                   ;; FIXME: This test occasionally eats out craploads
 882                   ;; of heap instead of expected error early. Not 100%
 883                   ;; sure if it would finish as expected, but since it
 884                   ;; hits swap on my system I'm not likely to find out
 885                   ;; soon. Disabling for now. -- nikodemus
 886             :skipped-on :sbcl)
 887   ;; We expect a (probable) error here: parellel readers and writers
 888   ;; on a hash-table are not expected to work -- but we also don't
 889   ;; expect this to corrupt the image.
 890   (let* ((hash (make-hash-table))
 891          (*errors* nil)
 892          (threads (list (sb-thread:make-thread
 893                          (lambda ()
 894                            (catch 'done
 895                              (handler-bind ((serious-condition 'oops))
 896                                (loop
 897                                  ;;(princ "1") (force-output)
 898                                  (setf (gethash (random 100) hash) 'h)))))
 899                          :name "writer")
 900                         (sb-thread:make-thread
 901                          (lambda ()
 902                            (catch 'done
 903                              (handler-bind ((serious-condition 'oops))
 904                                (loop
 905                                  ;;(princ "2") (force-output)
 906                                  (remhash (random 100) hash)))))
 907                          :name "reader")
 908                         (sb-thread:make-thread
 909                          (lambda ()
 910                            (catch 'done
 911                              (handler-bind ((serious-condition 'oops))
 912                                (loop
 913                                  (sleep (random 1.0))
 914                                  (sb-ext:gc :full t)))))
 915                          :name "collector"))))
 916     (unwind-protect
 917          (sleep 10)
 918       (mapc #'sb-thread:terminate-thread threads))))
 919
 920 (format t "~&unsynchronized hash table test done~%")
 921
 922 (with-test (:name (:synchronized-hash-table))
 923   (let* ((hash (make-hash-table :synchronized t))
 924          (*errors* nil)
 925          (threads (list (sb-thread:make-thread
 926                          (lambda ()
 927                            (catch 'done
 928                              (handler-bind ((serious-condition 'oops))
 929                                (loop
 930                                  ;;(princ "1") (force-output)
 931                                  (setf (gethash (random 100) hash) 'h)))))
 932                          :name "writer")
 933                         (sb-thread:make-thread
 934                          (lambda ()
 935                            (catch 'done
 936                              (handler-bind ((serious-condition 'oops))
 937                                (loop
 938                                  ;;(princ "2") (force-output)
 939                                  (remhash (random 100) hash)))))
 940                          :name "reader")
 941                         (sb-thread:make-thread
 942                          (lambda ()
 943                            (catch 'done
 944                              (handler-bind ((serious-condition 'oops))
 945                                (loop
 946                                  (sleep (random 1.0))
 947                                  (sb-ext:gc :full t)))))
 948                          :name "collector"))))
 949     (unwind-protect
 950          (sleep 10)
 951       (mapc #'sb-thread:terminate-thread threads))
 952     (assert (not *errors*))))
 953
 954 (format t "~&synchronized hash table test done~%")
 955
 956 (with-test (:name (:hash-table-parallel-readers))
 957   (let ((hash (make-hash-table))
 958         (*errors* nil))
 959     (loop repeat 50
 960           do (setf (gethash (random 100) hash) 'xxx))
 961     (let ((threads (list (sb-thread:make-thread
 962                           (lambda ()
 963                             (catch 'done
 964                               (handler-bind ((serious-condition 'oops))
 965                                 (loop
 966                                       until (eq t (gethash (random 100) hash))))))
 967                           :name "reader 1")
 968                          (sb-thread:make-thread
 969                           (lambda ()
 970                             (catch 'done
 971                               (handler-bind ((serious-condition 'oops))
 972                                 (loop
 973                                       until (eq t (gethash (random 100) hash))))))
 974                           :name "reader 2")
 975                          (sb-thread:make-thread
 976                           (lambda ()
 977                             (catch 'done
 978                               (handler-bind ((serious-condition 'oops))
 979                                 (loop
 980                                       until (eq t (gethash (random 100) hash))))))
 981                           :name "reader 3")
 982                          (sb-thread:make-thread
 983                           (lambda ()
 984                             (catch 'done
 985                               (handler-bind ((serious-condition 'oops))
 986                                (loop
 987                                  (sleep (random 1.0))
 988                                  (sb-ext:gc :full t)))))
 989                           :name "collector"))))
 990       (unwind-protect
 991            (sleep 10)
 992         (mapc #'sb-thread:terminate-thread threads))
 993       (assert (not *errors*)))))
 994
 995 (format t "~&multiple reader hash table test done~%")
 996
 997 (with-test (:name (:hash-table-single-accessor-parallel-gc))
 998   (let ((hash (make-hash-table))
 999         (*errors* nil))
1000     (let ((threads (list (sb-thread:make-thread
1001                           (lambda ()
1002                             (handler-bind ((serious-condition 'oops))
1003                               (loop
1004                                 (let ((n (random 100)))
1005                                   (if (gethash n hash)
1006                                       (remhash n hash)
1007                                       (setf (gethash n hash) 'h))))))
1008                           :name "accessor")
1009                          (sb-thread:make-thread
1010                           (lambda ()
1011                             (handler-bind ((serious-condition 'oops))
1012                               (loop
1013                                 (sleep (random 1.0))
1014                                 (sb-ext:gc :full t))))
1015                           :name "collector"))))
1016       (unwind-protect
1017            (sleep 10)
1018         (mapc #'sb-thread:terminate-thread threads))
1019       (assert (not *errors*)))))
1020
1021 (format t "~&single accessor hash table test~%")
1022
1023 #|  ;; a cll post from eric marsden
1024 | (defun crash ()
1025 |   (setq *debugger-hook*
1026 |         (lambda (condition old-debugger-hook)
1027 |           (debug:backtrace 10)
1028 |           (unix:unix-exit 2)))
1029 |   #+live-dangerously
1030 |   (mp::start-sigalrm-yield)
1031 |   (flet ((roomy () (loop (with-output-to-string (*standard-output*) (room)))))
1032 |     (mp:make-process #'roomy)
1033 |     (mp:make-process #'roomy)))
1034 |#
1035
1036 (with-test (:name (:condition-variable :notify-multiple))
1037   (flet ((tester (notify-fun)
1038            (let ((queue (make-waitqueue :name "queue"))
1039                  (lock (make-mutex :name "lock"))
1040                  (data nil))
1041              (labels ((test (x)
1042                         (loop
1043                            (with-mutex (lock)
1044                              (format t "condition-wait ~a~%" x)
1045                              (force-output)
1046                              (condition-wait queue lock)
1047                              (format t "woke up ~a~%" x)
1048                              (force-output)
1049                              (push x data)))))
1050                (let ((threads (loop for x from 1 to 10
1051                                     collect
1052                                     (let ((x x))
1053                                       (sb-thread:make-thread (lambda ()
1054                                                                (test x)))))))
1055                  (sleep 5)
1056                  (with-mutex (lock)
1057                    (funcall notify-fun queue))
1058                  (sleep 5)
1059                  (mapcar #'terminate-thread threads)
1060                  ;; Check that all threads woke up at least once
1061                  (assert (= (length (remove-duplicates data)) 10)))))))
1062     (tester (lambda (queue)
1063               (format t "~&(condition-notify queue 10)~%")
1064               (force-output)
1065               (condition-notify queue 10)))
1066     (tester (lambda (queue)
1067               (format t "~&(condition-broadcast queue)~%")
1068               (force-output)
1069               (condition-broadcast queue)))))
1070
1071 (format t "waitqueue wakeup tests done~%")
1072
1073 ;;; Make sure that a deadline handler is not invoked twice in a row in
1074 ;;; CONDITION-WAIT. See LP #512914 for a detailed explanation.
1075 ;;;
1076 (with-test (:name (:condition-wait :deadlines :LP-512914)
1077             :skipped-on '(not :sb-futex))
1078   (let ((n 2)                      ; was empirically enough to trigger the bug
1079         (mutex (sb-thread:make-mutex))
1080         (waitq (sb-thread:make-waitqueue))
1081         (threads nil)
1082         (deadline-handler-run-twice? nil))
1083     (dotimes (i n)
1084       (let ((child
1085               (sb-thread:make-thread
1086                #'(lambda ()
1087                    (handler-bind
1088                        ((sb-sys:deadline-timeout
1089                           (let ((already? nil))
1090                             #'(lambda (c)
1091                                 (when already?
1092                                   (setq deadline-handler-run-twice? t))
1093                                 (setq already? t)
1094                                 (sleep 0.2)
1095                                 (sb-thread:condition-broadcast waitq)
1096                                 (sb-sys:defer-deadline 10.0 c)))))
1097                      (sb-sys:with-deadline (:seconds 0.1)
1098                        (sb-thread:with-mutex (mutex)
1099                          (sb-thread:condition-wait waitq mutex))))))))
1100         (push child threads)))
1101     (mapc #'sb-thread:join-thread threads)
1102     (assert (not deadline-handler-run-twice?))))
1103
1104 (with-test (:name (:condition-wait :signal-deadline-with-interrupts-enabled))
1105   (let ((mutex (sb-thread:make-mutex))
1106         (waitq (sb-thread:make-waitqueue))
1107         (A-holds? :unknown)
1108         (B-holds? :unknown)
1109         (A-interrupts-enabled? :unknown)
1110         (B-interrupts-enabled? :unknown)
1111         (A)
1112         (B))
1113     ;; W.L.O.G., we assume that A is executed first...
1114     (setq A (sb-thread:make-thread
1115              #'(lambda ()
1116                  (handler-bind
1117                      ((sb-sys:deadline-timeout
1118                        #'(lambda (c)
1119                            ;; We came here through the call to DECODE-TIMEOUT
1120                            ;; in CONDITION-WAIT; hence both here are supposed
1121                            ;; to evaluate to T.
1122                            (setq A-holds? (sb-thread:holding-mutex-p mutex))
1123                            (setq A-interrupts-enabled?
1124                                  sb-sys:*interrupts-enabled*)
1125                            (sleep 0.2)
1126                            (sb-thread:condition-broadcast waitq)
1127                            (sb-sys:defer-deadline 10.0 c))))
1128                    (sb-sys:with-deadline (:seconds 0.1)
1129                      (sb-thread:with-mutex (mutex)
1130                        (sb-thread:condition-wait waitq mutex)))))
1131              :name "A"))
1132     (setq B (sb-thread:make-thread
1133              #'(lambda ()
1134                  (thread-yield)
1135                  (handler-bind
1136                      ((sb-sys:deadline-timeout
1137                        #'(lambda (c)
1138                            ;; We came here through the call to GET-MUTEX
1139                            ;; in CONDITION-WAIT (contended case of
1140                            ;; reaquiring the mutex) - so the former will
1141                            ;; be NIL, but interrupts should still be enabled.
1142                            (setq B-holds? (sb-thread:holding-mutex-p mutex))
1143                            (setq B-interrupts-enabled?
1144                                  sb-sys:*interrupts-enabled*)
1145                            (sleep 0.2)
1146                            (sb-thread:condition-broadcast waitq)
1147                            (sb-sys:defer-deadline 10.0 c))))
1148                    (sb-sys:with-deadline (:seconds 0.1)
1149                      (sb-thread:with-mutex (mutex)
1150                        (sb-thread:condition-wait waitq mutex)))))
1151              :name "B"))
1152     (sb-thread:join-thread A)
1153     (sb-thread:join-thread B)
1154     (let ((A-result (list A-holds? A-interrupts-enabled?))
1155           (B-result (list B-holds? B-interrupts-enabled?)))
1156       ;; We also check some subtle behaviour w.r.t. whether a deadline
1157       ;; handler in CONDITION-WAIT got the mutex, or not. This is most
1158       ;; probably very internal behaviour (so user should not depend
1159       ;; on it) -- I added the testing here just to manifest current
1160       ;; behaviour.
1161       (cond ((equal A-result '(t t)) (assert (equal B-result '(nil t))))
1162             ((equal B-result '(t t)) (assert (equal A-result '(nil t))))
1163             (t
1164              (error "Failure: fell through wit A: ~S, B: ~S"
1165                     A-result
1166                     B-result))))))
1167
1168 (with-test (:name (:mutex :finalization))
1169   (let ((a nil))
1170     (dotimes (i 500000)
1171       (setf a (make-mutex)))))
1172
1173 (format t "mutex finalization test done~%")
1174
1175 ;;; Check that INFO is thread-safe, at least when we're just doing reads.
1176
1177 (let* ((symbols (loop repeat 10000 collect (gensym)))
1178        (functions (loop for (symbol . rest) on symbols
1179                         for next = (car rest)
1180                         for fun = (let ((next next))
1181                                     (lambda (n)
1182                                       (if next
1183                                           (funcall next (1- n))
1184                                           n)))
1185                         do (setf (symbol-function symbol) fun)
1186                         collect fun)))
1187   (defun infodb-test ()
1188     (funcall (car functions) 9999)))
1189
1190 (with-test (:name (:infodb :read))
1191   (let* ((ok t)
1192          (threads (loop for i from 0 to 10
1193                         collect (sb-thread:make-thread
1194                                  (lambda ()
1195                                    (dotimes (j 100)
1196                                      (write-char #\-)
1197                                      (finish-output)
1198                                      (let ((n (infodb-test)))
1199                                        (unless (zerop n)
1200                                          (setf ok nil)
1201                                          (format t "N != 0 (~A)~%" n)
1202                                          (sb-ext:quit)))))))))
1203     (wait-for-threads threads)
1204     (assert ok)))
1205
1206 (format t "infodb test done~%")
1207
1208 (with-test (:name :backtrace)
1209   ;; Printing backtraces from several threads at once used to hang the
1210   ;; whole SBCL process (discovered by accident due to a timer.impure
1211   ;; test misbehaving). The cause was that packages weren't even
1212   ;; thread-safe for only doing FIND-SYMBOL, and while printing
1213   ;; backtraces a loot of symbol lookups need to be done due to
1214   ;; *PRINT-ESCAPE*.
1215   (let* ((threads (loop repeat 10
1216                         collect (sb-thread:make-thread
1217                                  (lambda ()
1218                                    (dotimes (i 1000)
1219                                      (with-output-to-string (*debug-io*)
1220                                        (sb-debug::backtrace 10))))))))
1221     (wait-for-threads threads)))
1222
1223 (format t "backtrace test done~%")
1224
1225 (format t "~&starting gc deadlock test: WARNING: THIS TEST WILL HANG ON FAILURE!~%")
1226
1227 (with-test (:name :gc-deadlock
1228                   ;; Prone to hang on Darwin due to interrupt issues.
1229             :broken-on :darwin)
1230   ;; Prior to 0.9.16.46 thread exit potentially deadlocked the
1231   ;; GC due to *all-threads-lock* and session lock. On earlier
1232   ;; versions and at least on one specific box this test is good enough
1233   ;; to catch that typically well before the 1500th iteration.
1234   (loop
1235      with i = 0
1236      with n = 3000
1237      while (< i n)
1238      do
1239        (incf i)
1240        (when (zerop (mod i 100))
1241          (write-char #\.)
1242          (force-output))
1243        (handler-case
1244            (if (oddp i)
1245                (sb-thread:make-thread
1246                 (lambda ()
1247                   (sleep (random 0.001)))
1248                 :name (format nil "SLEEP-~D" i))
1249                (sb-thread:make-thread
1250                 (lambda ()
1251                   ;; KLUDGE: what we are doing here is explicit,
1252                   ;; but the same can happen because of a regular
1253                   ;; MAKE-THREAD or LIST-ALL-THREADS, and various
1254                   ;; session functions.
1255                   (sb-thread::with-all-threads-lock
1256                     (sb-thread::with-session-lock (sb-thread::*session*)
1257                       (sb-ext:gc))))
1258                 :name (format nil "GC-~D" i)))
1259          (error (e)
1260            (format t "~%error creating thread ~D: ~A -- backing off for retry~%" i e)
1261            (sleep 0.1)
1262            (incf i)))))
1263
1264 (format t "~&gc deadlock test done~%")
1265 \f
1266 (let ((count (make-array 8 :initial-element 0)))
1267   (defun closure-one ()
1268     (declare (optimize safety))
1269     (values (incf (aref count 0)) (incf (aref count 1))
1270             (incf (aref count 2)) (incf (aref count 3))
1271             (incf (aref count 4)) (incf (aref count 5))
1272             (incf (aref count 6)) (incf (aref count 7))))
1273   (defun no-optimizing-away-closure-one ()
1274     (setf count (make-array 8 :initial-element 0))))
1275
1276 (defstruct box
1277   (count 0))
1278
1279 (let ((one (make-box))
1280       (two (make-box))
1281       (three (make-box)))
1282   (defun closure-two ()
1283     (declare (optimize safety))
1284     (values (incf (box-count one)) (incf (box-count two)) (incf (box-count three))))
1285   (defun no-optimizing-away-closure-two ()
1286     (setf one (make-box)
1287           two (make-box)
1288           three (make-box))))
1289
1290 (with-test (:name (:funcallable-instances))
1291   ;; the funcallable-instance implementation used not to be threadsafe
1292   ;; against setting the funcallable-instance function to a closure
1293   ;; (because the code and lexenv were set separately).
1294   (let ((fun (sb-kernel:%make-funcallable-instance 0))
1295         (condition nil))
1296     (setf (sb-kernel:funcallable-instance-fun fun) #'closure-one)
1297     (flet ((changer ()
1298              (loop (setf (sb-kernel:funcallable-instance-fun fun) #'closure-one)
1299                    (setf (sb-kernel:funcallable-instance-fun fun) #'closure-two)))
1300            (test ()
1301              (handler-case (loop (funcall fun))
1302                (serious-condition (c) (setf condition c)))))
1303       (let ((changer (make-thread #'changer))
1304             (test (make-thread #'test)))
1305         (handler-case
1306             (progn
1307               ;; The two closures above are fairly carefully crafted
1308               ;; so that if given the wrong lexenv they will tend to
1309               ;; do some serious damage, but it is of course difficult
1310               ;; to predict where the various bits and pieces will be
1311               ;; allocated.  Five seconds failed fairly reliably on
1312               ;; both my x86 and x86-64 systems.  -- CSR, 2006-09-27.
1313               (sb-ext:with-timeout 5
1314                 (wait-for-threads (list test)))
1315               (error "~@<test thread got condition:~2I~_~A~@:>" condition))
1316           (sb-ext:timeout ()
1317             (terminate-thread changer)
1318             (terminate-thread test)
1319             (wait-for-threads (list changer test))))))))
1320
1321 (format t "~&funcallable-instance test done~%")
1322
1323 (defun random-type (n)
1324   `(integer ,(random n) ,(+ n (random n))))
1325
1326 (defun subtypep-hash-cache-test ()
1327   (dotimes (i 10000)
1328     (let ((type1 (random-type 500))
1329           (type2 (random-type 500)))
1330       (let ((a (subtypep type1 type2)))
1331         (dotimes (i 100)
1332           (assert (eq (subtypep type1 type2) a))))))
1333   (format t "ok~%")
1334   (force-output))
1335
1336 (with-test (:name (:hash-cache :subtypep))
1337   (dotimes (i 10)
1338     (sb-thread:make-thread #'subtypep-hash-cache-test)))
1339 (format t "hash-cache tests done~%")
1340
1341 ;;;; BLACK BOX TESTS
1342
1343 (in-package :cl-user)
1344 (use-package :test-util)
1345 (use-package "ASSERTOID")
1346
1347 (format t "parallel defclass test -- WARNING, WILL HANG ON FAILURE!~%")
1348 (with-test (:name :parallel-defclass)
1349   (defclass test-1 () ((a :initform :orig-a)))
1350   (defclass test-2 () ((b :initform :orig-b)))
1351   (defclass test-3 (test-1 test-2) ((c :initform :orig-c)))
1352   (let* ((run t)
1353          (d1 (sb-thread:make-thread (lambda ()
1354                                       (loop while run
1355                                             do (defclass test-1 () ((a :initform :new-a)))
1356                                             (write-char #\1)
1357                                             (force-output)))
1358                                     :name "d1"))
1359          (d2 (sb-thread:make-thread (lambda ()
1360                                       (loop while run
1361                                             do (defclass test-2 () ((b :initform :new-b)))
1362                                                (write-char #\2)
1363                                                (force-output)))
1364                                     :name "d2"))
1365          (d3 (sb-thread:make-thread (lambda ()
1366                                       (loop while run
1367                                             do (defclass test-3 (test-1 test-2) ((c :initform :new-c)))
1368                                                (write-char #\3)
1369                                                (force-output)))
1370                                     :name "d3"))
1371          (i (sb-thread:make-thread (lambda ()
1372                                      (loop while run
1373                                            do (let ((i (make-instance 'test-3)))
1374                                                 (assert (member (slot-value i 'a) '(:orig-a :new-a)))
1375                                                 (assert (member (slot-value i 'b) '(:orig-b :new-b)))
1376                                                 (assert (member (slot-value i 'c) '(:orig-c :new-c))))
1377                                               (write-char #\i)
1378                                               (force-output)))
1379                                    :name "i")))
1380     (format t "~%sleeping!~%")
1381     (sleep 2.0)
1382     (format t "~%stopping!~%")
1383     (setf run nil)
1384     (mapc (lambda (th)
1385             (sb-thread:join-thread th)
1386             (format t "~%joined ~S~%" (sb-thread:thread-name th)))
1387           (list d1 d2 d3 i))))
1388 (format t "parallel defclass test done~%")
1389
1390 (with-test (:name (:deadlock-detection :interrupts))
1391   (let* ((m1 (sb-thread:make-mutex :name "M1"))
1392          (m2 (sb-thread:make-mutex :name "M2"))
1393          (t1 (sb-thread:make-thread
1394               (lambda ()
1395                 (sb-thread:with-mutex (m1)
1396                   (sleep 0.3)
1397                   :ok))
1398               :name "T1"))
1399          (t2 (sb-thread:make-thread
1400               (lambda ()
1401                 (sleep 0.1)
1402                 (sb-thread:with-mutex (m1 :wait-p t)
1403                   (sleep 0.2)
1404                   :ok))
1405               :name "T2")))
1406     (sleep 0.2)
1407     (sb-thread:interrupt-thread t2 (lambda ()
1408                                      (sb-thread:with-mutex (m2 :wait-p t)
1409                                        (sleep 0.3))))
1410     (sleep 0.05)
1411     (sb-thread:interrupt-thread t1 (lambda ()
1412                                      (sb-thread:with-mutex (m2 :wait-p t)
1413                                        (sleep 0.3))))
1414     ;; both threads should finish without a deadlock or deadlock
1415     ;; detection error
1416     (let ((res (list (sb-thread:join-thread t1)
1417                      (sb-thread:join-thread t2))))
1418       (assert (equal '(:ok :ok) res)))))
1419
1420 (with-test (:name (:deadlock-detection :gc))
1421   ;; To semi-reliably trigger the error (in SBCL's where)
1422   ;; it was present you had to run this for > 30 seconds,
1423   ;; but that's a bit long for a single test.
1424   (let* ((stop (+ 5 (get-universal-time)))
1425          (m1 (sb-thread:make-mutex :name "m1"))
1426          (t1 (sb-thread:make-thread
1427               (lambda ()
1428                 (loop until (> (get-universal-time) stop)
1429                       do (sb-thread:with-mutex (m1)
1430                            (eval `(make-array 24))))
1431                 :ok)))
1432          (t2 (sb-thread:make-thread
1433               (lambda ()
1434                 (loop until (> (get-universal-time) stop)
1435                       do (sb-thread:with-mutex (m1)
1436                            (eval `(make-array 24))))
1437                 :ok))))
1438     (let ((res (list (sb-thread:join-thread t1)
1439                      (sb-thread:join-thread t2))))
1440       (assert (equal '(:ok :ok) res)))))