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