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 :emulate-wait-on-semaphore))
 391   (flet ((busy-wait-on-semaphore (sem)
 392            (loop until (try-semaphore sem) do (sleep 0.001))))
 393     (test-semaphore-multiple-signals #'busy-wait-on-semaphore)))
 394
 395 ;;; Here we test that interrupting TRY-SEMAPHORE does not leave a
 396 ;;; semaphore in a bad state.
 397 (with-test (:name (:try-semaphore :interrupt-safe))
 398   (flet ((make-threads (count fn)
 399            (loop repeat count collect (make-thread fn)))
 400          (kill-thread (thread)
 401            (when (thread-alive-p thread)
 402              (ignore-errors (terminate-thread thread))))
 403          (count-live-threads (threads)
 404            (count-if #'thread-alive-p threads)))
 405     ;; WAITERS will already be waiting on the semaphore while
 406     ;; threads-being-interrupted will perform TRY-SEMAPHORE on that
 407     ;; semaphore, and MORE-WAITERS are new threads trying to wait on
 408     ;; the semaphore during the interruption-fire.
 409     (let* ((sem (make-semaphore :count 50))
 410            (waiters (make-threads 20 #'(lambda ()
 411                                          (wait-on-semaphore sem))))
 412            (triers  (make-threads 40 #'(lambda ()
 413                                          (sleep (random 0.01))
 414                                          (try-semaphore sem))))
 415            (more-waiters
 416             (loop repeat 10
 417                   do (kill-thread (nth (random 40) triers))
 418                   collect (make-thread #'(lambda () (wait-on-semaphore sem)))
 419                   do (kill-thread (nth (random 40) triers)))))
 420       (sleep 0.5)
 421       ;; Now ensure that the waiting threads will all be waked up,
 422       ;; i.e. that the semaphore is still working.
 423       (loop repeat (+ (count-live-threads waiters)
 424                       (count-live-threads more-waiters))
 425             do (signal-semaphore sem))
 426       (sleep 0.5)
 427       (assert (zerop (count-live-threads triers)))
 428       (assert (zerop (count-live-threads waiters)))
 429       (assert (zerop (count-live-threads more-waiters))))))
 430
 431
 432
 433 (format t "~&semaphore tests done~%")
 434
 435 (defun test-interrupt (function-to-interrupt &optional quit-p)
 436   (let ((child  (make-thread function-to-interrupt)))
 437     ;;(format t "gdb ./src/runtime/sbcl ~A~%attach ~A~%" child child)
 438     (sleep 2)
 439     (format t "interrupting child ~A~%" child)
 440     (interrupt-thread child
 441                       (lambda ()
 442                         (format t "child pid ~A~%" *current-thread*)
 443                         (when quit-p (sb-ext:quit))))
 444     (sleep 1)
 445     child))
 446
 447 ;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
 448 ;; (d) waiting on a lock, (e) some code which we hope is likely to be
 449 ;; in pseudo-atomic
 450
 451 (let ((child (test-interrupt (lambda () (loop)))))  (terminate-thread child))
 452
 453 (test-interrupt #'loop-forever :quit)
 454
 455 (let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
 456   (terminate-thread child)
 457   (wait-for-threads (list child)))
 458
 459 (let ((lock (make-mutex :name "loctite"))
 460       child)
 461   (with-mutex (lock)
 462     (setf child (test-interrupt
 463                  (lambda ()
 464                    (with-mutex (lock)
 465                      (assert (eql (mutex-value lock) *current-thread*)))
 466                    (assert (not (eql (mutex-value lock) *current-thread*)))
 467                    (sleep 10))))
 468     ;;hold onto lock for long enough that child can't get it immediately
 469     (sleep 5)
 470     (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock))))
 471     (format t "parent releasing lock~%"))
 472   (terminate-thread child)
 473   (wait-for-threads (list child)))
 474
 475 (format t "~&locking test done~%")
 476
 477 (defun alloc-stuff () (copy-list '(1 2 3 4 5)))
 478
 479 (progn
 480   (let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff))))))
 481     (let ((killers
 482            (loop repeat 4 collect
 483                  (sb-thread:make-thread
 484                   (lambda ()
 485                     (loop repeat 25 do
 486                           (sleep (random 0.1d0))
 487                           (princ ".")
 488                           (force-output)
 489                           (sb-thread:interrupt-thread thread (lambda ()))))))))
 490       (wait-for-threads killers)
 491       (sb-thread:terminate-thread thread)
 492       (wait-for-threads (list thread))))
 493   (sb-ext:gc :full t))
 494
 495 (format t "~&multi interrupt test done~%")
 496
 497 (let ((c (make-thread (lambda () (loop (alloc-stuff))))))
 498   ;; NB this only works on x86: other ports don't have a symbol for
 499   ;; pseudo-atomic atomicity
 500   (dotimes (i 100)
 501     (sleep (random 0.1d0))
 502     (interrupt-thread c
 503                       (lambda ()
 504                         (princ ".") (force-output)
 505                         (assert (thread-alive-p *current-thread*))
 506                         (assert
 507                          (not (logbitp 0 SB-KERNEL:*PSEUDO-ATOMIC-BITS*))))))
 508   (terminate-thread c)
 509   (wait-for-threads (list c)))
 510
 511 (format t "~&interrupt test done~%")
 512
 513 (defstruct counter (n 0 :type sb-vm:word))
 514 (defvar *interrupt-counter* (make-counter))
 515
 516 (declaim (notinline check-interrupt-count))
 517 (defun check-interrupt-count (i)
 518   (declare (optimize (debug 1) (speed 1)))
 519   ;; This used to lose if eflags were not restored after an interrupt.
 520   (unless (typep i 'fixnum)
 521     (error "!!!!!!!!!!!")))
 522
 523 (let ((c (make-thread
 524           (lambda ()
 525             (handler-bind ((error #'(lambda (cond)
 526                                       (princ cond)
 527                                       (sb-debug:backtrace
 528                                        most-positive-fixnum))))
 529               (loop (check-interrupt-count (counter-n *interrupt-counter*))))))))
 530   (let ((func (lambda ()
 531                 (princ ".")
 532                 (force-output)
 533                 (sb-ext:atomic-incf (counter-n *interrupt-counter*)))))
 534     (setf (counter-n *interrupt-counter*) 0)
 535     (dotimes (i 100)
 536       (sleep (random 0.1d0))
 537       (interrupt-thread c func))
 538     (loop until (= (counter-n *interrupt-counter*) 100) do (sleep 0.1))
 539     (terminate-thread c)
 540     (wait-for-threads (list c))))
 541
 542 (format t "~&interrupt count test done~%")
 543
 544 (defvar *runningp* nil)
 545
 546 (with-test (:name (:interrupt-thread :no-nesting))
 547   (let ((thread (sb-thread:make-thread
 548                  (lambda ()
 549                    (catch 'xxx
 550                      (loop))))))
 551     (declare (special runningp))
 552     (sleep 0.2)
 553     (sb-thread:interrupt-thread thread
 554                                 (lambda ()
 555                                     (let ((*runningp* t))
 556                                       (sleep 1))))
 557     (sleep 0.2)
 558     (sb-thread:interrupt-thread thread
 559                                 (lambda ()
 560                                   (throw 'xxx *runningp*)))
 561     (assert (not (sb-thread:join-thread thread)))))
 562
 563 (with-test (:name (:interrupt-thread :nesting))
 564   (let ((thread (sb-thread:make-thread
 565                  (lambda ()
 566                    (catch 'xxx
 567                      (loop))))))
 568     (declare (special runningp))
 569     (sleep 0.2)
 570     (sb-thread:interrupt-thread thread
 571                                 (lambda ()
 572                                   (let ((*runningp* t))
 573                                     (sb-sys:with-interrupts
 574                                       (sleep 1)))))
 575     (sleep 0.2)
 576     (sb-thread:interrupt-thread thread
 577                                 (lambda ()
 578                                   (throw 'xxx *runningp*)))
 579     (assert (sb-thread:join-thread thread))))
 580
 581 (let (a-done b-done)
 582   (make-thread (lambda ()
 583                  (dotimes (i 100)
 584                    (sb-ext:gc) (princ "\\") (force-output))
 585                  (setf a-done t)))
 586   (make-thread (lambda ()
 587                  (dotimes (i 25)
 588                    (sb-ext:gc :full t)
 589                    (princ "/") (force-output))
 590                  (setf b-done t)))
 591   (loop
 592    (when (and a-done b-done) (return))
 593    (sleep 1)))
 594
 595 (terpri)
 596
 597 (defun waste (&optional (n 100000))
 598   (loop repeat n do (make-string 16384)))
 599
 600 (loop for i below 100 do
 601       (princ "!")
 602       (force-output)
 603       (sb-thread:make-thread
 604        #'(lambda ()
 605            (waste)))
 606       (waste)
 607       (sb-ext:gc))
 608
 609 (terpri)
 610
 611 (defparameter *aaa* nil)
 612 (loop for i below 100 do
 613       (princ "!")
 614       (force-output)
 615       (sb-thread:make-thread
 616        #'(lambda ()
 617            (let ((*aaa* (waste)))
 618              (waste))))
 619       (let ((*aaa* (waste)))
 620         (waste))
 621       (sb-ext:gc))
 622
 623 (format t "~&gc test done~%")
 624
 625 ;; this used to deadlock on session-lock
 626 (sb-thread:make-thread (lambda () (sb-ext:gc)))
 627 ;; expose thread creation races by exiting quickly
 628 (sb-thread:make-thread (lambda ()))
 629
 630 (defun exercise-syscall (fn reference-errno)
 631   (sb-thread:make-thread
 632    (lambda ()
 633      (loop do
 634           (funcall fn)
 635           (let ((errno (sb-unix::get-errno)))
 636             (sleep (random 0.1d0))
 637             (unless (eql errno reference-errno)
 638               (format t "Got errno: ~A (~A) instead of ~A~%"
 639                       errno
 640                       (sb-unix::strerror)
 641                       reference-errno)
 642               (force-output)
 643               (sb-ext:quit :unix-status 1)))))))
 644
 645 ;; (nanosleep -1 0) does not fail on FreeBSD
 646 (let* (#-freebsd
 647        (nanosleep-errno (progn
 648                           (sb-unix:nanosleep -1 0)
 649                           (sb-unix::get-errno)))
 650        (open-errno (progn
 651                      (open "no-such-file"
 652                            :if-does-not-exist nil)
 653                      (sb-unix::get-errno)))
 654        (threads
 655         (list
 656          #-freebsd
 657          (exercise-syscall (lambda () (sb-unix:nanosleep -1 0)) nanosleep-errno)
 658          (exercise-syscall (lambda () (open "no-such-file"
 659                                             :if-does-not-exist nil))
 660                            open-errno)
 661          (sb-thread:make-thread (lambda () (loop (sb-ext:gc) (sleep 1)))))))
 662   (sleep 10)
 663   (princ "terminating threads")
 664   (dolist (thread threads)
 665     (sb-thread:terminate-thread thread)))
 666
 667 (format t "~&errno test done~%")
 668
 669 (loop repeat 100 do
 670       (let ((thread (sb-thread:make-thread (lambda () (sleep 0.1)))))
 671         (sb-thread:interrupt-thread
 672          thread
 673          (lambda ()
 674            (assert (find-restart 'sb-thread:terminate-thread))))))
 675
 676 (sb-ext:gc :full t)
 677
 678 (format t "~&thread startup sigmask test done~%")
 679
 680 ;; FIXME: What is this supposed to test?
 681 (sb-debug::enable-debugger)
 682 (let* ((main-thread *current-thread*)
 683        (interruptor-thread
 684         (make-thread (lambda ()
 685                        (sleep 2)
 686                        (interrupt-thread main-thread
 687                                          (lambda ()
 688                                            (with-interrupts
 689                                              (break))))
 690                        (sleep 2)
 691                        (interrupt-thread main-thread #'continue))
 692                      :name "interruptor")))
 693   (with-session-lock (*session*)
 694     (sleep 3))
 695   (loop while (thread-alive-p interruptor-thread)))
 696
 697 (format t "~&session lock test done~%")
 698
 699 (loop repeat 20 do
 700       (wait-for-threads
 701        (loop for i below 100 collect
 702              (sb-thread:make-thread (lambda ())))))
 703
 704 (format t "~&creation test done~%")
 705
 706 ;; interrupt handlers are per-thread with pthreads, make sure the
 707 ;; handler installed in one thread is global
 708 (sb-thread:make-thread
 709  (lambda ()
 710    (sb-ext:run-program "sleep" '("1") :search t :wait nil)))
 711
 712 ;;;; Binding stack safety
 713
 714 (defparameter *x* nil)
 715 (defparameter *n-gcs-requested* 0)
 716 (defparameter *n-gcs-done* 0)
 717
 718 (let ((counter 0))
 719   (defun make-something-big ()
 720     (let ((x (make-string 32000)))
 721       (incf counter)
 722       (let ((counter counter))
 723         (sb-ext:finalize x (lambda () (format t " ~S" counter)
 724                                    (force-output)))))))
 725
 726 (defmacro wait-for-gc ()
 727   `(progn
 728      (incf *n-gcs-requested*)
 729      (loop while (< *n-gcs-done* *n-gcs-requested*))))
 730
 731 (defun send-gc ()
 732   (loop until (< *n-gcs-done* *n-gcs-requested*))
 733   (format t "G")
 734   (force-output)
 735   (sb-ext:gc)
 736   (incf *n-gcs-done*))
 737
 738 (defun exercise-binding ()
 739   (loop
 740    (let ((*x* (make-something-big)))
 741      (let ((*x* 42))
 742        ;; at this point the binding stack looks like this:
 743        ;; NO-TLS-VALUE-MARKER, *x*, SOMETHING, *x*
 744        t))
 745    (wait-for-gc)
 746    ;; sig_stop_for_gc_handler binds FREE_INTERRUPT_CONTEXT_INDEX. By
 747    ;; now SOMETHING is gc'ed and the binding stack looks like this: 0,
 748    ;; 0, SOMETHING, 0 (because the symbol slots are zeroed on
 749    ;; unbinding but values are not).
 750    (let ((*x* nil))
 751      ;; bump bsp as if a BIND had just started
 752      (incf sb-vm::*binding-stack-pointer* 2)
 753      (wait-for-gc)
 754      (decf sb-vm::*binding-stack-pointer* 2))))
 755
 756 (with-test (:name (:binding-stack-gc-safety))
 757   (let (threads)
 758     (unwind-protect
 759          (progn
 760            (push (sb-thread:make-thread #'exercise-binding) threads)
 761            (push (sb-thread:make-thread (lambda ()
 762                                           (loop
 763                                            (sleep 0.1)
 764                                            (send-gc))))
 765                  threads)
 766            (sleep 4))
 767       (mapc #'sb-thread:terminate-thread threads))))
 768
 769 (format t "~&binding test done~%")
 770
 771 ;;; HASH TABLES
 772
 773 (defvar *errors* nil)
 774
 775 (defun oops (e)
 776   (setf *errors* e)
 777   (format t "~&oops: ~A in ~S~%" e *current-thread*)
 778   (sb-debug:backtrace)
 779   (catch 'done))
 780
 781 (with-test (:name (:unsynchronized-hash-table))
 782   ;; We expect a (probable) error here: parellel readers and writers
 783   ;; on a hash-table are not expected to work -- but we also don't
 784   ;; expect this to corrupt the image.
 785   (let* ((hash (make-hash-table))
 786          (*errors* nil)
 787          (threads (list (sb-thread:make-thread
 788                          (lambda ()
 789                            (catch 'done
 790                              (handler-bind ((serious-condition 'oops))
 791                                (loop
 792                                  ;;(princ "1") (force-output)
 793                                  (setf (gethash (random 100) hash) 'h)))))
 794                          :name "writer")
 795                         (sb-thread:make-thread
 796                          (lambda ()
 797                            (catch 'done
 798                              (handler-bind ((serious-condition 'oops))
 799                                (loop
 800                                  ;;(princ "2") (force-output)
 801                                  (remhash (random 100) hash)))))
 802                          :name "reader")
 803                         (sb-thread:make-thread
 804                          (lambda ()
 805                            (catch 'done
 806                              (handler-bind ((serious-condition 'oops))
 807                                (loop
 808                                  (sleep (random 1.0))
 809                                  (sb-ext:gc :full t)))))
 810                          :name "collector"))))
 811     (unwind-protect
 812          (sleep 10)
 813       (mapc #'sb-thread:terminate-thread threads))))
 814
 815 (format t "~&unsynchronized hash table test done~%")
 816
 817 (with-test (:name (:synchronized-hash-table))
 818   (let* ((hash (make-hash-table :synchronized t))
 819          (*errors* nil)
 820          (threads (list (sb-thread:make-thread
 821                          (lambda ()
 822                            (catch 'done
 823                              (handler-bind ((serious-condition 'oops))
 824                                (loop
 825                                  ;;(princ "1") (force-output)
 826                                  (setf (gethash (random 100) hash) 'h)))))
 827                          :name "writer")
 828                         (sb-thread:make-thread
 829                          (lambda ()
 830                            (catch 'done
 831                              (handler-bind ((serious-condition 'oops))
 832                                (loop
 833                                  ;;(princ "2") (force-output)
 834                                  (remhash (random 100) hash)))))
 835                          :name "reader")
 836                         (sb-thread:make-thread
 837                          (lambda ()
 838                            (catch 'done
 839                              (handler-bind ((serious-condition 'oops))
 840                                (loop
 841                                  (sleep (random 1.0))
 842                                  (sb-ext:gc :full t)))))
 843                          :name "collector"))))
 844     (unwind-protect
 845          (sleep 10)
 846       (mapc #'sb-thread:terminate-thread threads))
 847     (assert (not *errors*))))
 848
 849 (format t "~&synchronized hash table test done~%")
 850
 851 (with-test (:name (:hash-table-parallel-readers))
 852   (let ((hash (make-hash-table))
 853         (*errors* nil))
 854     (loop repeat 50
 855           do (setf (gethash (random 100) hash) 'xxx))
 856     (let ((threads (list (sb-thread:make-thread
 857                           (lambda ()
 858                             (catch 'done
 859                               (handler-bind ((serious-condition 'oops))
 860                                 (loop
 861                                       until (eq t (gethash (random 100) hash))))))
 862                           :name "reader 1")
 863                          (sb-thread:make-thread
 864                           (lambda ()
 865                             (catch 'done
 866                               (handler-bind ((serious-condition 'oops))
 867                                 (loop
 868                                       until (eq t (gethash (random 100) hash))))))
 869                           :name "reader 2")
 870                          (sb-thread:make-thread
 871                           (lambda ()
 872                             (catch 'done
 873                               (handler-bind ((serious-condition 'oops))
 874                                 (loop
 875                                       until (eq t (gethash (random 100) hash))))))
 876                           :name "reader 3")
 877                          (sb-thread:make-thread
 878                           (lambda ()
 879                             (catch 'done
 880                               (handler-bind ((serious-condition 'oops))
 881                                (loop
 882                                  (sleep (random 1.0))
 883                                  (sb-ext:gc :full t)))))
 884                           :name "collector"))))
 885       (unwind-protect
 886            (sleep 10)
 887         (mapc #'sb-thread:terminate-thread threads))
 888       (assert (not *errors*)))))
 889
 890 (format t "~&multiple reader hash table test done~%")
 891
 892 (with-test (:name (:hash-table-single-accessor-parallel-gc))
 893   (let ((hash (make-hash-table))
 894         (*errors* nil))
 895     (let ((threads (list (sb-thread:make-thread
 896                           (lambda ()
 897                             (handler-bind ((serious-condition 'oops))
 898                               (loop
 899                                 (let ((n (random 100)))
 900                                   (if (gethash n hash)
 901                                       (remhash n hash)
 902                                       (setf (gethash n hash) 'h))))))
 903                           :name "accessor")
 904                          (sb-thread:make-thread
 905                           (lambda ()
 906                             (handler-bind ((serious-condition 'oops))
 907                               (loop
 908                                 (sleep (random 1.0))
 909                                 (sb-ext:gc :full t))))
 910                           :name "collector"))))
 911       (unwind-protect
 912            (sleep 10)
 913         (mapc #'sb-thread:terminate-thread threads))
 914       (assert (not *errors*)))))
 915
 916 (format t "~&single accessor hash table test~%")
 917
 918 #|  ;; a cll post from eric marsden
 919 | (defun crash ()
 920 |   (setq *debugger-hook*
 921 |         (lambda (condition old-debugger-hook)
 922 |           (debug:backtrace 10)
 923 |           (unix:unix-exit 2)))
 924 |   #+live-dangerously
 925 |   (mp::start-sigalrm-yield)
 926 |   (flet ((roomy () (loop (with-output-to-string (*standard-output*) (room)))))
 927 |     (mp:make-process #'roomy)
 928 |     (mp:make-process #'roomy)))
 929 |#
 930
 931 ;;; KLUDGE: No deadlines while waiting on lutex-based condition variables. This test
 932 ;;; would just hang.
 933 #-sb-lutex
 934 (with-test (:name (:condition-variable :wait-multiple))
 935   (loop repeat 40 do
 936         (let ((waitqueue (sb-thread:make-waitqueue :name "Q"))
 937               (mutex (sb-thread:make-mutex :name "M"))
 938               (failedp nil))
 939           (format t ".")
 940           (finish-output t)
 941           (let ((threads (loop repeat 200
 942                                collect
 943                                (sb-thread:make-thread
 944                                 (lambda ()
 945                                   (handler-case
 946                                       (sb-sys:with-deadline (:seconds 0.01)
 947                                         (sb-thread:with-mutex (mutex)
 948                                           (sb-thread:condition-wait waitqueue
 949                                                                     mutex)
 950                                           (setq failedp t)))
 951                                     (sb-sys:deadline-timeout (c)
 952                                       (declare (ignore c)))))))))
 953             (mapc #'sb-thread:join-thread threads)
 954             (assert (not failedp))))))
 955
 956 (with-test (:name (:condition-variable :notify-multiple))
 957   (flet ((tester (notify-fun)
 958            (let ((queue (make-waitqueue :name "queue"))
 959                  (lock (make-mutex :name "lock"))
 960                  (data nil))
 961              (labels ((test (x)
 962                         (loop
 963                            (with-mutex (lock)
 964                              (format t "condition-wait ~a~%" x)
 965                              (force-output)
 966                              (condition-wait queue lock)
 967                              (format t "woke up ~a~%" x)
 968                              (force-output)
 969                              (push x data)))))
 970                (let ((threads (loop for x from 1 to 10
 971                                     collect
 972                                     (let ((x x))
 973                                       (sb-thread:make-thread (lambda ()
 974                                                                (test x)))))))
 975                  (sleep 5)
 976                  (with-mutex (lock)
 977                    (funcall notify-fun queue))
 978                  (sleep 5)
 979                  (mapcar #'terminate-thread threads)
 980                  ;; Check that all threads woke up at least once
 981                  (assert (= (length (remove-duplicates data)) 10)))))))
 982     (tester (lambda (queue)
 983               (format t "~&(condition-notify queue 10)~%")
 984               (force-output)
 985               (condition-notify queue 10)))
 986     (tester (lambda (queue)
 987               (format t "~&(condition-broadcast queue)~%")
 988               (force-output)
 989               (condition-broadcast queue)))))
 990
 991 (format t "waitqueue wakeup tests done~%")
 992
 993 ;;; Make sure that a deadline handler is not invoked twice in a row in
 994 ;;; CONDITION-WAIT. See LP #512914 for a detailed explanation.
 995 ;;;
 996 #-sb-lutex    ; See KLUDGE above: no deadlines for condition-wait+lutexes.
 997 (with-test (:name (:condition-wait :deadlines :LP-512914))
 998   (let ((n 2) ; was empirically enough to trigger the bug
 999         (mutex (sb-thread:make-mutex))
1000         (waitq (sb-thread:make-waitqueue))
1001         (threads nil)
1002         (deadline-handler-run-twice? nil))
1003     (dotimes (i n)
1004       (let ((child
1005              (sb-thread:make-thread
1006               #'(lambda ()
1007                   (handler-bind
1008                       ((sb-sys:deadline-timeout
1009                         (let ((already? nil))
1010                           #'(lambda (c)
1011                               (when already?
1012                                 (setq deadline-handler-run-twice? t))
1013                               (setq already? t)
1014                               (sleep 0.2)
1015                               (sb-thread:condition-broadcast waitq)
1016                               (sb-sys:defer-deadline 10.0 c)))))
1017                     (sb-sys:with-deadline (:seconds 0.1)
1018                       (sb-thread:with-mutex (mutex)
1019                         (sb-thread:condition-wait waitq mutex))))))))
1020         (push child threads)))
1021     (mapc #'sb-thread:join-thread threads)
1022     (assert (not deadline-handler-run-twice?))))
1023
1024 (with-test (:name (:condition-wait :signal-deadline-with-interrupts-enabled))
1025   (let ((mutex (sb-thread:make-mutex))
1026         (waitq (sb-thread:make-waitqueue))
1027         (A-holds? :unknown)
1028         (B-holds? :unknown)
1029         (A-interrupts-enabled? :unknown)
1030         (B-interrupts-enabled? :unknown)
1031         (A)
1032         (B))
1033     ;; W.L.O.G., we assume that A is executed first...
1034     (setq A (sb-thread:make-thread
1035              #'(lambda ()
1036                  (handler-bind
1037                      ((sb-sys:deadline-timeout
1038                        #'(lambda (c)
1039                            ;; We came here through the call to DECODE-TIMEOUT
1040                            ;; in CONDITION-WAIT; hence both here are supposed
1041                            ;; to evaluate to T.
1042                            (setq A-holds? (sb-thread:holding-mutex-p mutex))
1043                            (setq A-interrupts-enabled?
1044                                  sb-sys:*interrupts-enabled*)
1045                            (sleep 0.2)
1046                            (sb-thread:condition-broadcast waitq)
1047                            (sb-sys:defer-deadline 10.0 c))))
1048                    (sb-sys:with-deadline (:seconds 0.1)
1049                      (sb-thread:with-mutex (mutex)
1050                        (sb-thread:condition-wait waitq mutex)))))))
1051     (setq B (sb-thread:make-thread
1052              #'(lambda ()
1053                  (thread-yield)
1054                  (handler-bind
1055                      ((sb-sys:deadline-timeout
1056                        #'(lambda (c)
1057                            ;; We came here through the call to GET-MUTEX
1058                            ;; in CONDITION-WAIT (contended case of
1059                            ;; reaquiring the mutex) - so the former will
1060                            ;; be NIL, but interrupts should still be enabled.
1061                            (setq B-holds? (sb-thread:holding-mutex-p mutex))
1062                            (setq B-interrupts-enabled?
1063                                  sb-sys:*interrupts-enabled*)
1064                            (sleep 0.2)
1065                            (sb-thread:condition-broadcast waitq)
1066                            (sb-sys:defer-deadline 10.0 c))))
1067                    (sb-sys:with-deadline (:seconds 0.1)
1068                      (sb-thread:with-mutex (mutex)
1069                        (sb-thread:condition-wait waitq mutex)))))))
1070     (sb-thread:join-thread A)
1071     (sb-thread:join-thread B)
1072     (let ((A-result (list A-holds? A-interrupts-enabled?))
1073           (B-result (list B-holds? B-interrupts-enabled?)))
1074       ;; We also check some subtle behaviour w.r.t. whether a deadline
1075       ;; handler in CONDITION-WAIT got the mutex, or not. This is most
1076       ;; probably very internal behaviour (so user should not depend
1077       ;; on it) -- I added the testing here just to manifest current
1078       ;; behaviour.
1079       (cond ((equal A-result '(t t)) (assert (equal B-result '(nil t))))
1080             ((equal B-result '(t t)) (assert (equal A-result '(nil t))))
1081             (t (error "Failure: fall through."))))))
1082
1083 (with-test (:name (:mutex :finalization))
1084   (let ((a nil))
1085     (dotimes (i 500000)
1086       (setf a (make-mutex)))))
1087
1088 (format t "mutex finalization test done~%")
1089
1090 ;;; Check that INFO is thread-safe, at least when we're just doing reads.
1091
1092 (let* ((symbols (loop repeat 10000 collect (gensym)))
1093        (functions (loop for (symbol . rest) on symbols
1094                         for next = (car rest)
1095                         for fun = (let ((next next))
1096                                     (lambda (n)
1097                                       (if next
1098                                           (funcall next (1- n))
1099                                           n)))
1100                         do (setf (symbol-function symbol) fun)
1101                         collect fun)))
1102   (defun infodb-test ()
1103     (funcall (car functions) 9999)))
1104
1105 (with-test (:name (:infodb :read))
1106   (let* ((ok t)
1107          (threads (loop for i from 0 to 10
1108                         collect (sb-thread:make-thread
1109                                  (lambda ()
1110                                    (dotimes (j 100)
1111                                      (write-char #\-)
1112                                      (finish-output)
1113                                      (let ((n (infodb-test)))
1114                                        (unless (zerop n)
1115                                          (setf ok nil)
1116                                          (format t "N != 0 (~A)~%" n)
1117                                          (sb-ext:quit)))))))))
1118     (wait-for-threads threads)
1119     (assert ok)))
1120
1121 (format t "infodb test done~%")
1122
1123 (with-test (:name (:backtrace))
1124   ;; Printing backtraces from several threads at once used to hang the
1125   ;; whole SBCL process (discovered by accident due to a timer.impure
1126   ;; test misbehaving). The cause was that packages weren't even
1127   ;; thread-safe for only doing FIND-SYMBOL, and while printing
1128   ;; backtraces a loot of symbol lookups need to be done due to
1129   ;; *PRINT-ESCAPE*.
1130   (let* ((threads (loop repeat 10
1131                         collect (sb-thread:make-thread
1132                                  (lambda ()
1133                                    (dotimes (i 1000)
1134                                      (with-output-to-string (*debug-io*)
1135                                        (sb-debug::backtrace 10))))))))
1136     (wait-for-threads threads)))
1137
1138 (format t "backtrace test done~%")
1139
1140 (format t "~&starting gc deadlock test: WARNING: THIS TEST WILL HANG ON FAILURE!~%")
1141
1142 (with-test (:name (:gc-deadlock))
1143   ;; Prior to 0.9.16.46 thread exit potentially deadlocked the
1144   ;; GC due to *all-threads-lock* and session lock. On earlier
1145   ;; versions and at least on one specific box this test is good enough
1146   ;; to catch that typically well before the 1500th iteration.
1147   (loop
1148      with i = 0
1149      with n = 3000
1150      while (< i n)
1151      do
1152        (incf i)
1153        (when (zerop (mod i 100))
1154          (write-char #\.)
1155          (force-output))
1156        (handler-case
1157            (if (oddp i)
1158                (sb-thread:make-thread
1159                 (lambda ()
1160                   (sleep (random 0.001)))
1161                 :name (list :sleep i))
1162                (sb-thread:make-thread
1163                 (lambda ()
1164                   ;; KLUDGE: what we are doing here is explicit,
1165                   ;; but the same can happen because of a regular
1166                   ;; MAKE-THREAD or LIST-ALL-THREADS, and various
1167                   ;; session functions.
1168                   (sb-thread::with-all-threads-lock
1169                     (sb-thread::with-session-lock (sb-thread::*session*)
1170                       (sb-ext:gc))))
1171                 :name (list :gc i)))
1172          (error (e)
1173            (format t "~%error creating thread ~D: ~A -- backing off for retry~%" i e)
1174            (sleep 0.1)
1175            (incf i)))))
1176
1177 (format t "~&gc deadlock test done~%")
1178 \f
1179 (let ((count (make-array 8 :initial-element 0)))
1180   (defun closure-one ()
1181     (declare (optimize safety))
1182     (values (incf (aref count 0)) (incf (aref count 1))
1183             (incf (aref count 2)) (incf (aref count 3))
1184             (incf (aref count 4)) (incf (aref count 5))
1185             (incf (aref count 6)) (incf (aref count 7))))
1186   (defun no-optimizing-away-closure-one ()
1187     (setf count (make-array 8 :initial-element 0))))
1188
1189 (defstruct box
1190   (count 0))
1191
1192 (let ((one (make-box))
1193       (two (make-box))
1194       (three (make-box)))
1195   (defun closure-two ()
1196     (declare (optimize safety))
1197     (values (incf (box-count one)) (incf (box-count two)) (incf (box-count three))))
1198   (defun no-optimizing-away-closure-two ()
1199     (setf one (make-box)
1200           two (make-box)
1201           three (make-box))))
1202
1203 (with-test (:name (:funcallable-instances))
1204   ;; the funcallable-instance implementation used not to be threadsafe
1205   ;; against setting the funcallable-instance function to a closure
1206   ;; (because the code and lexenv were set separately).
1207   (let ((fun (sb-kernel:%make-funcallable-instance 0))
1208         (condition nil))
1209     (setf (sb-kernel:funcallable-instance-fun fun) #'closure-one)
1210     (flet ((changer ()
1211              (loop (setf (sb-kernel:funcallable-instance-fun fun) #'closure-one)
1212                    (setf (sb-kernel:funcallable-instance-fun fun) #'closure-two)))
1213            (test ()
1214              (handler-case (loop (funcall fun))
1215                (serious-condition (c) (setf condition c)))))
1216       (let ((changer (make-thread #'changer))
1217             (test (make-thread #'test)))
1218         (handler-case
1219             (progn
1220               ;; The two closures above are fairly carefully crafted
1221               ;; so that if given the wrong lexenv they will tend to
1222               ;; do some serious damage, but it is of course difficult
1223               ;; to predict where the various bits and pieces will be
1224               ;; allocated.  Five seconds failed fairly reliably on
1225               ;; both my x86 and x86-64 systems.  -- CSR, 2006-09-27.
1226               (sb-ext:with-timeout 5
1227                 (wait-for-threads (list test)))
1228               (error "~@<test thread got condition:~2I~_~A~@:>" condition))
1229           (sb-ext:timeout ()
1230             (terminate-thread changer)
1231             (terminate-thread test)
1232             (wait-for-threads (list changer test))))))))
1233
1234 (format t "~&funcallable-instance test done~%")
1235
1236 (defun random-type (n)
1237   `(integer ,(random n) ,(+ n (random n))))
1238
1239 (defun subtypep-hash-cache-test ()
1240   (dotimes (i 10000)
1241     (let ((type1 (random-type 500))
1242           (type2 (random-type 500)))
1243       (let ((a (subtypep type1 type2)))
1244         (dotimes (i 100)
1245           (assert (eq (subtypep type1 type2) a))))))
1246   (format t "ok~%")
1247   (force-output))
1248
1249 (with-test (:name '(:hash-cache :subtypep))
1250   (dotimes (i 10)
1251     (sb-thread:make-thread #'subtypep-hash-cache-test)))
1252 (format t "hash-cache tests done~%")
1253
1254 ;;;; BLACK BOX TESTS
1255
1256 (in-package :cl-user)
1257 (use-package :test-util)
1258 (use-package "ASSERTOID")
1259
1260 (format t "parallel defclass test -- WARNING, WILL HANG ON FAILURE!~%")
1261 (with-test (:name :parallel-defclass)
1262   (defclass test-1 () ((a :initform :orig-a)))
1263   (defclass test-2 () ((b :initform :orig-b)))
1264   (defclass test-3 (test-1 test-2) ((c :initform :orig-c)))
1265   (let* ((run t)
1266          (d1 (sb-thread:make-thread (lambda ()
1267                                       (loop while run
1268                                             do (defclass test-1 () ((a :initform :new-a)))
1269                                             (write-char #\1)
1270                                             (force-output)))
1271                                     :name "d1"))
1272          (d2 (sb-thread:make-thread (lambda ()
1273                                       (loop while run
1274                                             do (defclass test-2 () ((b :initform :new-b)))
1275                                                (write-char #\2)
1276                                                (force-output)))
1277                                     :name "d2"))
1278          (d3 (sb-thread:make-thread (lambda ()
1279                                       (loop while run
1280                                             do (defclass test-3 (test-1 test-2) ((c :initform :new-c)))
1281                                                (write-char #\3)
1282                                                (force-output)))
1283                                     :name "d3"))
1284          (i (sb-thread:make-thread (lambda ()
1285                                      (loop while run
1286                                            do (let ((i (make-instance 'test-3)))
1287                                                 (assert (member (slot-value i 'a) '(:orig-a :new-a)))
1288                                                 (assert (member (slot-value i 'b) '(:orig-b :new-b)))
1289                                                 (assert (member (slot-value i 'c) '(:orig-c :new-c))))
1290                                               (write-char #\i)
1291                                               (force-output)))
1292                                    :name "i")))
1293     (format t "~%sleeping!~%")
1294     (sleep 2.0)
1295     (format t "~%stopping!~%")
1296     (setf run nil)
1297     (mapc (lambda (th)
1298             (sb-thread:join-thread th)
1299             (format t "~%joined ~S~%" (sb-thread:thread-name th)))
1300           (list d1 d2 d3 i))))
1301 (format t "parallel defclass test done~%")