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