tests/threads.impure.lisp

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