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