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