tests/threads.impure.lisp

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