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