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