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