0.8.10.13:

[sbcl.git] / tests / threads.impure.lisp

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index 0477691..c0feefe 100644 (file)
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -18,8 +18,7 @@
 ;;; For one of the interupt-thread tests, we want a foreign function
 ;;; that does not make syscalls
 
-(setf SB-INT:*REPL-PROMPT-FUN* #'sb-thread::thread-repl-prompt-fun)
-(with-open-file (o "threads-foreign.c" :direction :output)
+(with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede)
   (format o "void loop_forever() { while(1) ; }~%"))
 (sb-ext:run-program    
  "cc"
@@ -33,14 +32,15 @@
 ;;; elementary "can we get a lock and release it again"
 (let ((l (make-mutex :name "foo"))
       (p (current-thread-id)))
-  (assert (eql (mutex-value l) nil))
-  (assert (eql (mutex-lock l) 0))
+  (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))
-  (assert (eql (mutex-lock l) 0))
+  (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))
-  (assert (eql (mutex-lock l) 0)))
+  (assert (eql (mutex-value l) nil) nil "5")
+  (assert (eql (mutex-lock l) 0)  nil "6")
+  (describe l))
 
 (let ((queue (make-waitqueue :name "queue"))
       (lock (make-mutex :name "lock")))
@@ -86,6 +86,18 @@
       (condition-notify queue))
     (sleep 1)))
 
+(let ((mutex (make-mutex :name "contended")))
+  (labels ((run ()
+            (let ((me (current-thread-id)))
+              (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)))))
+    (let ((kid1 (make-thread #'run))
+         (kid2 (make-thread #'run)))
+      (format t "contention ~A ~A~%" kid1 kid2))))
 
 (defun test-interrupt (function-to-interrupt &optional quit-p)
   (let ((child  (make-thread function-to-interrupt)))
@@ -100,7 +112,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 +133,60 @@
                 (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
+  (format t "new thread ~A~%" c)
+  (dotimes (i 100)
+    (sleep (random 1d0))
+    (interrupt-thread c
+                     (lambda ()
+                       (princ ".") (force-output)
+                       (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
+  (terminate-thread c))
+
+(format t "~&interrupt test done~%")
+
+(let (a-done b-done)
+  (make-thread (lambda ()
+                (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)))
+  (loop
+   (when (and a-done b-done) (return))
+   (sleep 1)))
+(format t "~&gc test done~%")
+
+#|  ;; a cll post from eric marsden
+| (defun crash ()
+|   (setq *debugger-hook*
+|         (lambda (condition old-debugger-hook)
+|           (debug:backtrace 10)
+|           (unix:unix-exit 2)))
+|   #+live-dangerously
+|   (mp::start-sigalrm-yield)
+|   (flet ((roomy () (loop (with-output-to-string (*standard-output*) (room)))))
+|     (mp:make-process #'roomy)
+|     (mp:make-process #'roomy)))
+|#
+
+;; 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)