Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv23481/tests
Modified Files:
threads.impure.lisp
Log Message:
0.9.4.1: thread allocation
* *CURRENT-THREAD* is now properly unbound (don't do bind_variable
without unbind), the workaround from 0.9.3.75 is removed
* also *CURRENT-THREAD* is temporarily bound to nil in the parent
thread to avoid the child inheriting the value from the parent
that could unnecessarily keep the parent thread object around
until the child exited
* free threads' interrupt_data when necessary
* made all_threads_lock a mutex instead of a spinlock to speed
start_the_world up
* minor cleanups
Index: threads.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/threads.impure.lisp,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -d -r1.23 -r1.24
--- threads.impure.lisp 19 Aug 2005 15:14:17 -0000 1.23
+++ threads.impure.lisp 26 Aug 2005 19:01:37 -0000 1.24
@@ -13,6 +13,9 @@
(in-package "SB-THREAD") ; this is white-box testing, really
+(defun wait-for-threads (threads)
+ (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
+
(assert (eql 1 (length (list-all-threads))))
(assert (eq *current-thread*
@@ -54,7 +57,8 @@
;; Start NTHREADS idle threads.
(dotimes (i nthreads)
(sb-thread:make-thread (lambda ()
- (sb-thread:condition-wait queue mutex)
+ (with-mutex (mutex)
+ (sb-thread:condition-wait queue mutex))
(sb-ext:quit))))
(let ((start-time (get-internal-run-time)))
(funcall function)
@@ -176,7 +180,8 @@
(format t "done ~A~%" *current-thread*))))
(let ((kid1 (make-thread #'run))
(kid2 (make-thread #'run)))
- (format t "contention ~A ~A~%" kid1 kid2))))
+ (format t "contention ~A ~A~%" kid1 kid2)
+ (wait-for-threads (list kid1 kid2)))))
(defun test-interrupt (function-to-interrupt &optional quit-p)
(let ((child (make-thread function-to-interrupt)))
@@ -199,7 +204,8 @@
(test-interrupt #'loop-forever :quit)
(let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
- (terminate-thread child))
+ (terminate-thread child)
+ (wait-for-threads (list child)))
(let ((lock (make-mutex :name "loctite"))
child)
@@ -214,7 +220,8 @@
(sleep 5)
(interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock))))
(format t "parent releasing lock~%"))
- (terminate-thread child))
+ (terminate-thread child)
+ (wait-for-threads (list child)))
(format t "~&locking test done~%")
@@ -230,11 +237,10 @@
(sleep (random 0.1d0))
(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-thread:interrupt-thread thread (lambda ()))))))))
+ (wait-for-threads killers)
+ (sb-thread:terminate-thread thread)
+ (wait-for-threads (list thread))))
(sb-ext:gc :full t))
(format t "~&multi interrupt test done~%")
@@ -242,7 +248,6 @@
(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)
(dotimes (i 100)
(sleep (random 0.1d0))
(interrupt-thread c
@@ -250,7 +255,8 @@
(princ ".") (force-output)
(assert (eq (thread-state *current-thread*) :running))
(assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
- (terminate-thread c))
+ (terminate-thread c)
+ (wait-for-threads (list c)))
(format t "~&interrupt test done~%")
@@ -278,9 +284,9 @@
(dotimes (i 100)
(sleep (random 0.1d0))
(interrupt-thread c func))
- (format t "~&waiting for interrupts to arrive~%")
(loop until (= *interrupt-count* 100) do (sleep 0.1))
- (terminate-thread c)))
+ (terminate-thread c)
+ (wait-for-threads (list c))))
(format t "~&interrupt count test done~%")
@@ -393,6 +399,24 @@
(loop while (thread-alive-p interruptor-thread)))
(format t "~&session lock test done~%")
+
+(sb-ext:gc :full t)
+(loop repeat 20 do
+ (wait-for-threads
+ (loop for i below 100 collect
+ (sb-thread:make-thread (lambda ()))))
+ (sb-ext:gc :full t)
+ (princ "+")
+ (force-output))
+
+(format t "~&creation test done~%")
+
+;; watch out for *current-thread* being the parent thread after exit
+(let ((thread (sb-thread:make-thread (lambda ()))))
+ (wait-for-threads (list thread))
+ (assert (null (symbol-value-in-thread 'sb-thread:*current-thread*
+ thread))))
+
#| ;; a cll post from eric marsden
| (defun crash ()
| (setq *debugger-hook*
|