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