src/code/timer.lisp

   1 ;;;; a timer facility based heavily on the timer package by Zach Beane
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!IMPL")
  13
  14 ;;; Heap (for the priority queue)
  15
  16 (declaim (inline heap-parent heap-left heap-right))
  17
  18 (defun heap-parent (i)
  19   (ash i -1))
  20
  21 (defun heap-left (i)
  22   (1+ (ash i 1)))
  23
  24 (defun heap-right (i)
  25   (+ 2 (ash i 1)))
  26
  27 (defun heapify (heap start &key (key #'identity) (test #'>=))
  28   (declare (function key test))
  29   (flet ((key (obj) (funcall key obj))
  30          (ge (i j) (funcall test i j)))
  31     (let ((l (heap-left start))
  32           (r (heap-right start))
  33           (size (length heap))
  34           largest)
  35       (setf largest (if (and (< l size)
  36                              (not (ge (key (aref heap start))
  37                                       (key (aref heap l)))))
  38                         l
  39                         start))
  40       (when (and (< r size)
  41                  (not (ge (key (aref heap largest))
  42                           (key (aref heap r)))))
  43         (setf largest r))
  44       (when (/= largest start)
  45         (rotatef (aref heap largest) (aref heap start))
  46         (heapify heap largest :key key :test test)))
  47     heap))
  48
  49 (defun heap-insert (heap new-item &key (key #'identity) (test #'>=))
  50   (declare (function key test))
  51   (flet ((key (obj) (funcall key obj))
  52          (ge (i j) (funcall test i j)))
  53     (vector-push-extend nil heap)
  54     (loop for i = (1- (length heap)) then parent-i
  55           for parent-i = (heap-parent i)
  56           while (and (> i 0)
  57                      (not (ge (key (aref heap parent-i))
  58                               (key new-item))))
  59           do (setf (aref heap i) (aref heap parent-i))
  60           finally (setf (aref heap i) new-item)
  61           (return-from heap-insert i))))
  62
  63 (defun heap-maximum (heap)
  64   (unless (zerop (length heap))
  65     (aref heap 0)))
  66
  67 (defun heap-extract (heap i &key (key #'identity) (test #'>=))
  68   (when (< (length heap) i)
  69     (error "Heap underflow"))
  70   (prog1
  71       (aref heap i)
  72     (setf (aref heap i) (aref heap (1- (length heap))))
  73     (decf (fill-pointer heap))
  74     (heapify heap i :key key :test test)))
  75
  76 (defun heap-extract-maximum (heap &key (key #'identity) (test #'>=))
  77   (heap-extract heap 0 :key key :test test))
  78
  79 ;;; Priority queue
  80
  81 (defstruct (priority-queue
  82              (:conc-name %pqueue-)
  83              (:constructor %make-priority-queue))
  84   contents
  85   keyfun)
  86
  87 (defun make-priority-queue (&key (key #'identity) (element-type t))
  88   (let ((contents (make-array 100
  89                               :adjustable t
  90                               :fill-pointer 0
  91                               :element-type element-type)))
  92     (%make-priority-queue :keyfun key
  93                           :contents contents)))
  94
  95 (def!method print-object ((object priority-queue) stream)
  96   (print-unreadable-object (object stream :type t :identity t)
  97     (format stream "~[empty~:;~:*~D item~:P~]"
  98             (length (%pqueue-contents object)))))
  99
 100 (defun priority-queue-maximum (priority-queue)
 101   "Return the item in PRIORITY-QUEUE with the largest key."
 102   (symbol-macrolet ((contents (%pqueue-contents priority-queue)))
 103     (unless (zerop (length contents))
 104       (heap-maximum contents))))
 105
 106 (defun priority-queue-extract-maximum (priority-queue)
 107   "Remove and return the item in PRIORITY-QUEUE with the largest key."
 108   (symbol-macrolet ((contents (%pqueue-contents priority-queue))
 109                     (keyfun (%pqueue-keyfun priority-queue)))
 110     (unless (zerop (length contents))
 111       (heap-extract-maximum contents :key keyfun :test #'<=))))
 112
 113 (defun priority-queue-insert (priority-queue new-item)
 114   "Add NEW-ITEM to PRIOIRITY-QUEUE."
 115   (symbol-macrolet ((contents (%pqueue-contents priority-queue))
 116                     (keyfun (%pqueue-keyfun priority-queue)))
 117     (heap-insert contents new-item :key keyfun :test #'<=)))
 118
 119 (defun priority-queue-empty-p (priority-queue)
 120   (zerop (length (%pqueue-contents priority-queue))))
 121
 122 (defun priority-queue-remove (priority-queue item &key (test #'eq))
 123   "Remove and return ITEM from PRIORITY-QUEUE."
 124   (symbol-macrolet ((contents (%pqueue-contents priority-queue))
 125                     (keyfun (%pqueue-keyfun priority-queue)))
 126     (let ((i (position item contents :test test)))
 127       (when i
 128         (heap-extract contents i :key keyfun :test #'<=)
 129         i))))
 130
 131 ;;; thread utility
 132
 133 (defun make-cancellable-interruptor (function)
 134   ;; return a list of two functions: one that does the same as
 135   ;; FUNCTION until the other is called, from when it does nothing.
 136   (let ((mutex (sb!thread:make-mutex))
 137         (cancelled-p nil))
 138     #!-sb-thread
 139     (declare (ignore mutex))
 140     (list
 141      #'(lambda ()
 142          (sb!thread:with-recursive-lock (mutex)
 143            (unless cancelled-p
 144              (funcall function))))
 145      #'(lambda ()
 146          (sb!thread:with-recursive-lock (mutex)
 147            (setq cancelled-p t))))))
 148
 149 ;;; timers
 150
 151 (defstruct (timer
 152              (:conc-name %timer-)
 153              (:constructor %make-timer))
 154   #!+sb-doc
 155   "Timer type. Do not rely on timers being structs as it may change in
 156 future versions."
 157   name
 158   function
 159   expire-time
 160   repeat-interval
 161   (thread nil :type (or sb!thread:thread (member t nil)))
 162   interrupt-function
 163   cancel-function)
 164
 165 (def!method print-object ((timer timer) stream)
 166   (let ((name (%timer-name timer)))
 167     (if name
 168         (print-unreadable-object (timer stream :type t :identity t)
 169           (prin1 name stream))
 170         (print-unreadable-object (timer stream :type t :identity t)
 171           ;; body is empty => there is only one space between type and
 172           ;; identity
 173           ))))
 174
 175 (defun make-timer (function &key name (thread sb!thread:*current-thread*))
 176   #!+sb-doc
 177   "Create a timer object that's when scheduled runs FUNCTION. If
 178 THREAD is a thread then that thread is to be interrupted with
 179 FUNCTION. If THREAD is T then a new thread is created each timer
 180 FUNCTION is run. If THREAD is NIL then FUNCTION can be run in any
 181 thread."
 182   (%make-timer :name name :function function :thread thread))
 183
 184 (defun timer-name (timer)
 185   #!+sb-doc
 186   "Return the name of TIMER."
 187   (%timer-name timer))
 188
 189 (defun timer-scheduled-p (timer &key (delta 0))
 190   #!+sb-doc
 191   "See if TIMER will still need to be triggered after DELTA seconds
 192 from now. For timers with a repeat interval it returns true."
 193   (symbol-macrolet ((expire-time (%timer-expire-time timer))
 194                     (repeat-interval (%timer-repeat-interval timer)))
 195       (or (and repeat-interval (plusp repeat-interval))
 196           (and expire-time
 197                (<= (+ (get-internal-real-time) delta)
 198                    expire-time)))))
 199
 200 ;;; The scheduler
 201
 202 (defvar *scheduler-lock* (sb!thread:make-mutex :name "Scheduler lock"))
 203
 204 (defmacro with-scheduler-lock ((&optional) &body body)
 205   ;; don't let the SIGALRM handler mess things up
 206   `(sb!sys:without-interrupts
 207     (sb!thread:with-mutex (*scheduler-lock*)
 208       ,@body)))
 209
 210 (defun under-scheduler-lock-p ()
 211   #!-sb-thread
 212   t
 213   #!+sb-thread
 214   (eq sb!thread:*current-thread* (sb!thread:mutex-value *scheduler-lock*)))
 215
 216 (defparameter *schedule* (make-priority-queue :key #'%timer-expire-time))
 217
 218 (defun peek-schedule ()
 219   (priority-queue-maximum *schedule*))
 220
 221 (defun time-left (timer)
 222   (- (%timer-expire-time timer) (get-internal-real-time)))
 223
 224 ;;; real time conversion
 225
 226 (defun delta->real (delta)
 227   (floor (* delta internal-time-units-per-second)))
 228
 229 ;;; Public interface
 230
 231 (defun %schedule-timer (timer)
 232   (let ((changed-p nil)
 233         (old-position (priority-queue-remove *schedule* timer)))
 234     ;; Make sure interruptors are cancelled even if this timer was
 235     ;; scheduled again since our last attempt.
 236     (when old-position
 237       (funcall (%timer-cancel-function timer)))
 238     (when (eql 0 old-position)
 239       (setq changed-p t))
 240     (when (zerop (priority-queue-insert *schedule* timer))
 241       (setq changed-p t))
 242     (setf (values (%timer-interrupt-function timer)
 243                   (%timer-cancel-function timer))
 244           (values-list (make-cancellable-interruptor
 245                         (%timer-function timer))))
 246     (when changed-p
 247       (set-system-timer)))
 248   (values))
 249
 250 (defun schedule-timer (timer time &key repeat-interval absolute-p)
 251   #!+sb-doc
 252   "Schedule TIMER to be triggered at TIME. If ABSOLUTE-P then TIME is
 253 universal time, but non-integral values are also allowed, else TIME is
 254 measured as the number of seconds from the current time. If
 255 REPEAT-INTERVAL is given, TIMER is automatically rescheduled upon
 256 expiry."
 257   ;; CANCEL-FUNCTION may block until all interruptors finish, let's
 258   ;; try to cancel without the scheduler lock first.
 259   (when (%timer-cancel-function timer)
 260     (funcall (%timer-cancel-function timer)))
 261   (with-scheduler-lock ()
 262     (setf (%timer-expire-time timer) (+ (get-internal-real-time)
 263                                         (delta->real
 264                                          (if absolute-p
 265                                              (- time (get-universal-time))
 266                                              time)))
 267           (%timer-repeat-interval timer) (if repeat-interval
 268                                              (delta->real repeat-interval)
 269                                              nil))
 270     (%schedule-timer timer)))
 271
 272 (defun unschedule-timer (timer)
 273   #!+sb-doc
 274   "Cancel TIMER. Once this function returns it is guaranteed that
 275 TIMER shall not be triggered again and there are no unfinished
 276 triggers."
 277   (let ((cancel-function (%timer-cancel-function timer)))
 278     (when cancel-function
 279       (funcall cancel-function)))
 280   (with-scheduler-lock ()
 281     (setf (%timer-expire-time timer) nil
 282           (%timer-repeat-interval timer) nil)
 283     (let ((old-position (priority-queue-remove *schedule* timer)))
 284       (when old-position
 285         (funcall (%timer-cancel-function timer)))
 286       (when (eql 0 old-position)
 287         (set-system-timer))))
 288   (values))
 289
 290 (defun list-all-timers ()
 291   #!+sb-doc
 292   "Return a list of all timers in the system."
 293   (with-scheduler-lock ()
 294     (concatenate 'list (%pqueue-contents *schedule*))))
 295
 296 ;;; Not public, but related
 297
 298 (defun reschedule-timer (timer)
 299   (with-scheduler-lock ()
 300     (setf (%timer-expire-time timer) (+ (get-internal-real-time)
 301                                         (%timer-repeat-interval timer)))
 302     (%schedule-timer timer)))
 303
 304 ;;; Expiring timers
 305
 306 (defun real-time->sec-and-usec(time)
 307   (if (minusp time)
 308       (list 0 1)
 309       (multiple-value-bind (s u) (floor time internal-time-units-per-second)
 310         (setf u (floor (* (/ u internal-time-units-per-second) 1000000)))
 311         (if (= 0 s u)
 312             ;; 0 0 means "shut down the timer" for setitimer
 313             (list 0 1)
 314             (list s u)))))
 315
 316 (defun set-system-timer ()
 317   (assert (under-scheduler-lock-p))
 318   (let ((next-timer (peek-schedule)))
 319     (if next-timer
 320         (let ((delta (- (%timer-expire-time next-timer)
 321                         (get-internal-real-time))))
 322           (apply #'sb!unix:unix-setitimer
 323                  :real 0 0 (real-time->sec-and-usec delta)))
 324         (sb!unix:unix-setitimer :real 0 0 0 0))))
 325
 326 (defun run-timer (timer)
 327   (symbol-macrolet ((function (%timer-function timer))
 328                     (repeat-interval (%timer-repeat-interval timer))
 329                     (thread (%timer-thread timer)))
 330     (when repeat-interval
 331       (reschedule-timer timer))
 332     (cond ((null thread)
 333            (funcall function))
 334           ((eq t thread)
 335            (sb!thread:make-thread function))
 336           (t
 337            (handler-case
 338                (sb!thread:interrupt-thread thread function)
 339              (sb!thread:interrupt-thread-error (c)
 340                (warn c)))))))
 341
 342 ;; Called from the signal handler.
 343 (defun run-expired-timers ()
 344   (unwind-protect
 345        (with-interrupts
 346          (let (timer)
 347            (loop
 348             (with-scheduler-lock ()
 349               (setq timer (peek-schedule))
 350               (unless (and timer
 351                            (> (get-internal-real-time)
 352                               (%timer-expire-time timer)))
 353                 (return-from run-expired-timers nil))
 354               (assert (eq timer (priority-queue-extract-maximum *schedule*))))
 355             ;; run the timer without the lock
 356             (run-timer timer))))
 357     (with-scheduler-lock ()
 358       (set-system-timer))))
 359
 360 (defmacro sb!ext:with-timeout (expires &body body)
 361   #!+sb-doc
 362   "Execute the body, asynchronously interrupting it and signalling a
 363 TIMEOUT condition after at least EXPIRES seconds have passed."
 364   (with-unique-names (timer)
 365     ;; FIXME: a temporary compatibility workaround for CLX, if unsafe
 366     ;; unwinds are handled revisit it.
 367     `(if (> ,expires 0)
 368          (let ((,timer (make-timer (lambda ()
 369                                      (cerror "Continue" 'sb!ext::timeout)))))
 370            (schedule-timer ,timer ,expires)
 371            (unwind-protect
 372                 (progn ,@body)
 373              (unschedule-timer ,timer)))
 374          (progn ,@body))))