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