;;;; 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*))
(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)))))
(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"))
(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))
-
-(let ((l (make-waitqueue :name "spinlock"))
+ (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")
+ (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")))
+
+(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
(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)
(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))
(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))))
(sb-thread:make-thread
(lambda ()
(loop repeat 25 do
- (sleep (random 2d0))
+ (sleep (random 0.1d0))
(princ ".")
(force-output)
(sb-thread:interrupt-thread
;; pseudo-atomic atomicity
(format t "new thread ~A~%" c)
(dotimes (i 100)
- (sleep (random 1d0))
+ (sleep (random 0.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~%")
(sb-impl::atomic-incf/symbol *interrupt-count*))))
(setq *interrupt-count* 0)
(dotimes (i 100)
- (sleep (random 1d0))
+ (sleep (random 0.1d0))
(interrupt-thread c func))
- (sleep 1)
- (assert (= 100 *interrupt-count*))
+ (format t "~&waiting for interrupts to arrive~%")
+ (loop until (= *interrupt-count* 100) do (sleep 0.1))
(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))
- (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)))
(loop do
(funcall fn)
(let ((errno (sb-unix::get-errno)))
- (sleep (random 1.0))
+ (sleep (random 0.1d0))
(unless (eql errno reference-errno)
(format t "Got errno: ~A (~A) instead of ~A~%"
errno
(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*
;; 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)
projects / sbcl.git / blobdiff