X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=4be11bcd7e0c1f2972fa624991d9ca2fd58e3611;hb=f16e090088c6aa6178ecf50a8b74ff41cce73640;hp=c0feefe3d25298b7a1b2811cc82c846fa6a6bfa7;hpb=fb9c34275389e23f32d80954ab4848fac48936d9;p=sbcl.git diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index c0feefe..4be11bc 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -15,6 +15,41 @@ (in-package "SB-THREAD") ; this is white-box testing, really +(let ((old-threads (list-all-threads)) + (thread (make-thread (lambda () + (assert (find *current-thread* *all-threads*)) + (sleep 2)))) + (new-threads (list-all-threads))) + (assert (thread-alive-p thread)) + (assert (eq thread (first new-threads))) + (assert (= (1+ (length old-threads)) (length new-threads))) + (sleep 3) + (assert (not (thread-alive-p thread)))) + +;;; 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 @@ -25,13 +60,13 @@ (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) ;;; elementary "can we get a lock and release it again" (let ((l (make-mutex :name "foo")) - (p (current-thread-id))) + (p *current-thread*)) (assert (eql (mutex-value l) nil) nil "1") (assert (eql (mutex-lock l) 0) nil "2") (sb-thread:get-mutex l) @@ -42,20 +77,50 @@ (assert (eql (mutex-lock l) 0) nil "6") (describe l)) +(labels ((ours-p (value) + (sb-vm:control-stack-pointer-valid-p + (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value))))) + (let ((l (make-mutex :name "rec"))) + (assert (eql (mutex-value l) nil) nil "1") + (assert (eql (mutex-lock l) 0) nil "2") + (sb-thread:with-recursive-lock (l) + (assert (ours-p (mutex-value l)) nil "3") + (sb-thread:with-recursive-lock (l) + (assert (ours-p (mutex-value l)) nil "4")) + (assert (ours-p (mutex-value l)) nil "5")) + (assert (eql (mutex-value l) nil) nil "6") + (assert (eql (mutex-lock l) 0) nil "7"))) + +(let ((l (make-waitqueue :name "spinlock")) + (p *current-thread*)) + (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) (sb-ext:gc :full t))) + (sleep 5) + (assert (>= (get-universal-time) (+ 5 start-time)))) + + (let ((queue (make-waitqueue :name "queue")) (lock (make-mutex :name "lock"))) (labels ((in-new-thread () (with-mutex (lock) - (assert (eql (mutex-value lock) (current-thread-id))) - (format t "~A got mutex~%" (current-thread-id)) + (assert (eql (mutex-value lock) *current-thread*)) + (format t "~A got mutex~%" *current-thread*) ;; now drop it and sleep (condition-wait queue lock) ;; after waking we should have the lock again - (assert (eql (mutex-value lock) (current-thread-id)))))) + (assert (eql (mutex-value lock) *current-thread*))))) (make-thread #'in-new-thread) (sleep 2) ; give it a chance to start ;; check the lock is free while it's asleep - (format t "parent thread ~A~%" (current-thread-id)) + (format t "parent thread ~A~%" *current-thread*) (assert (eql (mutex-value lock) nil)) (assert (eql (mutex-lock lock) 0)) (with-mutex (lock) @@ -79,7 +144,7 @@ (make-thread #'in-new-thread) (sleep 2) ; give it a chance to start ;; check the lock is free while it's asleep - (format t "parent thread ~A~%" (current-thread-id)) + (format t "parent thread ~A~%" *current-thread*) (assert (eql (mutex-value lock) nil)) (assert (eql (mutex-lock lock) 0)) (with-recursive-lock (lock) @@ -88,13 +153,13 @@ (let ((mutex (make-mutex :name "contended"))) (labels ((run () - (let ((me (current-thread-id))) + (let ((me *current-thread*)) (dotimes (i 100) (with-mutex (mutex) (sleep .1) (assert (eql (mutex-value mutex) me))) (assert (not (eql (mutex-value mutex) me)))) - (format t "done ~A~%" (current-thread-id))))) + (format t "done ~A~%" *current-thread*)))) (let ((kid1 (make-thread #'run)) (kid2 (make-thread #'run))) (format t "contention ~A ~A~%" kid1 kid2)))) @@ -106,24 +171,20 @@ (format t "interrupting child ~A~%" child) (interrupt-thread child (lambda () - (format t "child pid ~A~%" (current-thread-id)) + (format t "child pid ~A~%" *current-thread*) (when quit-p (sb-ext:quit)))) (sleep 1) child)) -;;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall, -;;; (d) waiting on a lock, (e) some code which we hope is likely to be -;;; in pseudo-atomic +;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall, +;; (d) waiting on a lock, (e) some code which we hope is likely to be +;; in pseudo-atomic (let ((child (test-interrupt (lambda () (loop))))) (terminate-thread child)) (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")) @@ -132,18 +193,39 @@ (setf child (test-interrupt (lambda () (with-mutex (lock) - (assert (eql (mutex-value lock) (current-thread-id)))) - (assert (not (eql (mutex-value lock) (current-thread-id)))) - (sleep 60)))) + (assert (eql (mutex-value lock) *current-thread*))) + (assert (not (eql (mutex-value lock) *current-thread*))) + (sleep 10)))) ;;hold onto lock for long enough that child can't get it immediately - (sleep 20) + (sleep 5) (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock)))) (format t "parent releasing lock~%")) (terminate-thread child)) +(format t "~&locking test done~%") + (defun alloc-stuff () (copy-list '(1 2 3 4 5))) -(let ((c (test-interrupt (lambda () (loop (alloc-stuff)))))) +(progn + (let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff)))))) + (let ((killers + (loop repeat 4 collect + (sb-thread:make-thread + (lambda () + (loop repeat 25 do + (sleep (random 2d0)) + (princ ".") + (force-output) + (sb-thread:interrupt-thread + thread + (lambda ())))))))) + (loop while (some #'thread-alive-p killers) do (sleep 0.1)) + (sb-thread:terminate-thread thread))) + (sb-ext:gc :full t)) + +(format t "~&multi interrupt test done~%") + +(let ((c (make-thread (lambda () (loop (alloc-stuff)))))) ;; NB this only works on x86: other ports don't have a symbol for ;; pseudo-atomic atomicity (format t "new thread ~A~%" c) @@ -152,15 +234,46 @@ (interrupt-thread c (lambda () (princ ".") (force-output) + (assert (eq (thread-state *current-thread*) :running)) (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*))))) (terminate-thread c)) (format t "~&interrupt test done~%") +(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*)))) + (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 count test done~%") + (let (a-done b-done) (make-thread (lambda () (dotimes (i 100) - (sb-ext:gc) (princ "\\") (force-output) ) + (sb-ext:gc) (princ "\\") (force-output)) (setf a-done t))) (make-thread (lambda () (dotimes (i 25) @@ -170,8 +283,102 @@ (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~%") + +(sb-debug::enable-debugger) +(let* ((main-thread *current-thread*) + (interruptor-thread + (make-thread (lambda () + (sleep 2) + (interrupt-thread main-thread #'break) + (sleep 2) + (interrupt-thread main-thread #'continue))))) + (with-session-lock (*session*) + (sleep 3)) + (loop while (thread-alive-p interruptor-thread))) + +(format t "~&session lock test done~%") #| ;; a cll post from eric marsden | (defun crash () | (setq *debugger-hook*