X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=1c8b291e804bfb1664e3b457362e9dd32931cc20;hb=891ba76c8476bb95951c4049e7c20d5895cb2233;hp=9e4fc6b9562e988b28f9b5ad37d24e6550b9ed6a;hpb=1b56edad1bf47547bbcd3b98c809b6f933ba937e;p=sbcl.git

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index 9e4fc6b..1c8b291 100644
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -15,32 +15,56 @@
 
 (in-package "SB-THREAD") ; this is white-box testing, really
 
+;;; We had appalling scaling properties for a while.  Make sure they
+;;; don't reappear.
+(defun scaling-test (function &optional (nthreads 5))
+  "Execute FUNCTION with NTHREADS lurking to slow it down."
+  (let ((queue (sb-thread:make-waitqueue))
+        (mutex (sb-thread:make-mutex)))
+    ;; Start NTHREADS idle threads.
+    (dotimes (i nthreads)
+      (sb-thread:make-thread (lambda ()
+                               (sb-thread:condition-wait queue mutex)
+			       (sb-ext:quit))))
+    (let ((start-time (get-internal-run-time)))
+      (funcall function)
+      (prog1 (- (get-internal-run-time) start-time)
+	(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)))
+    ;; a slightly weak assertion, but good enough for starters.
+    (assert (< four (* 1.5 zero)))))
+
 ;;; 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"
  (or #+linux '("-shared" "-o" "threads-foreign.so" "threads-foreign.c")
      (error "Missing shared library compilation options for this platform"))
  :search t)
-(sb-alien:load-1-foreign "threads-foreign.so")
+(sb-alien:load-shared-object "threads-foreign.so")
 (sb-alien:define-alien-routine loop-forever sb-alien:void)
 
 
 ;;; 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 +110,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)))
@@ -130,9 +166,11 @@
   (terminate-thread child))
 
 (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
@@ -141,17 +179,38 @@
 			(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)))
+(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 (zerop done) (return))
+   (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)
+(sb-ext:quit :unix-status 104)