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