X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=d642a6927701e6348865af1c70c0be4926b9a73a;hb=41f378de3960189227541f7864e709ba78f064cd;hp=4be11bcd7e0c1f2972fa624991d9ca2fd58e3611;hpb=f16e090088c6aa6178ecf50a8b74ff41cce73640;p=sbcl.git diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 4be11bc..d642a69 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -6,15 +6,34 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;; +;;; ;;;; This software is in the public domain and is provided with ;;;; absoluely no warranty. See the COPYING and CREDITS files for ;;;; more information. -#-sb-thread (quit :unix-status 104) - (in-package "SB-THREAD") ; this is white-box testing, really +(assert (eql 1 (length (list-all-threads)))) + +(assert (eq *current-thread* + (find (thread-name *current-thread*) (list-all-threads) + :key #'thread-name :test #'equal))) + +(assert (thread-alive-p *current-thread*)) + +(let ((a 0)) + (interrupt-thread *current-thread* (lambda () (setq a 1))) + (assert (eql a 1))) + +(let ((spinlock (make-spinlock))) + (with-spinlock (spinlock))) + +(let ((mutex (make-mutex))) + (with-mutex (mutex) + mutex)) + +#-sb-thread (sb-ext:quit :unix-status 104) + (let ((old-threads (list-all-threads)) (thread (make-thread (lambda () (assert (find *current-thread* *all-threads*)) @@ -36,17 +55,17 @@ (dotimes (i nthreads) (sb-thread:make-thread (lambda () (sb-thread:condition-wait queue mutex) - (sb-ext:quit)))) + (sb-ext:quit)))) (let ((start-time (get-internal-run-time))) (funcall function) (prog1 (- (get-internal-run-time) start-time) - (sb-thread:condition-broadcast queue))))) + (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))) + (four (scaling-test work 4))) ;; a slightly weak assertion, but good enough for starters. (assert (< four (* 1.5 zero))))) @@ -55,7 +74,7 @@ (with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede) (format o "void loop_forever() { while(1) ; }~%")) -(sb-ext:run-program +(sb-ext:run-program "cc" (or #+linux '("-shared" "-o" "threads-foreign.so" "threads-foreign.c") (error "Missing shared library compilation options for this platform")) @@ -68,36 +87,29 @@ (let ((l (make-mutex :name "foo")) (p *current-thread*)) (assert (eql (mutex-value l) nil) nil "1") - (assert (eql (mutex-lock l) 0) nil "2") (sb-thread:get-mutex l) (assert (eql (mutex-value l) p) nil "3") - (assert (eql (mutex-lock l) 0) nil "4") (sb-thread:release-mutex l) - (assert (eql (mutex-value l) nil) nil "5") - (assert (eql (mutex-lock l) 0) nil "6") - (describe l)) + (assert (eql (mutex-value l) nil) nil "5")) (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"))) + (assert (eql (mutex-value l) nil) nil "6"))) -(let ((l (make-waitqueue :name "spinlock")) +(let ((l (make-spinlock :name "spinlock")) (p *current-thread*)) - (assert (eql (waitqueue-lock l) 0) nil "1") + (assert (eql (spinlock-value 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)) + (assert (eql (spinlock-value l) p) nil "2")) + (assert (eql (spinlock-value l) 0) nil "3")) ;; test that SLEEP actually sleeps for at least the given time, even ;; if interrupted by another thread exiting/a gc/anything @@ -108,60 +120,62 @@ (let ((queue (make-waitqueue :name "queue")) - (lock (make-mutex :name "lock"))) + (lock (make-mutex :name "lock")) + (n 0)) (labels ((in-new-thread () - (with-mutex (lock) - (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*))))) + (with-mutex (lock) + (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*)) + (assert (eql n 1)) + (decf n)))) (make-thread #'in-new-thread) - (sleep 2) ; give it a chance to start + (sleep 2) ; give it a chance to start ;; check the lock is free while it's asleep (format t "parent thread ~A~%" *current-thread*) - (assert (eql (mutex-value lock) nil)) - (assert (eql (mutex-lock lock) 0)) + (assert (eql (mutex-value lock) nil)) (with-mutex (lock) + (incf n) (condition-notify queue)) (sleep 1))) (let ((queue (make-waitqueue :name "queue")) (lock (make-mutex :name "lock"))) (labels ((ours-p (value) - (sb-vm:control-stack-pointer-valid-p - (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value)))) - (in-new-thread () - (with-recursive-lock (lock) - (assert (ours-p (mutex-value lock))) - (format t "~A got mutex~%" (mutex-value lock)) - ;; now drop it and sleep - (condition-wait queue lock) - ;; after waking we should have the lock again - (format t "woken, ~A got mutex~%" (mutex-value lock)) - (assert (ours-p (mutex-value lock)))))) + (sb-vm:control-stack-pointer-valid-p + (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value)))) + (in-new-thread () + (with-recursive-lock (lock) + (assert (ours-p (mutex-value lock))) + (format t "~A got mutex~%" (mutex-value lock)) + ;; now drop it and sleep + (condition-wait queue lock) + ;; after waking we should have the lock again + (format t "woken, ~A got mutex~%" (mutex-value lock)) + (assert (ours-p (mutex-value lock)))))) (make-thread #'in-new-thread) - (sleep 2) ; give it a chance to start + (sleep 2) ; give it a chance to start ;; check the lock is free while it's asleep (format t "parent thread ~A~%" *current-thread*) - (assert (eql (mutex-value lock) nil)) - (assert (eql (mutex-lock lock) 0)) + (assert (eql (mutex-value lock) nil)) (with-recursive-lock (lock) (condition-notify queue)) (sleep 1))) (let ((mutex (make-mutex :name "contended"))) (labels ((run () - (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*)))) + (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*)))) (let ((kid1 (make-thread #'run)) - (kid2 (make-thread #'run))) + (kid2 (make-thread #'run))) (format t "contention ~A ~A~%" kid1 kid2)))) (defun test-interrupt (function-to-interrupt &optional quit-p) @@ -170,9 +184,9 @@ (sleep 2) (format t "interrupting child ~A~%" child) (interrupt-thread child - (lambda () - (format t "child pid ~A~%" *current-thread*) - (when quit-p (sb-ext:quit)))) + (lambda () + (format t "child pid ~A~%" *current-thread*) + (when quit-p (sb-ext:quit)))) (sleep 1) child)) @@ -186,16 +200,16 @@ (let ((child (test-interrupt (lambda () (loop (sleep 2000)))))) (terminate-thread child)) - + (let ((lock (make-mutex :name "loctite")) child) (with-mutex (lock) (setf child (test-interrupt - (lambda () - (with-mutex (lock) - (assert (eql (mutex-value lock) *current-thread*))) - (assert (not (eql (mutex-value lock) *current-thread*))) - (sleep 10)))) + (lambda () + (with-mutex (lock) + (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 5) (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock)))) @@ -232,10 +246,10 @@ (dotimes (i 100) (sleep (random 1d0)) (interrupt-thread c - (lambda () - (princ ".") (force-output) + (lambda () + (princ ".") (force-output) (assert (eq (thread-state *current-thread*) :running)) - (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*))))) + (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*))))) (terminate-thread c)) (format t "~&interrupt test done~%") @@ -272,14 +286,14 @@ (let (a-done b-done) (make-thread (lambda () - (dotimes (i 100) - (sb-ext:gc) (princ "\\") (force-output)) - (setf a-done t))) + (dotimes (i 100) + (sb-ext:gc) (princ "\\") (force-output)) + (setf a-done t))) (make-thread (lambda () - (dotimes (i 25) - (sb-ext:gc :full t) - (princ "/") (force-output)) - (setf b-done t))) + (dotimes (i 25) + (sb-ext:gc :full t) + (princ "/") (force-output)) + (setf b-done t))) (loop (when (and a-done b-done) (return)) (sleep 1))) @@ -394,6 +408,6 @@ ;; give the other thread time to die before we leave, otherwise the ;; overall exit status is 0, not 104 -(sleep 2) +(sleep 2) (sb-ext:quit :unix-status 104)