(defun make-timer (function &key name (thread sb!thread:*current-thread*))
#!+sb-doc
- "Create a timer object that's when scheduled runs FUNCTION. If
-THREAD is a thread then that thread is to be interrupted with
-FUNCTION. If THREAD is T then a new thread is created each timer
-FUNCTION is run. If THREAD is NIL then FUNCTION can be run in any
-thread. When THREAD is not T, INTERRUPT-THREAD is used to run FUNCTION
-and the ordering guarantees of INTERRUPT-THREAD also apply here.
-FUNCTION always runs with interrupts disabled but WITH-INTERRUPTS is
-allowed."
+ "Create a timer that runs FUNCTION when triggered.
+
+If a THREAD is supplied, FUNCTION is run in that thread. If THREAD is
+T, a new thread is created for FUNCTION each time the timer is
+triggered. If THREAD is NIL, FUNCTION is run in an unspecified thread.
+
+When THREAD is not T, INTERRUPT-THREAD is used to run FUNCTION and the
+ordering guarantees of INTERRUPT-THREAD apply. FUNCTION runs with
+interrupts disabled but WITH-INTERRUPTS is allowed."
(%make-timer :name name :function function :thread thread))
(defun timer-name (timer)
(setf (%timer-expire-time timer) nil
(%timer-repeat-interval timer) nil)
(let ((old-position (priority-queue-remove *schedule* timer)))
+ ;; Don't use cancel-function as the %timer-cancel-function
+ ;; may have changed before we got the scheduler lock.
(when old-position
(funcall (%timer-cancel-function timer)))
(when (eql 0 old-position)
(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))