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
  18 (defun wait-for-threads (threads)
  19   (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
  20
  21 (assert (eql 1 (length (list-all-threads))))
  22
  23 (assert (eq *current-thread*
  24             (find (thread-name *current-thread*) (list-all-threads)
  25                   :key #'thread-name :test #'equal)))
  26
  27 (assert (thread-alive-p *current-thread*))
  28
  29 (let ((a 0))
  30   (interrupt-thread *current-thread* (lambda () (setq a 1)))
  31   (assert (eql a 1)))
  32
  33 (let ((spinlock (make-spinlock)))
  34   (with-spinlock (spinlock)))
  35
  36 (let ((mutex (make-mutex)))
  37   (with-mutex (mutex)
  38     mutex))
  39
  40 #-sb-thread (sb-ext:quit :unix-status 104)
  41
  42 (let ((old-threads (list-all-threads))
  43       (thread (make-thread (lambda ()
  44                              (assert (find *current-thread* *all-threads*))
  45                              (sleep 2))))
  46       (new-threads (list-all-threads)))
  47   (assert (thread-alive-p thread))
  48   (assert (eq thread (first new-threads)))
  49   (assert (= (1+ (length old-threads)) (length new-threads)))
  50   (sleep 3)
  51   (assert (not (thread-alive-p thread))))
  52
  53 ;;; We had appalling scaling properties for a while.  Make sure they
  54 ;;; don't reappear.
  55 (defun scaling-test (function &optional (nthreads 5))
  56   "Execute FUNCTION with NTHREADS lurking to slow it down."
  57   (let ((queue (sb-thread:make-waitqueue))
  58         (mutex (sb-thread:make-mutex)))
  59     ;; Start NTHREADS idle threads.
  60     (dotimes (i nthreads)
  61       (sb-thread:make-thread (lambda ()
  62                                (with-mutex (mutex)
  63                                  (sb-thread:condition-wait queue mutex))
  64                                (sb-ext:quit))))
  65     (let ((start-time (get-internal-run-time)))
  66       (funcall function)
  67       (prog1 (- (get-internal-run-time) start-time)
  68         (sb-thread:condition-broadcast queue)))))
  69 (defun fact (n)
  70   "A function that does work with the CPU."
  71   (if (zerop n) 1 (* n (fact (1- n)))))
  72 (let ((work (lambda () (fact 15000))))
  73   (let ((zero (scaling-test work 0))
  74         (four (scaling-test work 4)))
  75     ;; a slightly weak assertion, but good enough for starters.
  76     (assert (< four (* 1.5 zero)))))
  77
  78 ;;; For one of the interupt-thread tests, we want a foreign function
  79 ;;; that does not make syscalls
  80
  81 (with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede)
  82   (format o "void loop_forever() { while(1) ; }~%"))
  83 (sb-ext:run-program
  84  "cc"
  85  (or #+linux '("-shared" "-o" "threads-foreign.so" "threads-foreign.c")
  86      (error "Missing shared library compilation options for this platform"))
  87  :search t)
  88 (sb-alien:load-shared-object "threads-foreign.so")
  89 (sb-alien:define-alien-routine loop-forever sb-alien:void)
  90
  91
  92 ;;; elementary "can we get a lock and release it again"
  93 (let ((l (make-mutex :name "foo"))
  94       (p *current-thread*))
  95   (assert (eql (mutex-value l) nil) nil "1")
  96   (sb-thread:get-mutex l)
  97   (assert (eql (mutex-value l) p) nil "3")
  98   (sb-thread:release-mutex l)
  99   (assert (eql (mutex-value l) nil) nil "5"))
 100
 101 (labels ((ours-p (value)
 102            (eq *current-thread* value)))
 103   (let ((l (make-mutex :name "rec")))
 104     (assert (eql (mutex-value l) nil) nil "1")
 105     (sb-thread:with-recursive-lock (l)
 106       (assert (ours-p (mutex-value l)) nil "3")
 107       (sb-thread:with-recursive-lock (l)
 108         (assert (ours-p (mutex-value l)) nil "4"))
 109       (assert (ours-p (mutex-value l)) nil "5"))
 110     (assert (eql (mutex-value l) nil) nil "6")))
 111
 112 (with-test (:name (:mutex :nesting-mutex-and-recursive-lock))
 113   (let ((l (make-mutex :name "a mutex")))
 114     (with-mutex (l)
 115       (with-recursive-lock (l)))))
 116
 117 (let ((l (make-spinlock :name "spinlock")))
 118   (assert (eql (spinlock-value l) 0) nil "1")
 119   (with-spinlock (l)
 120     (assert (eql (spinlock-value l) 1) nil "2"))
 121   (assert (eql (spinlock-value l) 0) nil "3"))
 122
 123 ;; test that SLEEP actually sleeps for at least the given time, even
 124 ;; if interrupted by another thread exiting/a gc/anything
 125 (let ((start-time (get-universal-time)))
 126   (make-thread (lambda () (sleep 1) (sb-ext:gc :full t)))
 127   (sleep 5)
 128   (assert (>= (get-universal-time) (+ 5 start-time))))
 129
 130
 131 (let ((queue (make-waitqueue :name "queue"))
 132       (lock (make-mutex :name "lock"))
 133       (n 0))
 134   (labels ((in-new-thread ()
 135              (with-mutex (lock)
 136                (assert (eql (mutex-value lock) *current-thread*))
 137                (format t "~A got mutex~%" *current-thread*)
 138                ;; now drop it and sleep
 139                (condition-wait queue lock)
 140                ;; after waking we should have the lock again
 141                (assert (eql (mutex-value lock) *current-thread*))
 142                (assert (eql n 1))
 143                (decf n))))
 144     (make-thread #'in-new-thread)
 145     (sleep 2)                           ; give it  a chance to start
 146     ;; check the lock is free while it's asleep
 147     (format t "parent thread ~A~%" *current-thread*)
 148     (assert (eql (mutex-value lock) nil))
 149     (with-mutex (lock)
 150       (incf n)
 151       (condition-notify queue))
 152     (sleep 1)))
 153
 154 (let ((queue (make-waitqueue :name "queue"))
 155       (lock (make-mutex :name "lock")))
 156   (labels ((ours-p (value)
 157              (eq *current-thread* value))
 158            (in-new-thread ()
 159              (with-recursive-lock (lock)
 160                (assert (ours-p (mutex-value lock)))
 161                (format t "~A got mutex~%" (mutex-value lock))
 162                ;; now drop it and sleep
 163                (condition-wait queue lock)
 164                ;; after waking we should have the lock again
 165                (format t "woken, ~A got mutex~%" (mutex-value lock))
 166                (assert (ours-p (mutex-value lock))))))
 167     (make-thread #'in-new-thread)
 168     (sleep 2)                           ; give it  a chance to start
 169     ;; check the lock is free while it's asleep
 170     (format t "parent thread ~A~%" *current-thread*)
 171     (assert (eql (mutex-value lock) nil))
 172     (with-recursive-lock (lock)
 173       (condition-notify queue))
 174     (sleep 1)))
 175
 176 (let ((mutex (make-mutex :name "contended")))
 177   (labels ((run ()
 178              (let ((me *current-thread*))
 179                (dotimes (i 100)
 180                  (with-mutex (mutex)
 181                    (sleep .03)
 182                    (assert (eql (mutex-value mutex) me)))
 183                  (assert (not (eql (mutex-value mutex) me))))
 184                (format t "done ~A~%" *current-thread*))))
 185     (let ((kid1 (make-thread #'run))
 186           (kid2 (make-thread #'run)))
 187       (format t "contention ~A ~A~%" kid1 kid2)
 188       (wait-for-threads (list kid1 kid2)))))
 189
 190 ;;; semaphores
 191
 192 (defmacro raises-timeout-p (&body body)
 193   `(handler-case (progn (progn ,@body) nil)
 194     (sb-ext:timeout () t)))
 195
 196 (with-test (:name (:semaphore :wait-forever))
 197   (let ((sem (make-semaphore :count 0)))
 198     (assert (raises-timeout-p
 199               (sb-ext:with-timeout 0.1
 200                 (wait-on-semaphore sem))))))
 201
 202 (with-test (:name (:semaphore :initial-count))
 203   (let ((sem (make-semaphore :count 1)))
 204     (sb-ext:with-timeout 0.1
 205       (wait-on-semaphore sem))))
 206
 207 (with-test (:name (:semaphore :wait-then-signal))
 208   (let ((sem (make-semaphore))
 209         (signalled-p nil))
 210     (make-thread (lambda ()
 211                    (sleep 0.1)
 212                    (setq signalled-p t)
 213                    (signal-semaphore sem)))
 214     (wait-on-semaphore sem)
 215     (assert signalled-p)))
 216
 217 (with-test (:name (:semaphore :signal-then-wait))
 218   (let ((sem (make-semaphore))
 219         (signalled-p nil))
 220     (make-thread (lambda ()
 221                    (signal-semaphore sem)
 222                    (setq signalled-p t)))
 223     (loop until signalled-p)
 224     (wait-on-semaphore sem)
 225     (assert signalled-p)))
 226
 227 (with-test (:name (:semaphore :multiple-signals))
 228   (let* ((sem (make-semaphore :count 5))
 229          (threads (loop repeat 20
 230                         collect (make-thread (lambda ()
 231                                                (wait-on-semaphore sem))))))
 232     (flet ((count-live-threads ()
 233              (count-if #'thread-alive-p threads)))
 234       (sleep 0.5)
 235       (assert (= 15 (count-live-threads)))
 236       (signal-semaphore sem 10)
 237       (sleep 0.5)
 238       (assert (= 5 (count-live-threads)))
 239       (signal-semaphore sem 3)
 240       (sleep 0.5)
 241       (assert (= 2 (count-live-threads)))
 242       (signal-semaphore sem 4)
 243       (sleep 0.5)
 244       (assert (= 0 (count-live-threads))))))
 245
 246 (format t "~&semaphore tests done~%")
 247
 248 (defun test-interrupt (function-to-interrupt &optional quit-p)
 249   (let ((child  (make-thread function-to-interrupt)))
 250     ;;(format t "gdb ./src/runtime/sbcl ~A~%attach ~A~%" child child)
 251     (sleep 2)
 252     (format t "interrupting child ~A~%" child)
 253     (interrupt-thread child
 254                       (lambda ()
 255                         (format t "child pid ~A~%" *current-thread*)
 256                         (when quit-p (sb-ext:quit))))
 257     (sleep 1)
 258     child))
 259
 260 ;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
 261 ;; (d) waiting on a lock, (e) some code which we hope is likely to be
 262 ;; in pseudo-atomic
 263
 264 (let ((child (test-interrupt (lambda () (loop)))))  (terminate-thread child))
 265
 266 (test-interrupt #'loop-forever :quit)
 267
 268 (let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
 269   (terminate-thread child)
 270   (wait-for-threads (list child)))
 271
 272 (let ((lock (make-mutex :name "loctite"))
 273       child)
 274   (with-mutex (lock)
 275     (setf child (test-interrupt
 276                  (lambda ()
 277                    (with-mutex (lock)
 278                      (assert (eql (mutex-value lock) *current-thread*)))
 279                    (assert (not (eql (mutex-value lock) *current-thread*)))
 280                    (sleep 10))))
 281     ;;hold onto lock for long enough that child can't get it immediately
 282     (sleep 5)
 283     (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock))))
 284     (format t "parent releasing lock~%"))
 285   (terminate-thread child)
 286   (wait-for-threads (list child)))
 287
 288 (format t "~&locking test done~%")
 289
 290 (defun alloc-stuff () (copy-list '(1 2 3 4 5)))
 291
 292 (progn
 293   (let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff))))))
 294     (let ((killers
 295            (loop repeat 4 collect
 296                  (sb-thread:make-thread
 297                   (lambda ()
 298                     (loop repeat 25 do
 299                           (sleep (random 0.1d0))
 300                           (princ ".")
 301                           (force-output)
 302                           (sb-thread:interrupt-thread thread (lambda ()))))))))
 303       (wait-for-threads killers)
 304       (sb-thread:terminate-thread thread)
 305       (wait-for-threads (list thread))))
 306   (sb-ext:gc :full t))
 307
 308 (format t "~&multi interrupt test done~%")
 309
 310 (let ((c (make-thread (lambda () (loop (alloc-stuff))))))
 311   ;; NB this only works on x86: other ports don't have a symbol for
 312   ;; pseudo-atomic atomicity
 313   (dotimes (i 100)
 314     (sleep (random 0.1d0))
 315     (interrupt-thread c
 316                       (lambda ()
 317                         (princ ".") (force-output)
 318                         (assert (thread-alive-p *current-thread*))
 319                         (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
 320   (terminate-thread c)
 321   (wait-for-threads (list c)))
 322
 323 (format t "~&interrupt test done~%")
 324
 325 (defparameter *interrupt-count* 0)
 326
 327 (declaim (notinline check-interrupt-count))
 328 (defun check-interrupt-count (i)
 329   (declare (optimize (debug 1) (speed 1)))
 330   ;; This used to lose if eflags were not restored after an interrupt.
 331   (unless (typep i 'fixnum)
 332     (error "!!!!!!!!!!!")))
 333
 334 (let ((c (make-thread
 335           (lambda ()
 336             (handler-bind ((error #'(lambda (cond)
 337                                       (princ cond)
 338                                       (sb-debug:backtrace
 339                                        most-positive-fixnum))))
 340               (loop (check-interrupt-count *interrupt-count*)))))))
 341   (let ((func (lambda ()
 342                 (princ ".")
 343                 (force-output)
 344                 (sb-impl::atomic-incf/symbol *interrupt-count*))))
 345     (setq *interrupt-count* 0)
 346     (dotimes (i 100)
 347       (sleep (random 0.1d0))
 348       (interrupt-thread c func))
 349     (loop until (= *interrupt-count* 100) do (sleep 0.1))
 350     (terminate-thread c)
 351     (wait-for-threads (list c))))
 352
 353 (format t "~&interrupt count test done~%")
 354
 355 (let (a-done b-done)
 356   (make-thread (lambda ()
 357                  (dotimes (i 100)
 358                    (sb-ext:gc) (princ "\\") (force-output))
 359                  (setf a-done t)))
 360   (make-thread (lambda ()
 361                  (dotimes (i 25)
 362                    (sb-ext:gc :full t)
 363                    (princ "/") (force-output))
 364                  (setf b-done t)))
 365   (loop
 366    (when (and a-done b-done) (return))
 367    (sleep 1)))
 368
 369 (terpri)
 370
 371 (defun waste (&optional (n 100000))
 372   (loop repeat n do (make-string 16384)))
 373
 374 (loop for i below 100 do
 375       (princ "!")
 376       (force-output)
 377       (sb-thread:make-thread
 378        #'(lambda ()
 379            (waste)))
 380       (waste)
 381       (sb-ext:gc))
 382
 383 (terpri)
 384
 385 (defparameter *aaa* nil)
 386 (loop for i below 100 do
 387       (princ "!")
 388       (force-output)
 389       (sb-thread:make-thread
 390        #'(lambda ()
 391            (let ((*aaa* (waste)))
 392              (waste))))
 393       (let ((*aaa* (waste)))
 394         (waste))
 395       (sb-ext:gc))
 396
 397 (format t "~&gc test done~%")
 398
 399 ;; this used to deadlock on session-lock
 400 (sb-thread:make-thread (lambda () (sb-ext:gc)))
 401 ;; expose thread creation races by exiting quickly
 402 (sb-thread:make-thread (lambda ()))
 403
 404 (defun exercise-syscall (fn reference-errno)
 405   (sb-thread:make-thread
 406    (lambda ()
 407      (loop do
 408           (funcall fn)
 409           (let ((errno (sb-unix::get-errno)))
 410             (sleep (random 0.1d0))
 411             (unless (eql errno reference-errno)
 412               (format t "Got errno: ~A (~A) instead of ~A~%"
 413                       errno
 414                       (sb-unix::strerror)
 415                       reference-errno)
 416               (force-output)
 417               (sb-ext:quit :unix-status 1)))))))
 418
 419 (let* ((nanosleep-errno (progn
 420                           (sb-unix:nanosleep -1 0)
 421                           (sb-unix::get-errno)))
 422        (open-errno (progn
 423                      (open "no-such-file"
 424                            :if-does-not-exist nil)
 425                      (sb-unix::get-errno)))
 426        (threads
 427         (list
 428          (exercise-syscall (lambda () (sb-unix:nanosleep -1 0)) nanosleep-errno)
 429          (exercise-syscall (lambda () (open "no-such-file"
 430                                             :if-does-not-exist nil))
 431                            open-errno)
 432          (sb-thread:make-thread (lambda () (loop (sb-ext:gc) (sleep 1)))))))
 433   (sleep 10)
 434   (princ "terminating threads")
 435   (dolist (thread threads)
 436     (sb-thread:terminate-thread thread)))
 437
 438 (format t "~&errno test done~%")
 439
 440 (loop repeat 100 do
 441       (let ((thread (sb-thread:make-thread (lambda () (sleep 0.1)))))
 442         (sb-thread:interrupt-thread
 443          thread
 444          (lambda ()
 445            (assert (find-restart 'sb-thread:terminate-thread))))))
 446
 447 (sb-ext:gc :full t)
 448
 449 (format t "~&thread startup sigmask test done~%")
 450
 451 (sb-debug::enable-debugger)
 452 (let* ((main-thread *current-thread*)
 453        (interruptor-thread
 454         (make-thread (lambda ()
 455                        (sleep 2)
 456                        (interrupt-thread main-thread #'break)
 457                        (sleep 2)
 458                        (interrupt-thread main-thread #'continue)))))
 459   (with-session-lock (*session*)
 460     (sleep 3))
 461   (loop while (thread-alive-p interruptor-thread)))
 462
 463 (format t "~&session lock test done~%")
 464
 465 (loop repeat 20 do
 466       (wait-for-threads
 467        (loop for i below 100 collect
 468              (sb-thread:make-thread (lambda ())))))
 469
 470 (format t "~&creation test done~%")
 471
 472 ;; interrupt handlers are per-thread with pthreads, make sure the
 473 ;; handler installed in one thread is global
 474 (sb-thread:make-thread
 475  (lambda ()
 476    (sb-ext:run-program "sleep" '("1") :search t :wait nil)))
 477
 478 ;;;; Binding stack safety
 479
 480 (defparameter *x* nil)
 481 (defparameter *n-gcs-requested* 0)
 482 (defparameter *n-gcs-done* 0)
 483
 484 (let ((counter 0))
 485   (defun make-something-big ()
 486     (let ((x (make-string 32000)))
 487       (incf counter)
 488       (let ((counter counter))
 489         (sb-ext:finalize x (lambda () (format t " ~S" counter)
 490                                    (force-output)))))))
 491
 492 (defmacro wait-for-gc ()
 493   `(progn
 494      (incf *n-gcs-requested*)
 495      (loop while (< *n-gcs-done* *n-gcs-requested*))))
 496
 497 (defun send-gc ()
 498   (loop until (< *n-gcs-done* *n-gcs-requested*))
 499   (format t "G" *n-gcs-requested* *n-gcs-done*)
 500   (force-output)
 501   (sb-ext:gc)
 502   (incf *n-gcs-done*))
 503
 504 (defun exercise-binding ()
 505   (loop
 506    (let ((*x* (make-something-big)))
 507      (let ((*x* 42))
 508        ;; at this point the binding stack looks like this:
 509        ;; NO-TLS-VALUE-MARKER, *x*, SOMETHING, *x*
 510        t))
 511    (wait-for-gc)
 512    ;; sig_stop_for_gc_handler binds FREE_INTERRUPT_CONTEXT_INDEX. By
 513    ;; now SOMETHING is gc'ed and the binding stack looks like this: 0,
 514    ;; 0, SOMETHING, 0 (because the symbol slots are zeroed on
 515    ;; unbinding but values are not).
 516    (let ((*x* nil))
 517      ;; bump bsp as if a BIND had just started
 518      (incf sb-vm::*binding-stack-pointer* 2)
 519      (wait-for-gc)
 520      (decf sb-vm::*binding-stack-pointer* 2))))
 521
 522 (with-test (:name (:binding-stack-gc-safety))
 523   (let (threads)
 524     (unwind-protect
 525          (progn
 526            (push (sb-thread:make-thread #'exercise-binding) threads)
 527            (push (sb-thread:make-thread (lambda ()
 528                                           (loop
 529                                            (send-gc))))
 530                  threads)
 531            (sleep 4))
 532       (mapc #'sb-thread:terminate-thread threads))))
 533
 534 (format t "~&binding test done~%")
 535
 536 ;; Try to corrupt the NEXT-VECTOR. Operations on a hash table with a
 537 ;; cyclic NEXT-VECTOR can loop endlessly in a WITHOUT-GCING form
 538 ;; causing the next gc hang SBCL.
 539 (with-test (:name (:hash-table-thread-safety))
 540   (let* ((hash (make-hash-table))
 541          (threads (list (sb-thread:make-thread
 542                          (lambda ()
 543                            (loop
 544                             ;;(princ "1") (force-output)
 545                             (setf (gethash (random 100) hash) 'h))))
 546                         (sb-thread:make-thread
 547                          (lambda ()
 548                            (loop
 549                             ;;(princ "2") (force-output)
 550                             (remhash (random 100) hash))))
 551                         (sb-thread:make-thread
 552                          (lambda ()
 553                            (loop
 554                             (sleep (random 1.0))
 555                             (sb-ext:gc :full t)))))))
 556     (unwind-protect
 557          (sleep 5)
 558       (mapc #'sb-thread:terminate-thread threads))))
 559
 560 (format t "~&hash table test done~%")
 561 #|  ;; a cll post from eric marsden
 562 | (defun crash ()
 563 |   (setq *debugger-hook*
 564 |         (lambda (condition old-debugger-hook)
 565 |           (debug:backtrace 10)
 566 |           (unix:unix-exit 2)))
 567 |   #+live-dangerously
 568 |   (mp::start-sigalrm-yield)
 569 |   (flet ((roomy () (loop (with-output-to-string (*standard-output*) (room)))))
 570 |     (mp:make-process #'roomy)
 571 |     (mp:make-process #'roomy)))
 572 |#