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 (let ((l (make-waitqueue :name "spinlock"))
  81       (p *current-thread*))
  82   (assert (eql (waitqueue-lock l) 0) nil "1")
  83   (with-spinlock (l)
  84     (assert (eql (waitqueue-lock l) p) nil "2"))
  85   (assert (eql (waitqueue-lock l) 0) nil "3")
  86   (describe l))
  87
  88 ;; test that SLEEP actually sleeps for at least the given time, even
  89 ;; if interrupted by another thread exiting/a gc/anything
  90 (let ((start-time (get-universal-time)))
  91   (make-thread (lambda () (sleep 1) (sb-ext:gc :full t)))
  92   (sleep 5)
  93   (assert (>= (get-universal-time) (+ 5 start-time))))
  94
  95
  96 (let ((queue (make-waitqueue :name "queue"))
  97       (lock (make-mutex :name "lock")))
  98   (labels ((in-new-thread ()
  99              (with-mutex (lock)
 100                (assert (eql (mutex-value lock) *current-thread*))
 101                (format t "~A got mutex~%" *current-thread*)
 102                ;; now drop it and sleep
 103                (condition-wait queue lock)
 104                ;; after waking we should have the lock again
 105                (assert (eql (mutex-value lock) *current-thread*)))))
 106     (make-thread #'in-new-thread)
 107     (sleep 2)                           ; give it  a chance to start
 108     ;; check the lock is free while it's asleep
 109     (format t "parent thread ~A~%" *current-thread*)
 110     (assert (eql (mutex-value lock) nil))
 111     (assert (eql (mutex-lock lock) 0))
 112     (with-mutex (lock)
 113       (condition-notify queue))
 114     (sleep 1)))
 115
 116 (let ((queue (make-waitqueue :name "queue"))
 117       (lock (make-mutex :name "lock")))
 118   (labels ((ours-p (value)
 119              (sb-vm:control-stack-pointer-valid-p
 120               (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value))))
 121            (in-new-thread ()
 122              (with-recursive-lock (lock)
 123                (assert (ours-p (mutex-value lock)))
 124                (format t "~A got mutex~%" (mutex-value lock))
 125                ;; now drop it and sleep
 126                (condition-wait queue lock)
 127                ;; after waking we should have the lock again
 128                (format t "woken, ~A got mutex~%" (mutex-value lock))
 129                (assert (ours-p (mutex-value lock))))))
 130     (make-thread #'in-new-thread)
 131     (sleep 2)                           ; give it  a chance to start
 132     ;; check the lock is free while it's asleep
 133     (format t "parent thread ~A~%" *current-thread*)
 134     (assert (eql (mutex-value lock) nil))
 135     (assert (eql (mutex-lock lock) 0))
 136     (with-recursive-lock (lock)
 137       (condition-notify queue))
 138     (sleep 1)))
 139
 140 (let ((mutex (make-mutex :name "contended")))
 141   (labels ((run ()
 142              (let ((me *current-thread*))
 143                (dotimes (i 100)
 144                  (with-mutex (mutex)
 145                    (sleep .1)
 146                    (assert (eql (mutex-value mutex) me)))
 147                  (assert (not (eql (mutex-value mutex) me))))
 148                (format t "done ~A~%" *current-thread*))))
 149     (let ((kid1 (make-thread #'run))
 150           (kid2 (make-thread #'run)))
 151       (format t "contention ~A ~A~%" kid1 kid2))))
 152
 153 (defun test-interrupt (function-to-interrupt &optional quit-p)
 154   (let ((child  (make-thread function-to-interrupt)))
 155     ;;(format t "gdb ./src/runtime/sbcl ~A~%attach ~A~%" child child)
 156     (sleep 2)
 157     (format t "interrupting child ~A~%" child)
 158     (interrupt-thread child
 159                       (lambda ()
 160                         (format t "child pid ~A~%" *current-thread*)
 161                         (when quit-p (sb-ext:quit))))
 162     (sleep 1)
 163     child))
 164
 165 ;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
 166 ;; (d) waiting on a lock, (e) some code which we hope is likely to be
 167 ;; in pseudo-atomic
 168
 169 (let ((child (test-interrupt (lambda () (loop)))))  (terminate-thread child))
 170
 171 (test-interrupt #'loop-forever :quit)
 172
 173 (let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
 174   (terminate-thread child))
 175
 176 (let ((lock (make-mutex :name "loctite"))
 177       child)
 178   (with-mutex (lock)
 179     (setf child (test-interrupt
 180                  (lambda ()
 181                    (with-mutex (lock)
 182                      (assert (eql (mutex-value lock) *current-thread*)))
 183                    (assert (not (eql (mutex-value lock) *current-thread*)))
 184                    (sleep 10))))
 185     ;;hold onto lock for long enough that child can't get it immediately
 186     (sleep 5)
 187     (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock))))
 188     (format t "parent releasing lock~%"))
 189   (terminate-thread child))
 190
 191 (format t "~&locking test done~%")
 192
 193 (defun alloc-stuff () (copy-list '(1 2 3 4 5)))
 194
 195 (progn
 196   (let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff))))))
 197     (let ((killers
 198            (loop repeat 4 collect
 199                  (sb-thread:make-thread
 200                   (lambda ()
 201                     (loop repeat 25 do
 202                           (sleep (random 2d0))
 203                           (princ ".")
 204                           (force-output)
 205                           (sb-thread:interrupt-thread
 206                            thread
 207                            (lambda ()))))))))
 208       (loop while (some #'thread-alive-p killers) do (sleep 0.1))
 209       (sb-thread:terminate-thread thread)))
 210   (sb-ext:gc :full t))
 211
 212 (format t "~&multi interrupt test done~%")
 213
 214 (let ((c (make-thread (lambda () (loop (alloc-stuff))))))
 215   ;; NB this only works on x86: other ports don't have a symbol for
 216   ;; pseudo-atomic atomicity
 217   (format t "new thread ~A~%" c)
 218   (dotimes (i 100)
 219     (sleep (random 1d0))
 220     (interrupt-thread c
 221                       (lambda ()
 222                         (princ ".") (force-output)
 223                         (assert (eq (thread-state *current-thread*) :running))
 224                         (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
 225   (terminate-thread c))
 226
 227 (format t "~&interrupt test done~%")
 228
 229 (defparameter *interrupt-count* 0)
 230
 231 (declaim (notinline check-interrupt-count))
 232 (defun check-interrupt-count (i)
 233   (declare (optimize (debug 1) (speed 1)))
 234   ;; This used to lose if eflags were not restored after an interrupt.
 235   (unless (typep i 'fixnum)
 236     (error "!!!!!!!!!!!")))
 237
 238 (let ((c (make-thread
 239           (lambda ()
 240             (handler-bind ((error #'(lambda (cond)
 241                                       (princ cond)
 242                                       (sb-debug:backtrace
 243                                        most-positive-fixnum))))
 244               (loop (check-interrupt-count *interrupt-count*)))))))
 245   (let ((func (lambda ()
 246                 (princ ".")
 247                 (force-output)
 248                 (sb-impl::atomic-incf/symbol *interrupt-count*))))
 249     (setq *interrupt-count* 0)
 250     (dotimes (i 100)
 251       (sleep (random 1d0))
 252       (interrupt-thread c func))
 253     (sleep 1)
 254     (assert (= 100 *interrupt-count*))
 255     (terminate-thread c)))
 256
 257 (format t "~&interrupt count test done~%")
 258
 259 (let (a-done b-done)
 260   (make-thread (lambda ()
 261                  (dotimes (i 100)
 262                    (sb-ext:gc) (princ "\\") (force-output))
 263                  (setf a-done t)))
 264   (make-thread (lambda ()
 265                  (dotimes (i 25)
 266                    (sb-ext:gc :full t)
 267                    (princ "/") (force-output))
 268                  (setf b-done t)))
 269   (loop
 270    (when (and a-done b-done) (return))
 271    (sleep 1)))
 272
 273 (terpri)
 274
 275 (defun waste (&optional (n 100000))
 276   (loop repeat n do (make-string 16384)))
 277
 278 (loop for i below 100 do
 279       (princ "!")
 280       (force-output)
 281       (sb-thread:make-thread
 282        #'(lambda ()
 283            (waste)))
 284       (waste)
 285       (sb-ext:gc))
 286
 287 (terpri)
 288
 289 (defparameter *aaa* nil)
 290 (loop for i below 100 do
 291       (princ "!")
 292       (force-output)
 293       (sb-thread:make-thread
 294        #'(lambda ()
 295            (let ((*aaa* (waste)))
 296              (waste))))
 297       (let ((*aaa* (waste)))
 298         (waste))
 299       (sb-ext:gc))
 300
 301 (format t "~&gc test done~%")
 302
 303 ;; this used to deadlock on session-lock
 304 (sb-thread:make-thread (lambda () (sb-ext:gc)))
 305 ;; expose thread creation races by exiting quickly
 306 (sb-thread:make-thread (lambda ()))
 307
 308 (defun exercise-syscall (fn reference-errno)
 309   (sb-thread:make-thread
 310    (lambda ()
 311      (loop do
 312           (funcall fn)
 313           (let ((errno (sb-unix::get-errno)))
 314             (sleep (random 1.0))
 315             (unless (eql errno reference-errno)
 316               (format t "Got errno: ~A (~A) instead of ~A~%"
 317                       errno
 318                       (sb-unix::strerror)
 319                       reference-errno)
 320               (force-output)
 321               (sb-ext:quit :unix-status 1)))))))
 322
 323 (let* ((nanosleep-errno (progn
 324                           (sb-unix:nanosleep -1 0)
 325                           (sb-unix::get-errno)))
 326        (open-errno (progn
 327                      (open "no-such-file"
 328                            :if-does-not-exist nil)
 329                      (sb-unix::get-errno)))
 330        (threads
 331         (list
 332          (exercise-syscall (lambda () (sb-unix:nanosleep -1 0)) nanosleep-errno)
 333          (exercise-syscall (lambda () (open "no-such-file"
 334                                             :if-does-not-exist nil))
 335                            open-errno)
 336          (sb-thread:make-thread (lambda () (loop (sb-ext:gc) (sleep 1)))))))
 337   (sleep 10)
 338   (princ "terminating threads")
 339   (dolist (thread threads)
 340     (sb-thread:terminate-thread thread)))
 341
 342 (format t "~&errno test done~%")
 343
 344 (loop repeat 100 do
 345       (let ((thread (sb-thread:make-thread (lambda () (sleep 0.1)))))
 346         (sb-thread:interrupt-thread
 347          thread
 348          (lambda ()
 349            (assert (find-restart 'sb-thread:terminate-thread))))))
 350
 351 (sb-ext:gc :full t)
 352
 353 (format t "~&thread startup sigmask test done~%")
 354
 355 (sb-debug::enable-debugger)
 356 (let* ((main-thread *current-thread*)
 357        (interruptor-thread
 358         (make-thread (lambda ()
 359                        (sleep 2)
 360                        (interrupt-thread main-thread #'break)
 361                        (sleep 2)
 362                        (interrupt-thread main-thread #'continue)))))
 363   (with-session-lock (*session*)
 364     (sleep 3))
 365   (loop while (thread-alive-p interruptor-thread)))
 366
 367 (format t "~&session lock test done~%")
 368 #|  ;; a cll post from eric marsden
 369 | (defun crash ()
 370 |   (setq *debugger-hook*
 371 |         (lambda (condition old-debugger-hook)
 372 |           (debug:backtrace 10)
 373 |           (unix:unix-exit 2)))
 374 |   #+live-dangerously
 375 |   (mp::start-sigalrm-yield)
 376 |   (flet ((roomy () (loop (with-output-to-string (*standard-output*) (room)))))
 377 |     (mp:make-process #'roomy)
 378 |     (mp:make-process #'roomy)))
 379 |#
 380
 381 ;; give the other thread time to die before we leave, otherwise the
 382 ;; overall exit status is 0, not 104
 383 (sleep 2)
 384
 385 (sb-ext:quit :unix-status 104)