From 85e71404cf7ddc58fb85cb043155a4e9896e4d3e Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 30 Sep 2010 08:39:39 +0000 Subject: [PATCH] 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. --- NEWS | 2 ++ src/code/timer.lisp | 35 +++++++++++++++++++---------------- tests/timer.impure.lisp | 11 ++++++++++- version.lisp-expr | 2 +- 4 files changed, 32 insertions(+), 18 deletions(-) diff --git a/NEWS b/NEWS index f4edd25..7642148 100644 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4