0.9.1.29:

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

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index 4b59604..a312f3b 100644 (file)
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -15,17 +15,41 @@
 
 (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
 
-(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)
 
 
@@ -42,6 +66,14 @@
   (assert (eql (mutex-lock l) 0)  nil "6")
   (describe l))
 
+;; test that SLEEP actually sleeps for at least the given time, even
+;; if interrupted by another thread exiting/a gc/anything
+(let ((start-time (get-universal-time)))
+  (make-thread (lambda () (sleep 1))) ; kid waits 1 then dies ->SIG_THREAD_EXIT
+  (sleep 5)
+  (assert (>= (get-universal-time) (+ 5 start-time))))
+
+
 (let ((queue (make-waitqueue :name "queue"))
       (lock (make-mutex :name "lock")))
   (labels ((in-new-thread ()
@@ -155,6 +187,35 @@
                        (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
   (terminate-thread c))
 
+(defparameter *interrupt-count* 0)
+
+(declaim (notinline check-interrupt-count))
+(defun check-interrupt-count (i)
+  (declare (optimize (debug 1) (speed 1)))
+  ;; This used to lose if eflags were not restored after an interrupt.
+  (unless (typep i 'fixnum)
+    (error "!!!!!!!!!!!")))
+
+(let ((c (make-thread
+          (lambda ()
+            (handler-bind ((error #'(lambda (cond)
+                                      (princ cond)
+                                      (sb-debug:backtrace
+                                       most-positive-fixnum))))
+              (loop (check-interrupt-count *interrupt-count*)))))))
+  (let ((func (lambda ()
+                (princ ".")
+                (force-output)
+                (sb-impl::atomic-incf/symbol *interrupt-count*))))
+    (sb-sys:with-pinned-objects (func)
+      (setq *interrupt-count* 0)
+      (dotimes (i 100)
+        (sleep (random 1d0))
+        (interrupt-thread c func))
+      (sleep 1)
+      (assert (= 100 *interrupt-count*))
+      (terminate-thread c))))
+
 (format t "~&interrupt test done~%")
 
 (let (a-done b-done)
@@ -170,6 +231,31 @@
   (loop
    (when (and a-done b-done) (return))
    (sleep 1)))
+
+(defun waste (&optional (n 100000))
+  (loop repeat n do (make-string 16384)))
+
+(loop for i below 100 do
+      (format t "LOOP:~A~%" i)
+      (force-output)
+      (sb-thread:make-thread
+       #'(lambda ()
+           (waste)))
+      (waste)
+      (sb-ext:gc))
+
+(defparameter *aaa* nil)
+(loop for i below 100 do
+      (format t "LOOP:~A~%" i)
+      (force-output)
+      (sb-thread:make-thread
+       #'(lambda ()
+           (let ((*aaa* (waste)))
+             (waste))))
+      (let ((*aaa* (waste)))
+        (waste))
+      (sb-ext:gc))
+
 (format t "~&gc test done~%")
 
 #|  ;; a cll post from eric marsden