X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=tests%2Fthreads.impure.lisp;h=e0973ff8b04d572eff7b06bad7c6a9ef2476e5fe;hb=782a45c5d5000d7e86c83e7b303f15270b1e03c2;hp=047769107e70760a0ced9bffd769b9ded70db83c;hpb=5b43e28a5a9f0fcdefc2132840492e2e382876c6;p=sbcl.git

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index 0477691..e0973ff 100644
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -100,7 +100,8 @@
     child))
 
 ;;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
-;;; (d) waiting on a lock
+;;; (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))
 
@@ -120,12 +121,37 @@
 		 (lambda ()
 		   (with-mutex (lock)
 		     (assert (eql (mutex-value lock) (current-thread-id))))
-		   (assert (not (eql (mutex-value lock) (current-thread-id)))))))
+		   (assert (not (eql (mutex-value lock) (current-thread-id))))
+		   (sleep 60))))
     ;;hold onto lock for long enough that child can't get it immediately
-    (sleep 5))
+    (sleep 20)
+    (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock))))
+    (format t "parent releasing lock~%"))
   (terminate-thread child))
 
-;; better would be "wait until all child threads have exited"
-(sleep 3)
+(defun alloc-stuff () (copy-list '(1 2 3 4 5)))
+(let ((c (test-interrupt (lambda () (loop (alloc-stuff))))))
+  ;; NB this only works on x86: other ports don't have a symbol for
+  ;; pseudo-atomic atomicity
+  (dotimes (i 100)
+    (sleep (random 1d0))
+    (interrupt-thread c
+		      (lambda ()
+			(princ ".") (force-output)
+			(assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
+  (terminate-thread c))
+
+;; I'm not sure that this one is always successful.  Note race potential:
+;; I haven't checked if decf is atomic here
+(let ((done 2))
+  (make-thread (lambda () (dotimes (i 100) (sb-ext:gc)) (decf done)))
+  (make-thread (lambda () (dotimes (i 25) (sb-ext:gc :full t)) (decf done)))
+  (loop
+   (when (zerop done) (return))
+   (sleep 1)))
+
+;; give the other thread time to die before we leave, otherwise the
+;; overall exit status is 0, not 104
+(sleep 2) 
 
 (sb-ext:quit :unix-status 104)