io-multiplex/scheduler.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
   2 ;;;
   3 ;;; scheduler.lisp --- Controlling the queue of scheduled events
   4 ;;;                    and running expired timers.
   5 ;;;
   6 ;;; Copyright (C) 2003 Zach Beane <xach@xach.com>
   7 ;;;
   8 ;;; Permission is hereby granted, free of charge, to any person obtaining
   9 ;;; a copy of this software and associated documentation files (the
  10 ;;; "Software"), to deal in the Software without restriction, including
  11 ;;; without limitation the rights to use, copy, modify, merge,publish,
  12 ;;; distribute, sublicense, and/or sell copies of the Software, and to
  13 ;;; permit persons to whom the Software is furnished to do so, subject to
  14 ;;; the following conditions:
  15 ;;;
  16 ;;; The above copyright notice and this permission notice shall be
  17 ;;; included in all copies or substantial portions of the Software.
  18 ;;;
  19 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  20 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  21 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  22 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
  23 ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
  24 ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
  25 ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  26
  27 (in-package :io.multiplex)
  28
  29 ;;;
  30 ;;; Public interface
  31 ;;;
  32
  33 (defun schedule-timer (schedule timer)
  34   (priority-queue-insert schedule timer)
  35   (values timer))
  36
  37 (defun unschedule-timer (schedule timer)
  38   (priority-queue-remove schedule timer)
  39   (values timer))
  40
  41 (defun reschedule-timer (schedule timer)
  42   (incf (%timer-expire-time timer) (%timer-relative-time timer))
  43   (priority-queue-insert schedule timer))
  44
  45 (defun reschedule-timer-relative-to-now (timer now)
  46   (setf (%timer-expire-time timer)
  47         (+ now (%timer-relative-time timer))))
  48 \f
  49 ;;;
  50 ;;; The scheduler
  51 ;;;
  52
  53 (defun peek-schedule (schedule)
  54   (priority-queue-minimum schedule))
  55
  56 (defun time-to-next-timer (schedule)
  57   (let ((timer (peek-schedule schedule)))
  58     (and timer (%timer-expire-time timer))))
  59 \f
  60 ;;;
  61 ;;; Expiring timers
  62 ;;;
  63
  64 (defun dispatch-timer (timer)
  65   (funcall (%timer-function timer)))
  66
  67 (defun timer-reschedulable-p (timer)
  68   (symbol-macrolet ((relative-time (%timer-relative-time timer))
  69                     (one-shot (%timer-one-shot timer)))
  70     (and relative-time (not one-shot))))
  71
  72 (defun expire-pending-timers (schedule now)
  73   (let ((expired-p nil)
  74         (timers-to-reschedule ()))
  75     (flet ((handle-expired-timer (timer)
  76              (when (timer-reschedulable-p timer)
  77                (push timer timers-to-reschedule))
  78              (dispatch-timer timer))
  79            (%return ()
  80              (dolist (timer timers-to-reschedule)
  81                (reschedule-timer schedule timer))
  82              (return-from expire-pending-timers expired-p)))
  83       (loop
  84          (let ((next-timer (peek-schedule schedule)))
  85            (unless next-timer (%return))
  86            (cond ((timer-expired-p next-timer now)
  87                   (setf expired-p t)
  88                   (handle-expired-timer (priority-queue-extract-minimum schedule)))
  89                  (t
  90                   (%return))))))))