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 ;;; For one of the interupt-thread tests, we want a foreign function
  19 ;;; that does not make syscalls
  20
  21 (setf SB-INT:*REPL-PROMPT-FUN* #'sb-thread::thread-repl-prompt-fun)
  22 (with-open-file (o "threads-foreign.c" :direction :output)
  23   (format o "void loop_forever() { while(1) ; }~%"))
  24 (sb-ext:run-program
  25  "cc"
  26  (or #+linux '("-shared" "-o" "threads-foreign.so" "threads-foreign.c")
  27      (error "Missing shared library compilation options for this platform"))
  28  :search t)
  29 (sb-alien:load-1-foreign "threads-foreign.so")
  30 (sb-alien:define-alien-routine loop-forever sb-alien:void)
  31
  32
  33 ;;; elementary "can we get a lock and release it again"
  34 (let ((l (make-mutex :name "foo"))
  35       (p (current-thread-id)))
  36   (assert (eql (mutex-value l) nil))
  37   (assert (eql (mutex-lock l) 0))
  38   (sb-thread:get-mutex l)
  39   (assert (eql (mutex-value l) p))
  40   (assert (eql (mutex-lock l) 0))
  41   (sb-thread:release-mutex l)
  42   (assert (eql (mutex-value l) nil))
  43   (assert (eql (mutex-lock l) 0)))
  44
  45 (let ((queue (make-waitqueue :name "queue"))
  46       (lock (make-mutex :name "lock")))
  47   (labels ((in-new-thread ()
  48              (with-mutex (lock)
  49                (assert (eql (mutex-value lock) (current-thread-id)))
  50                (format t "~A got mutex~%" (current-thread-id))
  51                ;; now drop it and sleep
  52                (condition-wait queue lock)
  53                ;; after waking we should have the lock again
  54                (assert (eql (mutex-value lock) (current-thread-id))))))
  55     (make-thread #'in-new-thread)
  56     (sleep 2)                           ; give it  a chance to start
  57     ;; check the lock is free while it's asleep
  58     (format t "parent thread ~A~%" (current-thread-id))
  59     (assert (eql (mutex-value lock) nil))
  60     (assert (eql (mutex-lock lock) 0))
  61     (with-mutex (lock)
  62       (condition-notify queue))
  63     (sleep 1)))
  64
  65 (let ((queue (make-waitqueue :name "queue"))
  66       (lock (make-mutex :name "lock")))
  67   (labels ((ours-p (value)
  68              (sb-vm:control-stack-pointer-valid-p
  69               (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value))))
  70            (in-new-thread ()
  71              (with-recursive-lock (lock)
  72                (assert (ours-p (mutex-value lock)))
  73                (format t "~A got mutex~%" (mutex-value lock))
  74                ;; now drop it and sleep
  75                (condition-wait queue lock)
  76                ;; after waking we should have the lock again
  77                (format t "woken, ~A got mutex~%" (mutex-value lock))
  78                (assert (ours-p (mutex-value lock))))))
  79     (make-thread #'in-new-thread)
  80     (sleep 2)                           ; give it  a chance to start
  81     ;; check the lock is free while it's asleep
  82     (format t "parent thread ~A~%" (current-thread-id))
  83     (assert (eql (mutex-value lock) nil))
  84     (assert (eql (mutex-lock lock) 0))
  85     (with-recursive-lock (lock)
  86       (condition-notify queue))
  87     (sleep 1)))
  88
  89
  90 (defun test-interrupt (function-to-interrupt &optional quit-p)
  91   (let ((child  (make-thread function-to-interrupt)))
  92     ;;(format t "gdb ./src/runtime/sbcl ~A~%attach ~A~%" child child)
  93     (sleep 2)
  94     (format t "interrupting child ~A~%" child)
  95     (interrupt-thread child
  96                       (lambda ()
  97                         (format t "child pid ~A~%" (current-thread-id))
  98                         (when quit-p (sb-ext:quit))))
  99     (sleep 1)
 100     child))
 101
 102 ;;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
 103 ;;; (d) waiting on a lock, (e) some code which we hope is likely to be
 104 ;;; in pseudo-atomic
 105
 106 (let ((child (test-interrupt (lambda () (loop)))))  (terminate-thread child))
 107
 108 (test-interrupt #'loop-forever :quit)
 109
 110 (let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
 111   ;; Interrupting a sleep form causes it to return early.  Welcome to Unix.
 112   ;; Just to be sure our LOOP form works, let's check the child is still
 113   ;; there
 114   (assert (zerop (sb-unix:unix-kill child 0)))
 115   (terminate-thread child))
 116
 117 (let ((lock (make-mutex :name "loctite"))
 118       child)
 119   (with-mutex (lock)
 120     (setf child (test-interrupt
 121                  (lambda ()
 122                    (with-mutex (lock)
 123                      (assert (eql (mutex-value lock) (current-thread-id))))
 124                    (assert (not (eql (mutex-value lock) (current-thread-id))))
 125                    (sleep 60))))
 126     ;;hold onto lock for long enough that child can't get it immediately
 127     (sleep 20)
 128     (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock))))
 129     (format t "parent releasing lock~%"))
 130   (terminate-thread child))
 131
 132 (defun alloc-stuff () (copy-list '(1 2 3 4 5)))
 133 (let ((c (test-interrupt (lambda () (loop (alloc-stuff))))))
 134   ;; NB this only works on x86: other ports don't have a symbol for
 135   ;; pseudo-atomic atomicity
 136   (dotimes (i 100)
 137     (sleep (random 1d0))
 138     (interrupt-thread c
 139                       (lambda ()
 140                         (princ ".") (force-output)
 141                         (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
 142   (terminate-thread c))
 143
 144 ;; I'm not sure that this one is always successful.  Note race potential:
 145 ;; I haven't checked if decf is atomic here
 146 (let ((done 2))
 147   (make-thread (lambda () (dotimes (i 100) (sb-ext:gc)) (decf done)))
 148   (make-thread (lambda () (dotimes (i 25) (sb-ext:gc :full t)) (decf done)))
 149   (loop
 150    (when (zerop done) (return))
 151    (sleep 1)))
 152
 153 ;; give the other thread time to die before we leave, otherwise the
 154 ;; overall exit status is 0, not 104
 155 (sleep 2)
 156
 157 (sb-ext:quit :unix-status 104)