1.0.43.11: smarter timer expiry

 When expiring timers, run all expired timers instead of setting the
 system timer again after expiring a single one.

 Hopefully addresses lp#375515.

diff --git a/NEWS b/NEWS
index f4edd25..7642148 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -13,6 +13,8 @@ changes relative to sbcl-1.0.43:
   * bug fix: interrupts arriving due to CL:OPEN caused an error.
   * bug fix: overeager character buffering could cause input to block
     spuriously when reading from a pipe (lp#643686)
+  * bug fix: more efficient timer expiry should avoid starvation on systems
+    where number of SIGALRMs per second is restricted. (lp#375515)
 
 changes in sbcl-1.0.43 relative to sbcl-1.0.42:
   * incompatible change: FD-STREAMS no longer participate in the serve-event

diff --git a/src/code/timer.lisp b/src/code/timer.lisp
index 065b4c2..381e363 100644 (file)
--- a/src/code/timer.lisp
+++ b/src/code/timer.lisp
@@ -355,23 +355,26 @@ triggers."
               (warn "Timer ~S failed to interrupt thread ~S."
                     timer thread)))))))
 
-;;; Called from the signal handler.
+;;; Called from the signal handler. We loop until all the expired timers
+;;; have been run.
 (defun run-expired-timers ()
-  (let (timer)
-    (with-scheduler-lock ()
-      (setq timer (peek-schedule))
-      (when (or (null timer)
-                (< (get-internal-real-time)
-                   (%timer-expire-time timer)))
-        ;; Seemingly this is a spurious SIGALRM, but play it safe and
-        ;; reset the system timer because if the system clock was set
-        ;; back after the SIGALRM had been delivered then we won't get
-        ;; another chance.
-        (set-system-timer)
-        (return-from run-expired-timers nil))
-      (assert (eq timer (priority-queue-extract-maximum *schedule*)))
-      (set-system-timer))
-    (run-timer timer)))
+  (loop
+    (let ((now (get-internal-real-time))
+          (timers nil))
+      (flet ((run-timers ()
+               (dolist (timer (nreverse timers))
+                 (run-timer timer))))
+        (with-scheduler-lock ()
+          (loop for timer = (peek-schedule)
+                when (or (null timer) (< now (%timer-expire-time timer)))
+                ;; No more timers to run for now, reset the system timer.
+                do (run-timers)
+                   (set-system-timer)
+                   (return-from run-expired-timers nil)
+                else
+                do (assert (eq timer (priority-queue-extract-maximum *schedule*)))
+                   (push timer timers)))
+        (run-timers)))))
 
 (defun timeout-cerror ()
   (cerror "Continue" 'sb!ext::timeout))

diff --git a/tests/timer.impure.lisp b/tests/timer.impure.lisp
index 9886cb5..41ba421 100644 (file)
--- a/tests/timer.impure.lisp
+++ b/tests/timer.impure.lisp
@@ -158,7 +158,16 @@
 (with-test (:name (:timer :stress))
   (let ((time (1+ (get-universal-time))))
     (loop repeat 200 do
-          (schedule-timer (make-timer (lambda ())) time :absolute-p t))
+             (schedule-timer (make-timer (lambda ())) time :absolute-p t))
+    (sleep 2)
+    (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
+
+(with-test (:name (:timer :stress2))
+  (let ((time (1+ (get-universal-time)))
+        (n 0))
+    (loop for time-n from time upto (+ 1/10 time) by (/ 1/10 200)
+          do (schedule-timer (make-timer (lambda ())) time-n :absolute-p t)
+             (incf n))
     (sleep 2)
     (assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
 

diff --git a/version.lisp-expr b/version.lisp-expr
index 20b341a..b481407 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.43.10"
+"1.0.43.11"