[Sbcl-commits] CVS: sbcl/tests threads.impure.lisp, 1.64, 1.65 timer.impure.lisp, 1.13, 1.14

[Gabor M. <me...@us...>]

Update of /cvsroot/sbcl/sbcl/tests
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv5258/tests

Modified Files:
	threads.impure.lisp timer.impure.lisp 
Log Message:
1.0.25.44: INTERRUPT-THREAD and timer improvements

The main thing accomplished by this commit is that it's finally
possible to use INTERRUPT-THREAD and TIMERS sanely:

- there is a per thread interruption queue, interruption are executed
  in order of arrival

- the interruption has to explicitly enable interrupts with
  WITH-INTERRUPTS if needed. In the absence of WITH-INTERRUPTS the
  interruption itself is not interrupted and running out of stack is
  not a problem.

- timers have an improved repeat mechanism

Implementation notes:

- INTERRUPT-THREAD is implemented on all platforms and builds (that
  is, even without :SB-THREAD) by sending a signal to the current
  thread (or process without thread). This allows us to hook into the
  normal, interrupt deferral mechanism without having to commit OAOO
  violations on the Lisp side. And it makes threaded, non-threaded
  builds closer, hopefully easing testing.

- SIG_INTERRUPT_THREAD is SIGPIPE on all platforms. SIGPIPE is not
  used in SBCL for its original purpose, instead it's for signalling a
  thread that it should look at its interruption queue. The handler
  (RUN_INTERRUPTION) just returns if there is nothing to do so it's
  safe to receive spurious SIGPIPEs coming from the kernel.

- IN-INTERRUPTION does not unblock deferrables anymore, but arranges
  for them to be unblocked when interrupts are enabled (see
  *UNBLOCK-DEFERRABLES-ON-ENABLING-INTERRUPTS-P*).

- Thread interruption run wrapped in a (WITHOUT-INTERRUPTS
  (ALLOW-WITH-INTERRUPTS ...)).

- Repeating timers reschedule themselves when they finished to the
  current expiry time + repeat interval even if that's in the past.
  Hence, a timer's schedule does not get shifted if it takes a long
  time to run. If it takes more time than the repeat interval then it
  may catch up on later invokations.

- Timers run wrapped in a (WITHOUT-INTERRUPTS (ALLOW-WITH-INTERRUPTS
  ...)) even in run in a new thread.

- Enable previously failing tests.

- Add more tests.

- Automatically unschedule repeating timers if they take up all the
  CPU.


Index: threads.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/threads.impure.lisp,v
retrieving revision 1.64
retrieving revision 1.65
diff -u -d -r1.64 -r1.65
--- threads.impure.lisp	16 Feb 2009 22:05:45 -0000	1.64
+++ threads.impure.lisp	16 Feb 2009 22:16:20 -0000	1.65
@@ -42,8 +42,46 @@
   (with-mutex (mutex)
     mutex))
 
