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-thread (sb-ext:quit :unix-status 104)
  46
  47 ;;; compare-and-swap
  48
  49 (defmacro defincf (name accessor &rest args)
  50   `(defun ,name (x)
  51      (let* ((old (,accessor x ,@args))
  52          (new (1+ old)))
  53     (loop until (eq old (sb-ext:compare-and-swap (,accessor x ,@args) old new))
  54        do (setf old (,accessor x ,@args)
  55                 new (1+ old)))
  56     new)))
  57
  58 (defstruct cas-struct (slot 0))
  59
  60 (defincf incf-car car)
  61 (defincf incf-cdr cdr)
  62 (defincf incf-slot cas-struct-slot)
  63 (defincf incf-symbol-value symbol-value)
  64 (defincf incf-svref/1 svref 1)
  65 (defincf incf-svref/0 svref 0)
  66
  67 (defmacro def-test-cas (name init incf op)
  68   `(progn
  69      (defun ,name (n)
  70        (declare (fixnum n))
  71        (let* ((x ,init)
  72               (run nil)
  73               (threads
  74                (loop repeat 10
  75                      collect (sb-thread:make-thread
  76                               (lambda ()
  77                                 (loop until run
  78                                    do (sb-thread:thread-yield))
  79                                 (loop repeat n do (,incf x)))))))
  80          (setf run t)
  81          (dolist (th threads)
  82            (sb-thread:join-thread th))
  83          (assert (= (,op x) (* 10 n)))))
  84      (,name 200000)))
  85
  86 (def-test-cas test-cas-car (cons 0 nil) incf-car car)
  87 (def-test-cas test-cas-cdr (cons nil 0) incf-cdr cdr)
  88 (def-test-cas test-cas-slot (make-cas-struct) incf-slot cas-struct-slot)
  89 (def-test-cas test-cas-value (let ((x '.x.))
  90                                (set x 0)
  91                                x)
  92   incf-symbol-value symbol-value)
  93 (def-test-cas test-cas-svref/0 (vector 0 nil) incf-svref/0 (lambda (x)
  94                                                              (svref x 0)))
  95 (def-test-cas test-cas-svref/1 (vector nil 0) incf-svref/1 (lambda (x)
  96                                                              (svref x 1)))
  97 (format t "~&compare-and-swap tests done~%")
  98
  99 (let ((old-threads (list-all-threads))
 100       (thread (make-thread (lambda ()
 101                              (assert (find *current-thread* *all-threads*))
 102                              (sleep 2))))
 103       (new-threads (list-all-threads)))
 104   (assert (thread-alive-p thread))
 105   (assert (eq thread (first new-threads)))
 106   (assert (= (1+ (length old-threads)) (length new-threads)))
 107   (sleep 3)
 108   (assert (not (thread-alive-p thread))))
 109
 110 (with-test (:name '(:join-thread :nlx :default))
 111   (let ((sym (gensym)))
 112     (assert (eq sym (join-thread (make-thread (lambda () (sb-ext:quit)))
 113                                  :default sym)))))
 114
 115 (with-test (:name '(:join-thread :nlx :error))
 116   (raises-error? (join-thread (make-thread (lambda () (sb-ext:quit))))
 117                  join-thread-error))
 118
 119 (with-test (:name '(:join-thread :multiple-values))
 120   (assert (equal '(1 2 3)
 121                  (multiple-value-list
 122                   (join-thread (make-thread (lambda () (values 1 2 3))))))))
 123
 124 ;;; We had appalling scaling properties for a while.  Make sure they
 125 ;;; don't reappear.
 126 (defun scaling-test (function &optional (nthreads 5))
 127   "Execute FUNCTION with NTHREADS lurking to slow it down."
 128   (let ((queue (sb-thread:make-waitqueue))
 129         (mutex (sb-thread:make-mutex)))
 130     ;; Start NTHREADS idle threads.
 131     (dotimes (i nthreads)
 132       (sb-thread:make-thread (lambda ()
 133                                (with-mutex (mutex)
 134                                  (sb-thread:condition-wait queue mutex))
 135                                (sb-ext:quit))))
 136     (let ((start-time (get-internal-run-time)))
 137       (funcall function)
 138       (prog1 (- (get-internal-run-time) start-time)
 139         (sb-thread:condition-broadcast queue)))))
 140 (defun fact (n)
 141   "A function that does work with the CPU."
 142   (if (zerop n) 1 (* n (fact (1- n)))))
 143 (let ((work (lambda () (fact 15000))))
 144   (let ((zero (scaling-test work 0))
 145         (four (scaling-test work 4)))
 146     ;; a slightly weak assertion, but good enough for starters.
 147     (assert (< four (* 1.5 zero)))))
 148
 149 ;;; For one of the interupt-thread tests, we want a foreign function
 150 ;;; that does not make syscalls
 151
 152 (with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede)
 153   (format o "void loop_forever() { while(1) ; }~%"))
 154 (sb-ext:run-program
 155  #-sunos "cc" #+sunos "gcc"
 156  (or #+(or linux freebsd sunos) '(#+x86-64 "-fPIC"
 157                                   "-shared" "-o" "threads-foreign.so" "threads-foreign.c")
 158      #+darwin '(#+x86-64 "-arch" #+x86-64 "x86_64"
 159                 "-dynamiclib" "-o" "threads-foreign.so" "threads-foreign.c")
 160      (error "Missing shared library compilation options for this platform"))
 161  :search t)
 162 (sb-alien:load-shared-object (truename "threads-foreign.so"))
 163 (sb-alien:define-alien-routine loop-forever sb-alien:void)
 164 (delete-file "threads-foreign.c")
 165
 166 ;;; elementary "can we get a lock and release it again"
 167 (let ((l (make-mutex :name "foo"))
 168       (p *current-thread*))
 169   (assert (eql (mutex-value l) nil) nil "1")
 170   (sb-thread:get-mutex l)
 171   (assert (eql (mutex-value l) p) nil "3")
 172   (sb-thread:release-mutex l)
 173   (assert (eql (mutex-value l) nil) nil "5"))
 174
 175 (labels ((ours-p (value)
 176            (eq *current-thread* value)))
 177   (let ((l (make-mutex :name "rec")))
 178     (assert (eql (mutex-value l) nil) nil "1")
 179     (sb-thread:with-recursive-lock (l)
 180       (assert (ours-p (mutex-value l)) nil "3")
 181       (sb-thread:with-recursive-lock (l)
 182         (assert (ours-p (mutex-value l)) nil "4"))
 183       (assert (ours-p (mutex-value l)) nil "5"))
 184     (assert (eql (mutex-value l) nil) nil "6")))
 185
 186 (labels ((ours-p (value)
 187            (eq *current-thread* value)))
 188   (let ((l (make-spinlock :name "rec")))
 189     (assert (eql (spinlock-value l) nil) nil "1")
 190     (with-recursive-spinlock (l)
 191       (assert (ours-p (spinlock-value l)) nil "3")
 192       (with-recursive-spinlock (l)
 193         (assert (ours-p (spinlock-value l)) nil "4"))
 194       (assert (ours-p (spinlock-value l)) nil "5"))
 195     (assert (eql (spinlock-value l) nil) nil "6")))
 196
 197 (with-test (:name (:mutex :nesting-mutex-and-recursive-lock))
 198   (let ((l (make-mutex :name "a mutex")))
 199     (with-mutex (l)
 200       (with-recursive-lock (l)))))
 201
 202 (with-test (:name (:spinlock :nesting-spinlock-and-recursive-spinlock))
 203   (let ((l (make-spinlock :name "a spinlock")))
 204     (with-spinlock (l)
 205       (with-recursive-spinlock (l)))))
 206
 207 (let ((l (make-spinlock :name "spinlock")))
 208   (assert (eql (spinlock-value l) nil) ((spinlock-value l))
 209           "spinlock not free (1)")
 210   (with-spinlock (l)
 211     (assert (eql (spinlock-value l) *current-thread*) ((spinlock-value l))
 212             "spinlock not taken"))
 213   (assert (eql (spinlock-value l) nil) ((spinlock-value l))
 214           "spinlock not free (2)"))
 215
 216 ;; test that SLEEP actually sleeps for at least the given time, even
 217 ;; if interrupted by another thread exiting/a gc/anything
 218 (let ((start-time (get-universal-time)))
 219   (make-thread (lambda () (sleep 1) (sb-ext:gc :full t)))
 220   (sleep 5)
 221   (assert (>= (get-universal-time) (+ 5 start-time))))
 222
 223
 224 (let ((queue (make-waitqueue :name "queue"))
 225       (lock (make-mutex :name "lock"))
 226       (n 0))
 227   (labels ((in-new-thread ()
 228              (with-mutex (lock)
 229                (assert (eql (mutex-value lock) *current-thread*))
 230                (format t "~A got mutex~%" *current-thread*)
 231                ;; now drop it and sleep
 232                (condition-wait queue lock)
 233                ;; after waking we should have the lock again
 234                (assert (eql (mutex-value lock) *current-thread*))
 235                (assert (eql n 1))
 236                (decf n))))
 237     (make-thread #'in-new-thread)
 238     (sleep 2)                           ; give it  a chance to start
 239     ;; check the lock is free while it's asleep
 240     (format t "parent thread ~A~%" *current-thread*)
 241     (assert (eql (mutex-value lock) nil))
 242     (with-mutex (lock)
 243       (incf n)
 244       (condition-notify queue))
 245     (sleep 1)))
 246
 247 (let ((queue (make-waitqueue :name "queue"))
 248       (lock (make-mutex :name "lock")))
 249   (labels ((ours-p (value)
 250              (eq *current-thread* value))
 251            (in-new-thread ()
 252              (with-recursive-lock (lock)
 253                (assert (ours-p (mutex-value lock)))
 254                (format t "~A got mutex~%" (mutex-value lock))
 255                ;; now drop it and sleep
 256                (condition-wait queue lock)
 257                ;; after waking we should have the lock again
 258                (format t "woken, ~A got mutex~%" (mutex-value lock))
 259                (assert (ours-p (mutex-value lock))))))
 260     (make-thread #'in-new-thread)
 261     (sleep 2)                           ; give it  a chance to start
 262     ;; check the lock is free while it's asleep
 263     (format t "parent thread ~A~%" *current-thread*)
 264     (assert (eql (mutex-value lock) nil))
 265     (with-recursive-lock (lock)
 266       (condition-notify queue))
 267     (sleep 1)))
 268
 269 (let ((mutex (make-mutex :name "contended")))
 270   (labels ((run ()
 271              (let ((me *current-thread*))
 272                (dotimes (i 100)
 273                  (with-mutex (mutex)
 274                    (sleep .03)
 275                    (assert (eql (mutex-value mutex) me)))
 276                  (assert (not (eql (mutex-value mutex) me))))
 277                (format t "done ~A~%" *current-thread*))))
 278     (let ((kid1 (make-thread #'run))
 279           (kid2 (make-thread #'run)))
 280       (format t "contention ~A ~A~%" kid1 kid2)
 281       (wait-for-threads (list kid1 kid2)))))
 282
 283 ;;; semaphores
 284
 285 (defmacro raises-timeout-p (&body body)
 286   `(handler-case (progn (progn ,@body) nil)
 287     (sb-ext:timeout () t)))
 288
 289 (with-test (:name (:semaphore :wait-forever))
 290   (let ((sem (make-semaphore :count 0)))
 291     (assert (raises-timeout-p
 292               (sb-ext:with-timeout 0.1
 293                 (wait-on-semaphore sem))))))
 294
 295 (with-test (:name (:semaphore :initial-count))
 296   (let ((sem (make-semaphore :count 1)))
 297     (sb-ext:with-timeout 0.1
 298       (wait-on-semaphore sem))))
 299
 300 (with-test (:name (:semaphore :wait-then-signal))
 301   (let ((sem (make-semaphore))
 302         (signalled-p nil))
 303     (make-thread (lambda ()
 304                    (sleep 0.1)
 305                    (setq signalled-p t)
 306                    (signal-semaphore sem)))
 307     (wait-on-semaphore sem)
 308     (assert signalled-p)))
 309
 310 (with-test (:name (:semaphore :signal-then-wait))
 311   (let ((sem (make-semaphore))
 312         (signalled-p nil))
 313     (make-thread (lambda ()
 314                    (signal-semaphore sem)
 315                    (setq signalled-p t)))
 316     (loop until signalled-p)
 317     (wait-on-semaphore sem)
 318     (assert signalled-p)))
 319
 320 (with-test (:name (:semaphore :multiple-signals))
 321   (let* ((sem (make-semaphore :count 5))
 322          (threads (loop repeat 20
 323                         collect (make-thread (lambda ()
 324                                                (wait-on-semaphore sem))))))
 325     (flet ((count-live-threads ()
 326              (count-if #'thread-alive-p threads)))
 327       (sleep 0.5)
 328       (assert (= 15 (count-live-threads)))
 329       (signal-semaphore sem 10)
 330       (sleep 0.5)
 331       (assert (= 5 (count-live-threads)))
 332       (signal-semaphore sem 3)
 333       (sleep 0.5)
 334       (assert (= 2 (count-live-threads)))
 335       (signal-semaphore sem 4)
 336       (sleep 0.5)
 337       (assert (= 0 (count-live-threads))))))
 338
 339 (format t "~&semaphore tests done~%")
 340
 341 (defun test-interrupt (function-to-interrupt &optional quit-p)
 342   (let ((child  (make-thread function-to-interrupt)))
 343     ;;(format t "gdb ./src/runtime/sbcl ~A~%attach ~A~%" child child)
 344     (sleep 2)
 345     (format t "interrupting child ~A~%" child)
 346     (interrupt-thread child
 347                       (lambda ()
 348                         (format t "child pid ~A~%" *current-thread*)
 349                         (when quit-p (sb-ext:quit))))
 350     (sleep 1)
 351     child))
 352
 353 ;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
 354 ;; (d) waiting on a lock, (e) some code which we hope is likely to be
 355 ;; in pseudo-atomic
 356
 357 (let ((child (test-interrupt (lambda () (loop)))))  (terminate-thread child))
 358
 359 (test-interrupt #'loop-forever :quit)
 360
 361 (let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
 362   (terminate-thread child)
 363   (wait-for-threads (list child)))
 364
 365 (let ((lock (make-mutex :name "loctite"))
 366       child)
 367   (with-mutex (lock)
 368     (setf child (test-interrupt
 369                  (lambda ()
 370                    (with-mutex (lock)
 371                      (assert (eql (mutex-value lock) *current-thread*)))
 372                    (assert (not (eql (mutex-value lock) *current-thread*)))
 373                    (sleep 10))))
 374     ;;hold onto lock for long enough that child can't get it immediately
 375     (sleep 5)
 376     (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock))))
 377     (format t "parent releasing lock~%"))
 378   (terminate-thread child)
 379   (wait-for-threads (list child)))
 380
 381 (format t "~&locking test done~%")
 382
 383 (defun alloc-stuff () (copy-list '(1 2 3 4 5)))
 384
 385 (progn
 386   (let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff))))))
 387     (let ((killers
 388            (loop repeat 4 collect
 389                  (sb-thread:make-thread
 390                   (lambda ()
 391                     (loop repeat 25 do
 392                           (sleep (random 0.1d0))
 393                           (princ ".")
 394                           (force-output)
 395                           (sb-thread:interrupt-thread thread (lambda ()))))))))
 396       (wait-for-threads killers)
 397       (sb-thread:terminate-thread thread)
 398       (wait-for-threads (list thread))))
 399   (sb-ext:gc :full t))
 400
 401 (format t "~&multi interrupt test done~%")
 402
 403 (let ((c (make-thread (lambda () (loop (alloc-stuff))))))
 404   ;; NB this only works on x86: other ports don't have a symbol for
 405   ;; pseudo-atomic atomicity
 406   (dotimes (i 100)
 407     (sleep (random 0.1d0))
 408     (interrupt-thread c
 409                       (lambda ()
 410                         (princ ".") (force-output)
 411                         (assert (thread-alive-p *current-thread*))
 412                         (assert
 413                          (not (logbitp 0 SB-KERNEL:*PSEUDO-ATOMIC-BITS*))))))
 414   (terminate-thread c)
 415   (wait-for-threads (list c)))
 416
 417 (format t "~&interrupt test done~%")
 418
 419 (defparameter *interrupt-count* 0)
 420
 421 (declaim (notinline check-interrupt-count))
 422 (defun check-interrupt-count (i)
 423   (declare (optimize (debug 1) (speed 1)))
 424   ;; This used to lose if eflags were not restored after an interrupt.
 425   (unless (typep i 'fixnum)
 426     (error "!!!!!!!!!!!")))
 427
 428 (let ((c (make-thread
 429           (lambda ()
 430             (handler-bind ((error #'(lambda (cond)
 431                                       (princ cond)
 432                                       (sb-debug:backtrace
 433                                        most-positive-fixnum))))
 434               (loop (check-interrupt-count *interrupt-count*)))))))
 435   (let ((func (lambda ()
 436                 (princ ".")
 437                 (force-output)
 438                 (sb-impl::atomic-incf/symbol *interrupt-count*))))
 439     (setq *interrupt-count* 0)
 440     (dotimes (i 100)
 441       (sleep (random 0.1d0))
 442       (interrupt-thread c func))
 443     (loop until (= *interrupt-count* 100) do (sleep 0.1))
 444     (terminate-thread c)
 445     (wait-for-threads (list c))))
 446
 447 (format t "~&interrupt count test done~%")
 448
 449 (let (a-done b-done)
 450   (make-thread (lambda ()
 451                  (dotimes (i 100)
 452                    (sb-ext:gc) (princ "\\") (force-output))
 453                  (setf a-done t)))
 454   (make-thread (lambda ()
 455                  (dotimes (i 25)
 456                    (sb-ext:gc :full t)
 457                    (princ "/") (force-output))
 458                  (setf b-done t)))
 459   (loop
 460    (when (and a-done b-done) (return))
 461    (sleep 1)))
 462
 463 (terpri)
 464
 465 (defun waste (&optional (n 100000))
 466   (loop repeat n do (make-string 16384)))
 467
 468 (loop for i below 100 do
 469       (princ "!")
 470       (force-output)
 471       (sb-thread:make-thread
 472        #'(lambda ()
 473            (waste)))
 474       (waste)
 475       (sb-ext:gc))
 476
 477 (terpri)
 478
 479 (defparameter *aaa* nil)
 480 (loop for i below 100 do
 481       (princ "!")
 482       (force-output)
 483       (sb-thread:make-thread
 484        #'(lambda ()
 485            (let ((*aaa* (waste)))
 486              (waste))))
 487       (let ((*aaa* (waste)))
 488         (waste))
 489       (sb-ext:gc))
 490
 491 (format t "~&gc test done~%")
 492
 493 ;; this used to deadlock on session-lock
 494 (sb-thread:make-thread (lambda () (sb-ext:gc)))
 495 ;; expose thread creation races by exiting quickly
 496 (sb-thread:make-thread (lambda ()))
 497
 498 (defun exercise-syscall (fn reference-errno)
 499   (sb-thread:make-thread
 500    (lambda ()
 501      (loop do
 502           (funcall fn)
 503           (let ((errno (sb-unix::get-errno)))
 504             (sleep (random 0.1d0))
 505             (unless (eql errno reference-errno)
 506               (format t "Got errno: ~A (~A) instead of ~A~%"
 507                       errno
 508                       (sb-unix::strerror)
 509                       reference-errno)
 510               (force-output)
 511               (sb-ext:quit :unix-status 1)))))))
 512
 513 ;; (nanosleep -1 0) does not fail on FreeBSD
 514 (let* (#-freebsd
 515        (nanosleep-errno (progn
 516                           (sb-unix:nanosleep -1 0)
 517                           (sb-unix::get-errno)))
 518        (open-errno (progn
 519                      (open "no-such-file"
 520                            :if-does-not-exist nil)
 521                      (sb-unix::get-errno)))
 522        (threads
 523         (list
 524          #-freebsd
 525          (exercise-syscall (lambda () (sb-unix:nanosleep -1 0)) nanosleep-errno)
 526          (exercise-syscall (lambda () (open "no-such-file"
 527                                             :if-does-not-exist nil))
 528                            open-errno)
 529          (sb-thread:make-thread (lambda () (loop (sb-ext:gc) (sleep 1)))))))
 530   (sleep 10)
 531   (princ "terminating threads")
 532   (dolist (thread threads)
 533     (sb-thread:terminate-thread thread)))
 534
 535 (format t "~&errno test done~%")
 536
 537 (loop repeat 100 do
 538       (let ((thread (sb-thread:make-thread (lambda () (sleep 0.1)))))
 539         (sb-thread:interrupt-thread
 540          thread
 541          (lambda ()
 542            (assert (find-restart 'sb-thread:terminate-thread))))))
 543
 544 (sb-ext:gc :full t)
 545
 546 (format t "~&thread startup sigmask test done~%")
 547
 548 ;; FIXME: What is this supposed to test?
 549 (sb-debug::enable-debugger)
 550 (let* ((main-thread *current-thread*)
 551        (interruptor-thread
 552         (make-thread (lambda ()
 553                        (sleep 2)
 554                        (interrupt-thread main-thread #'break)
 555                        (sleep 2)
 556                        (interrupt-thread main-thread #'continue))
 557                      :name "interruptor")))
 558   (with-session-lock (*session*)
 559     (sleep 3))
 560   (loop while (thread-alive-p interruptor-thread)))
 561
 562 (format t "~&session lock test done~%")
 563
 564 (loop repeat 20 do
 565       (wait-for-threads
 566        (loop for i below 100 collect
 567              (sb-thread:make-thread (lambda ())))))
 568
 569 (format t "~&creation test done~%")
 570
 571 ;; interrupt handlers are per-thread with pthreads, make sure the
 572 ;; handler installed in one thread is global
 573 (sb-thread:make-thread
 574  (lambda ()
 575    (sb-ext:run-program "sleep" '("1") :search t :wait nil)))
 576
 577 ;;;; Binding stack safety
 578
 579 (defparameter *x* nil)
 580 (defparameter *n-gcs-requested* 0)
 581 (defparameter *n-gcs-done* 0)
 582
 583 (let ((counter 0))
 584   (defun make-something-big ()
 585     (let ((x (make-string 32000)))
 586       (incf counter)
 587       (let ((counter counter))
 588         (sb-ext:finalize x (lambda () (format t " ~S" counter)
 589                                    (force-output)))))))
 590
 591 (defmacro wait-for-gc ()
 592   `(progn
 593      (incf *n-gcs-requested*)
 594      (loop while (< *n-gcs-done* *n-gcs-requested*))))
 595
 596 (defun send-gc ()
 597   (loop until (< *n-gcs-done* *n-gcs-requested*))
 598   (format t "G")
 599   (force-output)
 600   (sb-ext:gc)
 601   (incf *n-gcs-done*))
 602
 603 (defun exercise-binding ()
 604   (loop
 605    (let ((*x* (make-something-big)))
 606      (let ((*x* 42))
 607        ;; at this point the binding stack looks like this:
 608        ;; NO-TLS-VALUE-MARKER, *x*, SOMETHING, *x*
 609        t))
 610    (wait-for-gc)
 611    ;; sig_stop_for_gc_handler binds FREE_INTERRUPT_CONTEXT_INDEX. By
 612    ;; now SOMETHING is gc'ed and the binding stack looks like this: 0,
 613    ;; 0, SOMETHING, 0 (because the symbol slots are zeroed on
 614    ;; unbinding but values are not).
 615    (let ((*x* nil))
 616      ;; bump bsp as if a BIND had just started
 617      (incf sb-vm::*binding-stack-pointer* 2)
 618      (wait-for-gc)
 619      (decf sb-vm::*binding-stack-pointer* 2))))
 620
 621 (with-test (:name (:binding-stack-gc-safety))
 622   (let (threads)
 623     (unwind-protect
 624          (progn
 625            (push (sb-thread:make-thread #'exercise-binding) threads)
 626            (push (sb-thread:make-thread (lambda ()
 627                                           (loop
 628                                            (sleep 0.1)
 629                                            (send-gc))))
 630                  threads)
 631            (sleep 4))
 632       (mapc #'sb-thread:terminate-thread threads))))
 633
 634 (format t "~&binding test done~%")
 635
 636 ;;; HASH TABLES
 637
 638 (defvar *errors* nil)
 639
 640 (defun oops (e)
 641   (setf *errors* e)
 642   (format t "~&oops: ~A in ~S~%" e *current-thread*)
 643   (sb-debug:backtrace)
 644   (catch 'done))
 645
 646 (with-test (:name (:unsynchronized-hash-table))
 647   ;; We expect a (probable) error here: parellel readers and writers
 648   ;; on a hash-table are not expected to work -- but we also don't
 649   ;; expect this to corrupt the image.
 650   (let* ((hash (make-hash-table))
 651          (*errors* nil)
 652          (threads (list (sb-thread:make-thread
 653                          (lambda ()
 654                            (catch 'done
 655                              (handler-bind ((serious-condition 'oops))
 656                                (loop
 657                                  ;;(princ "1") (force-output)
 658                                  (setf (gethash (random 100) hash) 'h)))))
 659                          :name "writer")
 660                         (sb-thread:make-thread
 661                          (lambda ()
 662                            (catch 'done
 663                              (handler-bind ((serious-condition 'oops))
 664                                (loop
 665                                  ;;(princ "2") (force-output)
 666                                  (remhash (random 100) hash)))))
 667                          :name "reader")
 668                         (sb-thread:make-thread
 669                          (lambda ()
 670                            (catch 'done
 671                              (handler-bind ((serious-condition 'oops))
 672                                (loop
 673                                  (sleep (random 1.0))
 674                                  (sb-ext:gc :full t)))))
 675                          :name "collector"))))
 676     (unwind-protect
 677          (sleep 10)
 678       (mapc #'sb-thread:terminate-thread threads))))
 679
 680 (format t "~&unsynchronized hash table test done~%")
 681
 682 (with-test (:name (:synchronized-hash-table))
 683   (let* ((hash (make-hash-table :synchronized t))
 684          (*errors* nil)
 685          (threads (list (sb-thread:make-thread
 686                          (lambda ()
 687                            (catch 'done
 688                              (handler-bind ((serious-condition 'oops))
 689                                (loop
 690                                  ;;(princ "1") (force-output)
 691                                  (setf (gethash (random 100) hash) 'h)))))
 692                          :name "writer")
 693                         (sb-thread:make-thread
 694                          (lambda ()
 695                            (catch 'done
 696                              (handler-bind ((serious-condition 'oops))
 697                                (loop
 698                                  ;;(princ "2") (force-output)
 699                                  (remhash (random 100) hash)))))
 700                          :name "reader")
 701                         (sb-thread:make-thread
 702                          (lambda ()
 703                            (catch 'done
 704                              (handler-bind ((serious-condition 'oops))
 705                                (loop
 706                                  (sleep (random 1.0))
 707                                  (sb-ext:gc :full t)))))
 708                          :name "collector"))))
 709     (unwind-protect
 710          (sleep 10)
 711       (mapc #'sb-thread:terminate-thread threads))
 712     (assert (not *errors*))))
 713
 714 (format t "~&synchronized hash table test done~%")
 715
 716 (with-test (:name (:hash-table-parallel-readers))
 717   (let ((hash (make-hash-table))
 718         (*errors* nil))
 719     (loop repeat 50
 720           do (setf (gethash (random 100) hash) 'xxx))
 721     (let ((threads (list (sb-thread:make-thread
 722                           (lambda ()
 723                             (catch 'done
 724                               (handler-bind ((serious-condition 'oops))
 725                                 (loop
 726                                       until (eq t (gethash (random 100) hash))))))
 727                           :name "reader 1")
 728                          (sb-thread:make-thread
 729                           (lambda ()
 730                             (catch 'done
 731                               (handler-bind ((serious-condition 'oops))
 732                                 (loop
 733                                       until (eq t (gethash (random 100) hash))))))
 734                           :name "reader 2")
 735                          (sb-thread:make-thread
 736                           (lambda ()
 737                             (catch 'done
 738                               (handler-bind ((serious-condition 'oops))
 739                                 (loop
 740                                       until (eq t (gethash (random 100) hash))))))
 741                           :name "reader 3")
 742                          (sb-thread:make-thread
 743                           (lambda ()
 744                             (catch 'done
 745                               (handler-bind ((serious-condition 'oops))
 746                                (loop
 747                                  (sleep (random 1.0))
 748                                  (sb-ext:gc :full t)))))
 749                           :name "collector"))))
 750       (unwind-protect
 751            (sleep 10)
 752         (mapc #'sb-thread:terminate-thread threads))
 753       (assert (not *errors*)))))
 754
 755 (format t "~&multiple reader hash table test done~%")
 756
 757 (with-test (:name (:hash-table-single-accessor-parallel-gc))
 758   (let ((hash (make-hash-table))
 759         (*errors* nil))
 760     (let ((threads (list (sb-thread:make-thread
 761                           (lambda ()
 762                             (handler-bind ((serious-condition 'oops))
 763                               (loop
 764                                 (let ((n (random 100)))
 765                                   (if (gethash n hash)
 766                                       (remhash n hash)
 767                                       (setf (gethash n hash) 'h))))))
 768                           :name "accessor")
 769                          (sb-thread:make-thread
 770                           (lambda ()
 771                             (handler-bind ((serious-condition 'oops))
 772                               (loop
 773                                 (sleep (random 1.0))
 774                                 (sb-ext:gc :full t))))
 775                           :name "collector"))))
 776       (unwind-protect
 777            (sleep 10)
 778         (mapc #'sb-thread:terminate-thread threads))
 779       (assert (not *errors*)))))
 780
 781 (format t "~&single accessor hash table test~%")
 782
 783 #|  ;; a cll post from eric marsden
 784 | (defun crash ()
 785 |   (setq *debugger-hook*
 786 |         (lambda (condition old-debugger-hook)
 787 |           (debug:backtrace 10)
 788 |           (unix:unix-exit 2)))
 789 |   #+live-dangerously
 790 |   (mp::start-sigalrm-yield)
 791 |   (flet ((roomy () (loop (with-output-to-string (*standard-output*) (room)))))
 792 |     (mp:make-process #'roomy)
 793 |     (mp:make-process #'roomy)))
 794 |#
 795
 796 (with-test (:name (:condition-variable :notify-multiple))
 797   (flet ((tester (notify-fun)
 798            (let ((queue (make-waitqueue :name "queue"))
 799                  (lock (make-mutex :name "lock"))
 800                  (data nil))
 801              (labels ((test (x)
 802                         (loop
 803                            (with-mutex (lock)
 804                              (format t "condition-wait ~a~%" x)
 805                              (force-output)
 806                              (condition-wait queue lock)
 807                              (format t "woke up ~a~%" x)
 808                              (force-output)
 809                              (push x data)))))
 810                (let ((threads (loop for x from 1 to 10
 811                                     collect
 812                                     (let ((x x))
 813                                       (sb-thread:make-thread (lambda ()
 814                                                                (test x)))))))
 815                  (sleep 5)
 816                  (with-mutex (lock)
 817                    (funcall notify-fun queue))
 818                  (sleep 5)
 819                  (mapcar #'terminate-thread threads)
 820                  ;; Check that all threads woke up at least once
 821                  (assert (= (length (remove-duplicates data)) 10)))))))
 822     (tester (lambda (queue)
 823               (format t "~&(condition-notify queue 10)~%")
 824               (force-output)
 825               (condition-notify queue 10)))
 826     (tester (lambda (queue)
 827               (format t "~&(condition-broadcast queue)~%")
 828               (force-output)
 829               (condition-broadcast queue)))))
 830
 831 (format t "waitqueue wakeup tests done~%")
 832
 833 (with-test (:name (:mutex :finalization))
 834   (let ((a nil))
 835     (dotimes (i 500000)
 836       (setf a (make-mutex)))))
 837
 838 (format t "mutex finalization test done~%")
 839
 840 ;;; Check that INFO is thread-safe, at least when we're just doing reads.
 841
 842 (let* ((symbols (loop repeat 10000 collect (gensym)))
 843        (functions (loop for (symbol . rest) on symbols
 844                         for next = (car rest)
 845                         for fun = (let ((next next))
 846                                     (lambda (n)
 847                                       (if next
 848                                           (funcall next (1- n))
 849                                           n)))
 850                         do (setf (symbol-function symbol) fun)
 851                         collect fun)))
 852   (defun infodb-test ()
 853     (funcall (car functions) 9999)))
 854
 855 (with-test (:name (:infodb :read))
 856   (let* ((ok t)
 857          (threads (loop for i from 0 to 10
 858                         collect (sb-thread:make-thread
 859                                  (lambda ()
 860                                    (dotimes (j 100)
 861                                      (write-char #\-)
 862                                      (finish-output)
 863                                      (let ((n (infodb-test)))
 864                                        (unless (zerop n)
 865                                          (setf ok nil)
 866                                          (format t "N != 0 (~A)~%" n)
 867                                          (sb-ext:quit)))))))))
 868     (wait-for-threads threads)
 869     (assert ok)))
 870
 871 (format t "infodb test done~%")
 872
 873 (with-test (:name (:backtrace))
 874   ;; Printing backtraces from several threads at once used to hang the
 875   ;; whole SBCL process (discovered by accident due to a timer.impure
 876   ;; test misbehaving). The cause was that packages weren't even
 877   ;; thread-safe for only doing FIND-SYMBOL, and while printing
 878   ;; backtraces a loot of symbol lookups need to be done due to
 879   ;; *PRINT-ESCAPE*.
 880   (let* ((threads (loop repeat 10
 881                         collect (sb-thread:make-thread
 882                                  (lambda ()
 883                                    (dotimes (i 1000)
 884                                      (with-output-to-string (*debug-io*)
 885                                        (sb-debug::backtrace 10))))))))
 886     (wait-for-threads threads)))
 887
 888 (format t "backtrace test done~%")
 889
 890 (format t "~&starting gc deadlock test: WARNING: THIS TEST WILL HANG ON FAILURE!~%")
 891
 892 (with-test (:name (:gc-deadlock))
 893   ;; Prior to 0.9.16.46 thread exit potentially deadlocked the
 894   ;; GC due to *all-threads-lock* and session lock. On earlier
 895   ;; versions and at least on one specific box this test is good enough
 896   ;; to catch that typically well before the 1500th iteration.
 897   (loop
 898      with i = 0
 899      with n = 3000
 900      while (< i n)
 901      do
 902        (incf i)
 903        (when (zerop (mod i 100))
 904          (write-char #\.)
 905          (force-output))
 906        (handler-case
 907            (if (oddp i)
 908                (sb-thread:make-thread
 909                 (lambda ()
 910                   (sleep (random 0.001)))
 911                 :name (list :sleep i))
 912                (sb-thread:make-thread
 913                 (lambda ()
 914                   ;; KLUDGE: what we are doing here is explicit,
 915                   ;; but the same can happen because of a regular
 916                   ;; MAKE-THREAD or LIST-ALL-THREADS, and various
 917                   ;; session functions.
 918                   (sb-thread::with-all-threads-lock
 919                     (sb-thread::with-session-lock (sb-thread::*session*)
 920                       (sb-ext:gc))))
 921                 :name (list :gc i)))
 922          (error (e)
 923            (format t "~%error creating thread ~D: ~A -- backing off for retry~%" i e)
 924            (sleep 0.1)
 925            (incf i)))))
 926
 927 (format t "~&gc deadlock test done~%")
 928 \f
 929 (let ((count (make-array 8 :initial-element 0)))
 930   (defun closure-one ()
 931     (declare (optimize safety))
 932     (values (incf (aref count 0)) (incf (aref count 1))
 933             (incf (aref count 2)) (incf (aref count 3))
 934             (incf (aref count 4)) (incf (aref count 5))
 935             (incf (aref count 6)) (incf (aref count 7))))
 936   (defun no-optimizing-away-closure-one ()
 937     (setf count (make-array 8 :initial-element 0))))
 938
 939 (defstruct box
 940   (count 0))
 941
 942 (let ((one (make-box))
 943       (two (make-box))
 944       (three (make-box)))
 945   (defun closure-two ()
 946     (declare (optimize safety))
 947     (values (incf (box-count one)) (incf (box-count two)) (incf (box-count three))))
 948   (defun no-optimizing-away-closure-two ()
 949     (setf one (make-box)
 950           two (make-box)
 951           three (make-box))))
 952
 953 (with-test (:name (:funcallable-instances))
 954   ;; the funcallable-instance implementation used not to be threadsafe
 955   ;; against setting the funcallable-instance function to a closure
 956   ;; (because the code and lexenv were set separately).
 957   (let ((fun (sb-kernel:%make-funcallable-instance 0))
 958         (condition nil))
 959     (setf (sb-kernel:funcallable-instance-fun fun) #'closure-one)
 960     (flet ((changer ()
 961              (loop (setf (sb-kernel:funcallable-instance-fun fun) #'closure-one)
 962                    (setf (sb-kernel:funcallable-instance-fun fun) #'closure-two)))
 963            (test ()
 964              (handler-case (loop (funcall fun))
 965                (serious-condition (c) (setf condition c)))))
 966       (let ((changer (make-thread #'changer))
 967             (test (make-thread #'test)))
 968         (handler-case
 969             (progn
 970               ;; The two closures above are fairly carefully crafted
 971               ;; so that if given the wrong lexenv they will tend to
 972               ;; do some serious damage, but it is of course difficult
 973               ;; to predict where the various bits and pieces will be
 974               ;; allocated.  Five seconds failed fairly reliably on
 975               ;; both my x86 and x86-64 systems.  -- CSR, 2006-09-27.
 976               (sb-ext:with-timeout 5
 977                 (wait-for-threads (list test)))
 978               (error "~@<test thread got condition:~2I~_~A~@:>" condition))
 979           (sb-ext:timeout ()
 980             (terminate-thread changer)
 981             (terminate-thread test)
 982             (wait-for-threads (list changer test))))))))
 983
 984 (format t "~&funcallable-instance test done~%")
 985
 986 (defun random-type (n)
 987   `(integer ,(random n) ,(+ n (random n))))
 988
 989 (defun subtypep-hash-cache-test ()
 990   (dotimes (i 10000)
 991     (let ((type1 (random-type 500))
 992           (type2 (random-type 500)))
 993       (let ((a (subtypep type1 type2)))
 994         (dotimes (i 100)
 995           (assert (eq (subtypep type1 type2) a))))))
 996   (format t "ok~%")
 997   (force-output))
 998
 999 (with-test (:name '(:hash-cache :subtypep))
1000   (dotimes (i 10)
1001     (sb-thread:make-thread #'subtypep-hash-cache-test)))
1002 (format t "hash-cache tests done~%")
1003
1004 ;;;; BLACK BOX TESTS
1005
1006 (in-package :cl-user)
1007 (use-package :test-util)
1008 (use-package "ASSERTOID")
1009
1010 (format t "parallel defclass test -- WARNING, WILL HANG ON FAILURE!~%")
1011 (with-test (:name :parallel-defclass)
1012   (defclass test-1 () ((a :initform :orig-a)))
1013   (defclass test-2 () ((b :initform :orig-b)))
1014   (defclass test-3 (test-1 test-2) ((c :initform :orig-c)))
1015   (let* ((run t)
1016          (d1 (sb-thread:make-thread (lambda ()
1017                                       (loop while run
1018                                             do (defclass test-1 () ((a :initform :new-a)))
1019                                             (write-char #\1)
1020                                             (force-output)))
1021                                     :name "d1"))
1022          (d2 (sb-thread:make-thread (lambda ()
1023                                       (loop while run
1024                                             do (defclass test-2 () ((b :initform :new-b)))
1025                                                (write-char #\2)
1026                                                (force-output)))
1027                                     :name "d2"))
1028          (d3 (sb-thread:make-thread (lambda ()
1029                                       (loop while run
1030                                             do (defclass test-3 (test-1 test-2) ((c :initform :new-c)))
1031                                                (write-char #\3)
1032                                                (force-output)))
1033                                     :name "d3"))
1034          (i (sb-thread:make-thread (lambda ()
1035                                      (loop while run
1036                                            do (let ((i (make-instance 'test-3)))
1037                                                 (assert (member (slot-value i 'a) '(:orig-a :new-a)))
1038                                                 (assert (member (slot-value i 'b) '(:orig-b :new-b)))
1039                                                 (assert (member (slot-value i 'c) '(:orig-c :new-c))))
1040                                               (write-char #\i)
1041                                               (force-output)))
1042                                    :name "i")))
1043     (format t "~%sleeping!~%")
1044     (sleep 2.0)
1045     (format t "~%stopping!~%")
1046     (setf run nil)
1047     (mapc (lambda (th)
1048             (sb-thread:join-thread th)
1049             (format t "~%joined ~S~%" (sb-thread:thread-name th)))
1050           (list d1 d2 d3 i))))
1051 (format t "parallel defclass test done~%")