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 (defun wait-for-threads (threads)
  17   (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
  18
  19 (assert (eql 1 (length (list-all-threads))))
  20
  21 (assert (eq *current-thread*
  22             (find (thread-name *current-thread*) (list-all-threads)
  23                   :key #'thread-name :test #'equal)))
  24
  25 (assert (thread-alive-p *current-thread*))
  26
  27 (let ((a 0))
  28   (interrupt-thread *current-thread* (lambda () (setq a 1)))
  29   (assert (eql a 1)))
  30
  31 (let ((spinlock (make-spinlock)))
  32   (with-spinlock (spinlock)))
  33
  34 (let ((mutex (make-mutex)))
  35   (with-mutex (mutex)
  36     mutex))
  37
  38 #-sb-thread (sb-ext:quit :unix-status 104)
  39
  40 (let ((old-threads (list-all-threads))
  41       (thread (make-thread (lambda ()
  42                              (assert (find *current-thread* *all-threads*))
  43                              (sleep 2))))
  44       (new-threads (list-all-threads)))
  45   (assert (thread-alive-p thread))
  46   (assert (eq thread (first new-threads)))
  47   (assert (= (1+ (length old-threads)) (length new-threads)))
  48   (sleep 3)
  49   (assert (not (thread-alive-p thread))))
  50
  51 ;;; We had appalling scaling properties for a while.  Make sure they
  52 ;;; don't reappear.
  53 (defun scaling-test (function &optional (nthreads 5))
  54   "Execute FUNCTION with NTHREADS lurking to slow it down."
  55   (let ((queue (sb-thread:make-waitqueue))
  56         (mutex (sb-thread:make-mutex)))
  57     ;; Start NTHREADS idle threads.
  58     (dotimes (i nthreads)
  59       (sb-thread:make-thread (lambda ()
  60                                (with-mutex (mutex)
  61                                  (sb-thread:condition-wait queue mutex))
  62                                (sb-ext:quit))))
  63     (let ((start-time (get-internal-run-time)))
  64       (funcall function)
  65       (prog1 (- (get-internal-run-time) start-time)
  66         (sb-thread:condition-broadcast queue)))))
  67 (defun fact (n)
  68   "A function that does work with the CPU."
  69   (if (zerop n) 1 (* n (fact (1- n)))))
  70 (let ((work (lambda () (fact 15000))))
  71   (let ((zero (scaling-test work 0))
  72         (four (scaling-test work 4)))
  73     ;; a slightly weak assertion, but good enough for starters.
  74     (assert (< four (* 1.5 zero)))))
  75
  76 ;;; For one of the interupt-thread tests, we want a foreign function
  77 ;;; that does not make syscalls
  78
  79 (with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede)
  80   (format o "void loop_forever() { while(1) ; }~%"))
  81 (sb-ext:run-program
  82  "cc"
  83  (or #+linux '("-shared" "-o" "threads-foreign.so" "threads-foreign.c")
  84      (error "Missing shared library compilation options for this platform"))
  85  :search t)
  86 (sb-alien:load-shared-object "threads-foreign.so")
  87 (sb-alien:define-alien-routine loop-forever sb-alien:void)
  88
  89
  90 ;;; elementary "can we get a lock and release it again"
  91 (let ((l (make-mutex :name "foo"))
  92       (p *current-thread*))
  93   (assert (eql (mutex-value l) nil) nil "1")
  94   (sb-thread:get-mutex l)
  95   (assert (eql (mutex-value l) p) nil "3")
  96   (sb-thread:release-mutex l)
  97   (assert (eql (mutex-value l) nil) nil "5"))
  98
  99 (labels ((ours-p (value)
 100            (sb-vm:control-stack-pointer-valid-p
 101             (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value)))))
 102   (let ((l (make-mutex :name "rec")))
 103     (assert (eql (mutex-value l) nil) nil "1")
 104     (sb-thread:with-recursive-lock (l)
 105       (assert (ours-p (mutex-value l)) nil "3")
 106       (sb-thread:with-recursive-lock (l)
 107         (assert (ours-p (mutex-value l)) nil "4"))
 108       (assert (ours-p (mutex-value l)) nil "5"))
 109     (assert (eql (mutex-value l) nil) nil "6")))
 110
 111 (let ((l (make-spinlock :name "spinlock"))
 112       (p *current-thread*))
 113   (assert (eql (spinlock-value l) 0) nil "1")
 114   (with-spinlock (l)
 115     (assert (eql (spinlock-value l) p) nil "2"))
 116   (assert (eql (spinlock-value l) 0) nil "3"))
 117
 118 ;; test that SLEEP actually sleeps for at least the given time, even
 119 ;; if interrupted by another thread exiting/a gc/anything
 120 (let ((start-time (get-universal-time)))
 121   (make-thread (lambda () (sleep 1) (sb-ext:gc :full t)))
 122   (sleep 5)
 123   (assert (>= (get-universal-time) (+ 5 start-time))))
 124
 125
 126 (let ((queue (make-waitqueue :name "queue"))
 127       (lock (make-mutex :name "lock"))
 128       (n 0))
 129   (labels ((in-new-thread ()
 130              (with-mutex (lock)
 131                (assert (eql (mutex-value lock) *current-thread*))
 132                (format t "~A got mutex~%" *current-thread*)
 133                ;; now drop it and sleep
 134                (condition-wait queue lock)
 135                ;; after waking we should have the lock again
 136                (assert (eql (mutex-value lock) *current-thread*))
 137                (assert (eql n 1))
 138                (decf n))))
 139     (make-thread #'in-new-thread)
 140     (sleep 2)                           ; give it  a chance to start
 141     ;; check the lock is free while it's asleep
 142     (format t "parent thread ~A~%" *current-thread*)
 143     (assert (eql (mutex-value lock) nil))
 144     (with-mutex (lock)
 145       (incf n)
 146       (condition-notify queue))
 147     (sleep 1)))
 148
 149 (let ((queue (make-waitqueue :name "queue"))
 150       (lock (make-mutex :name "lock")))
 151   (labels ((ours-p (value)
 152              (sb-vm:control-stack-pointer-valid-p
 153               (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value))))
 154            (in-new-thread ()
 155              (with-recursive-lock (lock)
 156                (assert (ours-p (mutex-value lock)))
 157                (format t "~A got mutex~%" (mutex-value lock))
 158                ;; now drop it and sleep
 159                (condition-wait queue lock)
 160                ;; after waking we should have the lock again
 161                (format t "woken, ~A got mutex~%" (mutex-value lock))
 162                (assert (ours-p (mutex-value lock))))))
 163     (make-thread #'in-new-thread)
 164     (sleep 2)                           ; give it  a chance to start
 165     ;; check the lock is free while it's asleep
 166     (format t "parent thread ~A~%" *current-thread*)
 167     (assert (eql (mutex-value lock) nil))
 168     (with-recursive-lock (lock)
 169       (condition-notify queue))
 170     (sleep 1)))
 171
 172 (let ((mutex (make-mutex :name "contended")))
 173   (labels ((run ()
 174              (let ((me *current-thread*))
 175                (dotimes (i 100)
 176                  (with-mutex (mutex)
 177                    (sleep .1)
 178                    (assert (eql (mutex-value mutex) me)))
 179                  (assert (not (eql (mutex-value mutex) me))))
 180                (format t "done ~A~%" *current-thread*))))
 181     (let ((kid1 (make-thread #'run))
 182           (kid2 (make-thread #'run)))
 183       (format t "contention ~A ~A~%" kid1 kid2)
 184       (wait-for-threads (list kid1 kid2)))))
 185
 186 (defun test-interrupt (function-to-interrupt &optional quit-p)
 187   (let ((child  (make-thread function-to-interrupt)))
 188     ;;(format t "gdb ./src/runtime/sbcl ~A~%attach ~A~%" child child)
 189     (sleep 2)
 190     (format t "interrupting child ~A~%" child)
 191     (interrupt-thread child
 192                       (lambda ()
 193                         (format t "child pid ~A~%" *current-thread*)
 194                         (when quit-p (sb-ext:quit))))
 195     (sleep 1)
 196     child))
 197
 198 ;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
 199 ;; (d) waiting on a lock, (e) some code which we hope is likely to be
 200 ;; in pseudo-atomic
 201
 202 (let ((child (test-interrupt (lambda () (loop)))))  (terminate-thread child))
 203
 204 (test-interrupt #'loop-forever :quit)
 205
 206 (let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
 207   (terminate-thread child)
 208   (wait-for-threads (list child)))
 209
 210 (let ((lock (make-mutex :name "loctite"))
 211       child)
 212   (with-mutex (lock)
 213     (setf child (test-interrupt
 214                  (lambda ()
 215                    (with-mutex (lock)
 216                      (assert (eql (mutex-value lock) *current-thread*)))
 217                    (assert (not (eql (mutex-value lock) *current-thread*)))
 218                    (sleep 10))))
 219     ;;hold onto lock for long enough that child can't get it immediately
 220     (sleep 5)
 221     (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock))))
 222     (format t "parent releasing lock~%"))
 223   (terminate-thread child)
 224   (wait-for-threads (list child)))
 225
 226 (format t "~&locking test done~%")
 227
 228 (defun alloc-stuff () (copy-list '(1 2 3 4 5)))
 229
 230 (progn
 231   (let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff))))))
 232     (let ((killers
 233            (loop repeat 4 collect
 234                  (sb-thread:make-thread
 235                   (lambda ()
 236                     (loop repeat 25 do
 237                           (sleep (random 0.1d0))
 238                           (princ ".")
 239                           (force-output)
 240                           (sb-thread:interrupt-thread thread (lambda ()))))))))
 241       (wait-for-threads killers)
 242       (sb-thread:terminate-thread thread)
 243       (wait-for-threads (list thread))))
 244   (sb-ext:gc :full t))
 245
 246 (format t "~&multi interrupt test done~%")
 247
 248 (let ((c (make-thread (lambda () (loop (alloc-stuff))))))
 249   ;; NB this only works on x86: other ports don't have a symbol for
 250   ;; pseudo-atomic atomicity
 251   (dotimes (i 100)
 252     (sleep (random 0.1d0))
 253     (interrupt-thread c
 254                       (lambda ()
 255                         (princ ".") (force-output)
 256                         (assert (eq (thread-state *current-thread*) :running))
 257                         (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
 258   (terminate-thread c)
 259   (wait-for-threads (list c)))
 260
 261 (format t "~&interrupt test done~%")
 262
 263 (defparameter *interrupt-count* 0)
 264
 265 (declaim (notinline check-interrupt-count))
 266 (defun check-interrupt-count (i)
 267   (declare (optimize (debug 1) (speed 1)))
 268   ;; This used to lose if eflags were not restored after an interrupt.
 269   (unless (typep i 'fixnum)
 270     (error "!!!!!!!!!!!")))
 271
 272 (let ((c (make-thread
 273           (lambda ()
 274             (handler-bind ((error #'(lambda (cond)
 275                                       (princ cond)
 276                                       (sb-debug:backtrace
 277                                        most-positive-fixnum))))
 278               (loop (check-interrupt-count *interrupt-count*)))))))
 279   (let ((func (lambda ()
 280                 (princ ".")
 281                 (force-output)
 282                 (sb-impl::atomic-incf/symbol *interrupt-count*))))
 283     (setq *interrupt-count* 0)
 284     (dotimes (i 100)
 285       (sleep (random 0.1d0))
 286       (interrupt-thread c func))
 287     (loop until (= *interrupt-count* 100) do (sleep 0.1))
 288     (terminate-thread c)
 289     (wait-for-threads (list c))))
 290
 291 (format t "~&interrupt count test done~%")
 292
 293 (let (a-done b-done)
 294   (make-thread (lambda ()
 295                  (dotimes (i 100)
 296                    (sb-ext:gc) (princ "\\") (force-output))
 297                  (setf a-done t)))
 298   (make-thread (lambda ()
 299                  (dotimes (i 25)
 300                    (sb-ext:gc :full t)
 301                    (princ "/") (force-output))
 302                  (setf b-done t)))
 303   (loop
 304    (when (and a-done b-done) (return))
 305    (sleep 1)))
 306
 307 (terpri)
 308
 309 (defun waste (&optional (n 100000))
 310   (loop repeat n do (make-string 16384)))
 311
 312 (loop for i below 100 do
 313       (princ "!")
 314       (force-output)
 315       (sb-thread:make-thread
 316        #'(lambda ()
 317            (waste)))
 318       (waste)
 319       (sb-ext:gc))
 320
 321 (terpri)
 322
 323 (defparameter *aaa* nil)
 324 (loop for i below 100 do
 325       (princ "!")
 326       (force-output)
 327       (sb-thread:make-thread
 328        #'(lambda ()
 329            (let ((*aaa* (waste)))
 330              (waste))))
 331       (let ((*aaa* (waste)))
 332         (waste))
 333       (sb-ext:gc))
 334
 335 (format t "~&gc test done~%")
 336
 337 ;; this used to deadlock on session-lock
 338 (sb-thread:make-thread (lambda () (sb-ext:gc)))
 339 ;; expose thread creation races by exiting quickly
 340 (sb-thread:make-thread (lambda ()))
 341
 342 (defun exercise-syscall (fn reference-errno)
 343   (sb-thread:make-thread
 344    (lambda ()
 345      (loop do
 346           (funcall fn)
 347           (let ((errno (sb-unix::get-errno)))
 348             (sleep (random 0.1d0))
 349             (unless (eql errno reference-errno)
 350               (format t "Got errno: ~A (~A) instead of ~A~%"
 351                       errno
 352                       (sb-unix::strerror)
 353                       reference-errno)
 354               (force-output)
 355               (sb-ext:quit :unix-status 1)))))))
 356
 357 (let* ((nanosleep-errno (progn
 358                           (sb-unix:nanosleep -1 0)
 359                           (sb-unix::get-errno)))
 360        (open-errno (progn
 361                      (open "no-such-file"
 362                            :if-does-not-exist nil)
 363                      (sb-unix::get-errno)))
 364        (threads
 365         (list
 366          (exercise-syscall (lambda () (sb-unix:nanosleep -1 0)) nanosleep-errno)
 367          (exercise-syscall (lambda () (open "no-such-file"
 368                                             :if-does-not-exist nil))
 369                            open-errno)
 370          (sb-thread:make-thread (lambda () (loop (sb-ext:gc) (sleep 1)))))))
 371   (sleep 10)
 372   (princ "terminating threads")
 373   (dolist (thread threads)
 374     (sb-thread:terminate-thread thread)))
 375
 376 (format t "~&errno test done~%")
 377
 378 (loop repeat 100 do
 379       (let ((thread (sb-thread:make-thread (lambda () (sleep 0.1)))))
 380         (sb-thread:interrupt-thread
 381          thread
 382          (lambda ()
 383            (assert (find-restart 'sb-thread:terminate-thread))))))
 384
 385 (sb-ext:gc :full t)
 386
 387 (format t "~&thread startup sigmask test done~%")
 388
 389 (sb-debug::enable-debugger)
 390 (let* ((main-thread *current-thread*)
 391        (interruptor-thread
 392         (make-thread (lambda ()
 393                        (sleep 2)
 394                        (interrupt-thread main-thread #'break)
 395                        (sleep 2)
 396                        (interrupt-thread main-thread #'continue)))))
 397   (with-session-lock (*session*)
 398     (sleep 3))
 399   (loop while (thread-alive-p interruptor-thread)))
 400
 401 (format t "~&session lock test done~%")
 402
 403 (sb-ext:gc :full t)
 404 (loop repeat 20 do
 405       (wait-for-threads
 406        (loop for i below 100 collect
 407              (sb-thread:make-thread (lambda ()))))
 408       (sb-ext:gc :full t)
 409       (princ "+")
 410       (force-output))
 411
 412 (format t "~&creation test done~%")
 413
 414 ;; watch out for *current-thread* being the parent thread after exit
 415 (let ((thread (sb-thread:make-thread (lambda ()))))
 416   (wait-for-threads (list thread))
 417   (assert (null (symbol-value-in-thread 'sb-thread:*current-thread*
 418                                         thread))))
 419
 420 #|  ;; a cll post from eric marsden
 421 | (defun crash ()
 422 |   (setq *debugger-hook*
 423 |         (lambda (condition old-debugger-hook)
 424 |           (debug:backtrace 10)
 425 |           (unix:unix-exit 2)))
 426 |   #+live-dangerously
 427 |   (mp::start-sigalrm-yield)
 428 |   (flet ((roomy () (loop (with-output-to-string (*standard-output*) (room)))))
 429 |     (mp:make-process #'roomy)
 430 |     (mp:make-process #'roomy)))
 431 |#
 432
 433 ;; give the other thread time to die before we leave, otherwise the
 434 ;; overall exit status is 0, not 104
 435 (sleep 2)
 436