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                (declare (ignore c))
 341                (warn "Timer ~S failed to interrupt thread ~S."
 342                      timer thread)))))))
 343
 344 ;; Called from the signal handler.
 345 (defun run-expired-timers ()
 346   (unwind-protect
 347        (with-interrupts
 348          (let (timer)
 349            (loop
 350             (with-scheduler-lock ()
 351               (setq timer (peek-schedule))
 352               (unless (and timer
 353                            (> (get-internal-real-time)
 354                               (%timer-expire-time timer)))
 355                 (return-from run-expired-timers nil))
 356               (assert (eq timer (priority-queue-extract-maximum *schedule*))))
 357             ;; run the timer without the lock
 358             (run-timer timer))))
 359     (with-scheduler-lock ()
 360       (set-system-timer))))
 361
 362 (defmacro sb!ext:with-timeout (expires &body body)
 363   #!+sb-doc
 364   "Execute the body, asynchronously interrupting it and signalling a TIMEOUT
 365 condition after at least EXPIRES seconds have passed.
 366
 367 Note that it is never safe to unwind from an asynchronous condition. Consider:
 368
 369   (defun call-with-foo (function)
 370     (let (foo)
 371       (unwind-protect
 372          (progn
 373            (setf foo (get-foo))
 374            (funcall function foo))
 375        (when foo
 376          (release-foo foo)))))
 377
 378 If TIMEOUT occurs after GET-FOO has executed, but before the assignment, then
 379 RELEASE-FOO will be missed. While individual sites like this can be made proof
 380 against asynchronous unwinds, this doesn't solve the fundamental issue, as all
 381 the frames potentially unwound through need to be proofed, which includes both
 382 system and application code -- and in essence proofing everything will make
 383 the system uninterruptible."
 384   (with-unique-names (timer)
 385     ;; FIXME: a temporary compatibility workaround for CLX, if unsafe
 386     ;; unwinds are handled revisit it.
 387     `(if (> ,expires 0)
 388          (let ((,timer (make-timer (lambda ()
 389                                      (cerror "Continue" 'sb!ext::timeout)))))
 390            (schedule-timer ,timer ,expires)
 391            (unwind-protect
 392                 (progn ,@body)
 393              (unschedule-timer ,timer)))
 394          (progn ,@body))))