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 (1- 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   (unless (> (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 ;;; timers
 132
 133 (defstruct (timer
 134              (:conc-name %timer-)
 135              (:constructor %make-timer))
 136   #!+sb-doc
 137   "Timer type. Do not rely on timers being structs as it may change in
 138 future versions."
 139   name
 140   function
 141   expire-time
 142   repeat-interval
 143   (thread nil :type (or sb!thread:thread (member t nil)))
 144   interrupt-function
 145   cancel-function)
 146
 147 (def!method print-object ((timer timer) stream)
 148   (let ((name (%timer-name timer)))
 149     (if name
 150         (print-unreadable-object (timer stream :type t :identity t)
 151           (prin1 name stream))
 152         (print-unreadable-object (timer stream :type t :identity t)
 153           ;; body is empty => there is only one space between type and
 154           ;; identity
 155           ))))
 156
 157 (defun make-timer (function &key name (thread sb!thread:*current-thread*))
 158   #!+sb-doc
 159   "Create a timer object that's when scheduled runs FUNCTION. If
 160 THREAD is a thread then that thread is to be interrupted with
 161 FUNCTION. If THREAD is T then a new thread is created each timer
 162 FUNCTION is run. If THREAD is NIL then FUNCTION can be run in any
 163 thread. When THREAD is not T, INTERRUPT-THREAD is used to run FUNCTION
 164 and the ordering guarantees of INTERRUPT-THREAD also apply here.
 165 FUNCTION always runs with interrupts disabled but WITH-INTERRUPTS is
 166 allowed."
 167   (%make-timer :name name :function function :thread thread))
 168
 169 (defun timer-name (timer)
 170   #!+sb-doc
 171   "Return the name of TIMER."
 172   (%timer-name timer))
 173
 174 (defun timer-scheduled-p (timer &key (delta 0))
 175   #!+sb-doc
 176   "See if TIMER will still need to be triggered after DELTA seconds
 177 from now. For timers with a repeat interval it returns true."
 178   (symbol-macrolet ((expire-time (%timer-expire-time timer))
 179                     (repeat-interval (%timer-repeat-interval timer)))
 180       (or (and repeat-interval (plusp repeat-interval))
 181           (and expire-time
 182                (<= (+ (get-internal-real-time) delta)
 183                    expire-time)))))
 184
 185 ;;; The scheduler
 186
 187 (defvar *scheduler-lock* (sb!thread:make-mutex :name "Scheduler lock"))
 188
 189 (defmacro with-scheduler-lock ((&optional) &body body)
 190   ;; Don't let the SIGALRM handler mess things up.
 191   `(sb!thread::with-system-mutex (*scheduler-lock*)
 192      ,@body))
 193
 194 (defun under-scheduler-lock-p ()
 195   (sb!thread:holding-mutex-p *scheduler-lock*))
 196
 197 (defparameter *schedule* (make-priority-queue :key #'%timer-expire-time))
 198
 199 (defun peek-schedule ()
 200   (priority-queue-maximum *schedule*))
 201
 202 (defun time-left (timer)
 203   (- (%timer-expire-time timer) (get-internal-real-time)))
 204
 205 ;;; real time conversion
 206
 207 (defun delta->real (delta)
 208   (floor (* delta internal-time-units-per-second)))
 209
 210 ;;; Public interface
 211
 212 (defun make-cancellable-interruptor (timer)
 213   ;; return a list of two functions: one that does the same as
 214   ;; FUNCTION until the other is called, from when it does nothing.
 215   (let ((mutex (sb!thread:make-mutex))
 216         (cancelledp nil)
 217         (function (if (%timer-repeat-interval timer)
 218                       (lambda ()
 219                         (unwind-protect
 220                              (funcall (%timer-function timer))
 221                           (reschedule-timer timer)))
 222                       (%timer-function timer))))
 223     (list
 224      (lambda ()
 225        ;; Use WITHOUT-INTERRUPTS for the acquiring lock to avoid
 226        ;; unblocking deferrables unless it's inevitable.
 227        (without-interrupts
 228          (sb!thread:with-recursive-lock (mutex)
 229            (unless cancelledp
 230              (allow-with-interrupts
 231                (funcall function))))))
 232      (lambda ()
 233        (sb!thread:with-recursive-lock (mutex)
 234          (setq cancelledp t))))))
 235
 236 (defun %schedule-timer (timer)
 237   (let ((changed-p nil)
 238         (old-position (priority-queue-remove *schedule* timer)))
 239     ;; Make sure interruptors are cancelled even if this timer was
 240     ;; scheduled again since our last attempt.
 241     (when old-position
 242       (funcall (%timer-cancel-function timer)))
 243     (when (eql 0 old-position)
 244       (setq changed-p t))
 245     (when (zerop (priority-queue-insert *schedule* timer))
 246       (setq changed-p t))
 247     (setf (values (%timer-interrupt-function timer)
 248                   (%timer-cancel-function timer))
 249           (values-list (make-cancellable-interruptor timer)))
 250     (when changed-p
 251       (set-system-timer)))
 252   (values))
 253
 254 (defun schedule-timer (timer time &key repeat-interval absolute-p)
 255   #!+sb-doc
 256   "Schedule TIMER to be triggered at TIME. If ABSOLUTE-P then TIME is
 257 universal time, but non-integral values are also allowed, else TIME is
 258 measured as the number of seconds from the current time. If
 259 REPEAT-INTERVAL is given, TIMER is automatically rescheduled upon
 260 expiry."
 261   ;; CANCEL-FUNCTION may block until all interruptors finish, let's
 262   ;; try to cancel without the scheduler lock first.
 263   (when (%timer-cancel-function timer)
 264     (funcall (%timer-cancel-function timer)))
 265   (with-scheduler-lock ()
 266     (setf (%timer-expire-time timer) (+ (get-internal-real-time)
 267                                         (delta->real
 268                                          (if absolute-p
 269                                              (- time (get-universal-time))
 270                                              time)))
 271           (%timer-repeat-interval timer) (if repeat-interval
 272                                              (delta->real repeat-interval)
 273                                              nil))
 274     (%schedule-timer timer)))
 275
 276 (defun unschedule-timer (timer)
 277   #!+sb-doc
 278   "Cancel TIMER. Once this function returns it is guaranteed that
 279 TIMER shall not be triggered again and there are no unfinished
 280 triggers."
 281   (let ((cancel-function (%timer-cancel-function timer)))
 282     (when cancel-function
 283       (funcall cancel-function)))
 284   (with-scheduler-lock ()
 285     (setf (%timer-expire-time timer) nil
 286           (%timer-repeat-interval timer) nil)
 287     (let ((old-position (priority-queue-remove *schedule* timer)))
 288       (when old-position
 289         (funcall (%timer-cancel-function timer)))
 290       (when (eql 0 old-position)
 291         (set-system-timer))))
 292   (values))
 293
 294 (defun list-all-timers ()
 295   #!+sb-doc
 296   "Return a list of all timers in the system."
 297   (with-scheduler-lock ()
 298     (concatenate 'list (%pqueue-contents *schedule*))))
 299
 300 ;;; Not public, but related
 301
 302 (defun reschedule-timer (timer)
 303   ;; unless unscheduled
 304   (when (%timer-expire-time timer)
 305     (let ((thread (%timer-thread timer)))
 306       (if (and (sb!thread::thread-p thread)
 307                (not (sb!thread:thread-alive-p thread)))
 308           (unschedule-timer timer)
 309           (with-scheduler-lock ()
 310             ;; Schedule at regular intervals. If TIMER has not finished
 311             ;; in time then it may catch up later.
 312             (incf (%timer-expire-time timer) (%timer-repeat-interval timer))
 313             (%schedule-timer timer))))))
 314
 315 ;;; Expiring timers
 316
 317 (defun real-time->sec-and-usec (time)
 318   ;; KLUDGE: Always leave 0.0001 second for other stuff in order to
 319   ;; avoid starvation.
 320   (let ((min-usec 100))
 321     (if (minusp time)
 322         (list 0 min-usec)
 323         (multiple-value-bind (s u) (floor time internal-time-units-per-second)
 324           (setf u (floor (* (/ u internal-time-units-per-second) 1000000)))
 325           (if (and (= 0 s) (< u min-usec))
 326               ;; 0 0 means "shut down the timer" for setitimer
 327               (list 0 min-usec)
 328               (list s u))))))
 329
 330 (defun set-system-timer ()
 331   (assert (under-scheduler-lock-p))
 332   (assert (not *interrupts-enabled*))
 333   (let ((next-timer (peek-schedule)))
 334     (if next-timer
 335         (let ((delta (- (%timer-expire-time next-timer)
 336                         (get-internal-real-time))))
 337           (apply #'sb!unix:unix-setitimer
 338                  :real 0 0 (real-time->sec-and-usec delta)))
 339         (sb!unix:unix-setitimer :real 0 0 0 0))))
 340
 341 (defun run-timer (timer)
 342   (let ((function (%timer-interrupt-function timer))
 343         (thread (%timer-thread timer)))
 344     (if (eq t thread)
 345         (sb!thread:make-thread (without-interrupts
 346                                  (allow-with-interrupts
 347                                    function))
 348                                :name (format nil "Timer ~A"
 349                                              (%timer-name timer)))
 350         (let ((thread (or thread sb!thread:*current-thread*)))
 351           (handler-case
 352               (sb!thread:interrupt-thread thread function)
 353             (sb!thread:interrupt-thread-error (c)
 354               (declare (ignore c))
 355               (warn "Timer ~S failed to interrupt thread ~S."
 356                     timer thread)))))))
 357
 358 ;;; Called from the signal handler.
 359 (defun run-expired-timers ()
 360   (let (timer)
 361     (with-scheduler-lock ()
 362       (setq timer (peek-schedule))
 363       (when (or (null timer)
 364                 (< (get-internal-real-time)
 365                    (%timer-expire-time timer)))
 366         ;; Seemingly this is a spurious SIGALRM, but play it safe and
 367         ;; reset the system timer because if the system clock was set
 368         ;; back after the SIGALRM had been delivered then we won't get
 369         ;; another chance.
 370         (set-system-timer)
 371         (return-from run-expired-timers nil))
 372       (assert (eq timer (priority-queue-extract-maximum *schedule*)))
 373       (set-system-timer))
 374     (run-timer timer)))
 375
 376 (defun timeout-cerror ()
 377   (cerror "Continue" 'sb!ext::timeout))
 378
 379 (defmacro sb!ext:with-timeout (expires &body body)
 380   #!+sb-doc
 381   "Execute the body, asynchronously interrupting it and signalling a TIMEOUT
 382 condition after at least EXPIRES seconds have passed.
 383
 384 Note that it is never safe to unwind from an asynchronous condition. Consider:
 385
 386   (defun call-with-foo (function)
 387     (let (foo)
 388       (unwind-protect
 389          (progn
 390            (setf foo (get-foo))
 391            (funcall function foo))
 392        (when foo
 393          (release-foo foo)))))
 394
 395 If TIMEOUT occurs after GET-FOO has executed, but before the assignment, then
 396 RELEASE-FOO will be missed. While individual sites like this can be made proof
 397 against asynchronous unwinds, this doesn't solve the fundamental issue, as all
 398 the frames potentially unwound through need to be proofed, which includes both
 399 system and application code -- and in essence proofing everything will make
 400 the system uninterruptible."
 401   `(dx-flet ((timeout-body () ,@body))
 402      (let ((expires ,expires))
 403        ;; FIXME: a temporary compatibility workaround for CLX, if unsafe
 404        ;; unwinds are handled revisit it.
 405        (if (> expires 0)
 406            (let ((timer (make-timer #'timeout-cerror)))
 407              (schedule-timer timer expires)
 408              (unwind-protect (timeout-body)
 409                (unschedule-timer timer)))
 410            (timeout-body)))))