(in-package "SB-THREAD") ; this is white-box testing, really
+;;; We had appalling scaling properties for a while. Make sure they
+;;; don't reappear.
+(defun scaling-test (function &optional (nthreads 5))
+ "Execute FUNCTION with NTHREADS lurking to slow it down."
+ (let ((queue (sb-thread:make-waitqueue))
+ (mutex (sb-thread:make-mutex)))
+ ;; Start NTHREADS idle threads.
+ (dotimes (i nthreads)
+ (sb-thread:make-thread (lambda ()
+ (sb-thread:condition-wait queue mutex)
+ (sb-ext:quit))))
+ (let ((start-time (get-internal-run-time)))
+ (funcall function)
+ (prog1 (- (get-internal-run-time) start-time)
+ (sb-thread:condition-broadcast queue)))))
+(defun fact (n)
+ "A function that does work with the CPU."
+ (if (zerop n) 1 (* n (fact (1- n)))))
+(let ((work (lambda () (fact 15000))))
+ (let ((zero (scaling-test work 0))
+ (four (scaling-test work 4)))
+ ;; a slightly weak assertion, but good enough for starters.
+ (assert (< four (* 1.5 zero)))))
+
;;; For one of the interupt-thread tests, we want a foreign function
;;; that does not make syscalls
-(with-open-file (o "threads-foreign.c" :direction :output)
+(with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede)
(format o "void loop_forever() { while(1) ; }~%"))
(sb-ext:run-program
"cc"
(or #+linux '("-shared" "-o" "threads-foreign.so" "threads-foreign.c")
(error "Missing shared library compilation options for this platform"))
:search t)
-(sb-alien:load-1-foreign "threads-foreign.so")
+(sb-alien:load-shared-object "threads-foreign.so")
(sb-alien:define-alien-routine loop-forever sb-alien:void)
(assert (eql (mutex-lock l) 0) nil "6")
(describe l))
+(let ((l (make-waitqueue :name "spinlock"))
+ (p (current-thread-id)))
+ (assert (eql (waitqueue-lock l) 0) nil "1")
+ (with-spinlock (l)
+ (assert (eql (waitqueue-lock l) p) nil "2"))
+ (assert (eql (waitqueue-lock l) 0) nil "3")
+ (describe l))
+
+;; test that SLEEP actually sleeps for at least the given time, even
+;; if interrupted by another thread exiting/a gc/anything
+(let ((start-time (get-universal-time)))
+ (make-thread (lambda () (sleep 1))) ; kid waits 1 then dies ->SIG_THREAD_EXIT
+ (sleep 5)
+ (assert (>= (get-universal-time) (+ 5 start-time))))
+
+
(let ((queue (make-waitqueue :name "queue"))
(lock (make-mutex :name "lock")))
(labels ((in-new-thread ()
(test-interrupt #'loop-forever :quit)
(let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
- ;; Interrupting a sleep form causes it to return early. Welcome to Unix.
- ;; Just to be sure our LOOP form works, let's check the child is still
- ;; there
- (assert (zerop (sb-unix:unix-kill child 0)))
(terminate-thread child))
(let ((lock (make-mutex :name "loctite"))
(princ ".") (force-output)
(assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
(terminate-thread c))
+(terpri)
+
+(defparameter *interrupt-count* 0)
+
+(declaim (notinline check-interrupt-count))
+(defun check-interrupt-count (i)
+ (declare (optimize (debug 1) (speed 1)))
+ ;; This used to lose if eflags were not restored after an interrupt.
+ (unless (typep i 'fixnum)
+ (error "!!!!!!!!!!!")))
+
+(let ((c (make-thread
+ (lambda ()
+ (handler-bind ((error #'(lambda (cond)
+ (princ cond)
+ (sb-debug:backtrace
+ most-positive-fixnum))))
+ (loop (check-interrupt-count *interrupt-count*)))))))
+ (let ((func (lambda ()
+ (princ ".")
+ (force-output)
+ (sb-impl::atomic-incf/symbol *interrupt-count*))))
+ (sb-sys:with-pinned-objects (func)
+ (setq *interrupt-count* 0)
+ (dotimes (i 100)
+ (sleep (random 1d0))
+ (interrupt-thread c func))
+ (sleep 1)
+ (assert (= 100 *interrupt-count*))
+ (terminate-thread c))))
(format t "~&interrupt test done~%")
(loop
(when (and a-done b-done) (return))
(sleep 1)))
+
+(terpri)
+
+(defun waste (&optional (n 100000))
+ (loop repeat n do (make-string 16384)))
+
+(loop for i below 100 do
+ (princ "!")
+ (force-output)
+ (sb-thread:make-thread
+ #'(lambda ()
+ (waste)))
+ (waste)
+ (sb-ext:gc))
+
+(terpri)
+
+(defparameter *aaa* nil)
+(loop for i below 100 do
+ (princ "!")
+ (force-output)
+ (sb-thread:make-thread
+ #'(lambda ()
+ (let ((*aaa* (waste)))
+ (waste))))
+ (let ((*aaa* (waste)))
+ (waste))
+ (sb-ext:gc))
+
(format t "~&gc test done~%")
+;; this used to deadlock on session-lock
+(sb-thread:make-thread (lambda () (sb-ext:gc)))
+;; expose thread creation races by exiting quickly
+(sb-thread:make-thread (lambda ()))
+
+(defun exercise-syscall (fn reference-errno)
+ (sb-thread:make-thread
+ (lambda ()
+ (loop do
+ (funcall fn)
+ (let ((errno (sb-unix::get-errno)))
+ (sleep (random 1.0))
+ (unless (eql errno reference-errno)
+ (format t "Got errno: ~A (~A) instead of ~A~%"
+ errno
+ (sb-unix::strerror)
+ reference-errno)
+ (force-output)
+ (sb-ext:quit :unix-status 1)))))))
+
+(let* ((nanosleep-errno (progn
+ (sb-unix:nanosleep -1 0)
+ (sb-unix::get-errno)))
+ (open-errno (progn
+ (open "no-such-file"
+ :if-does-not-exist nil)
+ (sb-unix::get-errno)))
+ (threads
+ (list
+ (exercise-syscall (lambda () (sb-unix:nanosleep -1 0)) nanosleep-errno)
+ (exercise-syscall (lambda () (open "no-such-file"
+ :if-does-not-exist nil))
+ open-errno)
+ (sb-thread:make-thread (lambda () (loop (sb-ext:gc) (sleep 1)))))))
+ (sleep 10)
+ (princ "terminating threads")
+ (dolist (thread threads)
+ (sb-thread:terminate-thread thread)))
+
+(format t "~&errno test done~%")
+
+(loop repeat 100 do
+ (let ((thread (sb-thread:make-thread (lambda () (sleep 0.1)))))
+ (sb-thread:interrupt-thread
+ thread
+ (lambda ()
+ (assert (find-restart 'sb-thread:terminate-thread))))))
+
+(sb-ext:gc :full t)
+
+(format t "~&thread startup sigmask test done~%")
+
#| ;; a cll post from eric marsden
| (defun crash ()
| (setq *debugger-hook*
projects / sbcl.git / blobdiff