+(sb-alien:define-alien-routine "check_deferrables_blocked_or_lose"
+    void)
+(sb-alien:define-alien-routine "check_deferrables_unblocked_or_lose"
+    void)
+
+(with-test (:name (:interrupt-thread :deferrables-blocked))
+  (sb-thread:interrupt-thread sb-thread:*current-thread*
+                              (lambda ()
+                                (check-deferrables-blocked-or-lose))))
+
+(with-test (:name (:interrupt-thread :deferrables-unblocked))
+  (sb-thread:interrupt-thread sb-thread:*current-thread*
+                              (lambda ()
+                                (with-interrupts
+                                  (check-deferrables-unblocked-or-lose)))))
+
+(with-test (:name (:interrupt-thread :nlx))
+  (catch 'xxx
+    (sb-thread:interrupt-thread sb-thread:*current-thread*
+                                (lambda ()
+                                  (check-deferrables-blocked-or-lose)
+                                  (throw 'xxx nil))))
+  (check-deferrables-unblocked-or-lose))
+
 #-sb-thread (sb-ext:quit :unix-status 104)
 
+(with-test (:name (:interrupt-thread :deferrables-unblocked-by-spinlock))
+  (let ((spinlock (sb-thread::make-spinlock))
+        (thread (sb-thread:make-thread (lambda ()
+                                         (loop (sleep 1))))))
+    (sb-thread::get-spinlock spinlock)
+    (sb-thread:interrupt-thread thread
+                                (lambda ()
+                                  (check-deferrables-blocked-or-lose)
+                                  (sb-thread::get-spinlock spinlock)
+                                  (check-deferrables-unblocked-or-lose)
+                                  (sb-ext:quit)))
+    (sleep 1)
+    (sb-thread::release-spinlock spinlock)))
+
 ;;; compare-and-swap
 
 (defmacro defincf (name accessor &rest args)
@@ -446,6 +484,43 @@
 
 (format t "~&interrupt count test done~%")
 
+(defvar *runningp* nil)
+
+(with-test (:name (:interrupt-thread :no-nesting))
+  (let ((thread (sb-thread:make-thread
+                 (lambda ()
+                   (catch 'xxx
+                     (loop))))))
+    (declare (special runningp))
+    (sleep 0.2)
+    (sb-thread:interrupt-thread thread
+                                (lambda ()
+                                    (let ((*runningp* t))
+                                      (sleep 1))))
+    (sleep 0.2)
+    (sb-thread:interrupt-thread thread
+                                (lambda ()
+                                  (throw 'xxx *runningp*)))
+    (assert (not (sb-thread:join-thread thread)))))
+
+(with-test (:name (:interrupt-thread :nesting))
+  (let ((thread (sb-thread:make-thread
+                 (lambda ()
+                   (catch 'xxx
+                     (loop))))))
+    (declare (special runningp))
+    (sleep 0.2)
+    (sb-thread:interrupt-thread thread
+                                (lambda ()
+                                  (let ((*runningp* t))
+                                    (sb-sys:with-interrupts
+                                      (sleep 1)))))
+    (sleep 0.2)
+    (sb-thread:interrupt-thread thread
+                                (lambda ()
+                                  (throw 'xxx *runningp*)))
+    (assert (sb-thread:join-thread thread))))
+
 (let (a-done b-done)
   (make-thread (lambda ()
                  (dotimes (i 100)
@@ -551,7 +626,10 @@
        (interruptor-thread
         (make-thread (lambda ()
                        (sleep 2)
-                       (interrupt-thread main-thread #'break)
+                       (interrupt-thread main-thread
+                                         (lambda ()
+                                           (with-interrupts
+                                             (break))))
                        (sleep 2)
                        (interrupt-thread main-thread #'continue))
                      :name "interruptor")))

Index: timer.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/timer.impure.lisp,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -d -r1.13 -r1.14
--- timer.impure.lisp	23 Sep 2008 16:07:40 -0000	1.13
+++ timer.impure.lisp	16 Feb 2009 22:16:20 -0000	1.14
@@ -13,6 +13,62 @@
 
 (use-package :test-util)
 
+(sb-alien:define-alien-routine "check_deferrables_blocked_or_lose"
+    void)
+(sb-alien:define-alien-routine "check_deferrables_unblocked_or_lose"
+    void)
+
+(defun make-limited-timer (fn n &rest args)
+  (let (timer)
+    (setq timer
+          (apply #'sb-ext:make-timer
+                 (lambda ()
+                   (sb-sys:without-interrupts
+                     (decf n)
+                     (cond ((minusp n)
+                            (warn "Unscheduling timer ~A ~
+                                   upon reaching run limit. System too slow?"
+                                  timer)
+                            (sb-ext:unschedule-timer timer))
+                           (t
+                            (sb-sys:allow-with-interrupts
+                              (funcall fn))))))
+                 args))))
+
+(defun make-and-schedule-and-wait (fn time)
+  (let ((finishedp nil))
+    (sb-ext:schedule-timer (sb-ext:make-timer
+                            (lambda ()
+                              (sb-sys:without-interrupts
+                                (unwind-protect
+                                     (sb-sys:allow-with-interrupts
+                                       (funcall fn))
+                                  (setq finishedp t)))))
+                           time)
+    (loop until finishedp)))
+
+(with-test (:name (:timer :deferrables-blocked))
+  (make-and-schedule-and-wait (lambda ()
+                                (check-deferrables-blocked-or-lose))
+                              (random 0.1))
+  (check-deferrables-unblocked-or-lose))
+
+(with-test (:name (:timer :deferrables-unblocked))
+  (make-and-schedule-and-wait (lambda ()
+                                (sb-sys:with-interrupts
+                                  (check-deferrables-unblocked-or-lose)))
+                              (random 0.1))
+  (check-deferrables-unblocked-or-lose))
+
+(with-test (:name (:timer :deferrables-unblocked :unwind))
+  (catch 'xxx
+    (make-and-schedule-and-wait (lambda ()
+                                  (check-deferrables-blocked-or-lose)
+                                  (throw 'xxx nil))
+                                (random 0.1))
+    (sleep 1))
+  (check-deferrables-unblocked-or-lose))
+
 (defmacro raises-timeout-p (&body body)
   `(handler-case (progn (progn ,@body) nil)
     (sb-ext:timeout () t)))
@@ -165,9 +221,10 @@
         (loop
            (assert (eq wanted (subtypep type1 type2))))))))
 
-;;; Disabled. Hangs occasionally at least on x86. See comment before
-;;; the next test case.
-#+(and nil sb-thread)
+;;; Used to hang occasionally at least on x86. Two bugs caused it:
+;;; running out of stack (due to repeating timers being rescheduled
+;;; before they ran) and dying threads were open interrupts.
+#+sb-thread
 (with-test (:name (:timer :parallel-unschedule))
   (let ((timer (sb-ext:make-timer (lambda () 42) :name "parallel schedulers"))
         (other nil))
@@ -180,42 +237,42 @@
                        (loop for i from 1 upto 10
                              collect (let* ((thread (sb-thread:make-thread #'flop
                                                                            :name (format nil "scheduler ~A" i)))
-                                            (ticker (sb-ext:make-timer (lambda () 13) :thread (or other thread)
-                                                                       :name (format nil "ticker ~A" i))))
+                                            (ticker (make-limited-timer (lambda () 13)
+                                                                               1000
+                                                                               :thread (or other thread)
+                                                                               :name (format nil "ticker ~A" i))))
                                        (setf other thread)
                                        (sb-ext:schedule-timer ticker 0 :repeat-interval 0.00001)
                                        thread)))))))
 
 ;;;; FIXME: OS X 10.4 doesn't like these being at all, and gives us a SIGSEGV
 ;;;; instead of using the Mach expection system! 10.5 on the other tends to
-;;;; lose() where with interrupt already pending. :/
-;;;;
-;;;; FIXME: This test also occasionally hangs on Linux/x86-64 at least. The
-;;;; common feature is one thread in gc_stop_the_world, and another trying to
-;;;; signal_interrupt_thread, but both (apparently) getting EAGAIN repeatedly.
-;;;; Exactly how or why this is happening remains under investigation -- but
-;;;; it seems plausible that the fast timers simply fill up the interrupt
-;;;; queue completely. (On some occasions the process unwedges itself after
-;;;; a few minutes, but not always.)
+;;;; lose() here with interrupt already pending. :/
 ;;;;
-;;;; FIXME: Another failure mode on Linux: recursive entries to
-;;;; RUN-EXPIRED-TIMERS blowing the stack.
-#+nil
+;;;; Used to have problems in genereal, see comment on (:TIMER
+;;;; :PARALLEL-UNSCHEDULE).
 (with-test (:name (:timer :schedule-stress))
   (flet ((test ()
-           (let* ((slow-timers (loop for i from 1 upto 100
-                                     collect (sb-ext:make-timer (lambda () 13) :name (format nil "slow ~A" i))))
-                  (fast-timer (sb-ext:make-timer (lambda () 42) :name "fast")))
-             (sb-ext:schedule-timer fast-timer 0.0001 :repeat-interval 0.0001)
-             (dolist (timer slow-timers)
-               (sb-ext:schedule-timer timer (random 0.1) :repeat-interval (random 0.1)))
-             (dolist (timer slow-timers)
-               (sb-ext:unschedule-timer timer))
-             (sb-ext:unschedule-timer fast-timer))))
-    #+sb-thread
-    (mapcar #'sb-thread:join-thread (loop repeat 10 collect (sb-thread:make-thread #'test)))
-    #-sb-thread
-    (loop repeat 10 do (test))))
+         (let* ((slow-timers
+                 (loop for i from 1 upto 1
+                       collect (make-limited-timer
+                                (lambda () 13)
+                                1000
+                                :name (format nil "slow ~A" i))))
+                (fast-timer (make-limited-timer (lambda () 42) 1000
+                                                :name "fast")))
+           (sb-ext:schedule-timer fast-timer 0.0001 :repeat-interval 0.0001)
+           (dolist (timer slow-timers)
+             (sb-ext:schedule-timer timer (random 0.1)
+                                    :repeat-interval (random 0.1)))
+           (dolist (timer slow-timers)
+             (sb-ext:unschedule-timer timer))
+           (sb-ext:unschedule-timer fast-timer))))
+  #+sb-thread
+  (mapcar #'sb-thread:join-thread
+          (loop repeat 10 collect (sb-thread:make-thread #'test)))
+  #-sb-thread
+  (loop repeat 10 do (test))))
 
 #+sb-thread
 (with-test (:name (:timer :threaded-stress))