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                (&key ((:key keyfun) #'identity) (element-type t)
  85                 &aux (contents (make-array 100
  86                                            :adjustable t
  87                                            :fill-pointer 0
  88                                            :element-type element-type))))
  89              (:copier nil))
  90   (contents nil :type vector   :read-only t)
  91   (keyfun   nil :type function :read-only t))
  92
  93 (defmethod print-object ((object priority-queue) stream)
  94   (print-unreadable-object (object stream :type t :identity t)
  95     (format stream "~[empty~:;~:*~D item~:P~]"
  96             (length (%pqueue-contents object)))))
  97
  98 (defun priority-queue-maximum (priority-queue)
  99   "Return the item in PRIORITY-QUEUE with the largest key."
 100   (symbol-macrolet ((contents (%pqueue-contents priority-queue)))
 101     (unless (zerop (length contents))
 102       (heap-maximum contents))))
 103
 104 (defun priority-queue-extract-maximum (priority-queue)
 105   "Remove and return the item in PRIORITY-QUEUE with the largest key."
 106   (symbol-macrolet ((contents (%pqueue-contents priority-queue))
 107                     (keyfun (%pqueue-keyfun priority-queue)))
 108     (unless (zerop (length contents))
 109       (heap-extract-maximum contents :key keyfun :test #'<=))))
 110
 111 (defun priority-queue-insert (priority-queue new-item)
 112   "Add NEW-ITEM to PRIORITY-QUEUE."
 113   (symbol-macrolet ((contents (%pqueue-contents priority-queue))
 114                     (keyfun (%pqueue-keyfun priority-queue)))
 115     (heap-insert contents new-item :key keyfun :test #'<=)))
 116
 117 (defun priority-queue-empty-p (priority-queue)
 118   (zerop (length (%pqueue-contents priority-queue))))
 119
 120 (defun priority-queue-remove (priority-queue item &key (test #'eq))
 121   "Remove and return ITEM from PRIORITY-QUEUE."
 122   (symbol-macrolet ((contents (%pqueue-contents priority-queue))
 123                     (keyfun (%pqueue-keyfun priority-queue)))
 124     (let ((i (position item contents :test test)))
 125       (when i
 126         (heap-extract contents i :key keyfun :test #'<=)
 127         i))))
 128
 129 ;;; timers
 130
 131 (defstruct (timer
 132              (:conc-name %timer-)
 133              (:constructor
 134               make-timer
 135               (function &key name (thread sb!thread:*current-thread*)))
 136              (:copier nil))
 137   "Timer type. Do not rely on timers being structs as it may change in
 138 future versions."
 139   (name               nil :read-only t)
 140   (function           nil :read-only t)
 141   (expire-time        1   :type (or null real))
 142   (repeat-interval    nil :type (or null (real 0)))
 143   (catch-up           nil :type boolean)
 144   (thread             nil :type (or sb!thread:thread boolean))
 145   (interrupt-function nil :type (or null function))
 146   (cancel-function    nil :type (or null function)))
 147
 148 (defmethod print-object ((timer timer) stream)
 149   (let ((name (%timer-name timer)))
 150     (if name
 151         (print-unreadable-object (timer stream :type t :identity t)
 152           (prin1 name stream))
 153         (print-unreadable-object (timer stream :type t :identity t)
 154           ;; body is empty => there is only one space between type and
 155           ;; identity
 156           ))))
 157
 158 (setf (fdocumentation 'make-timer 'function)
 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. In that case, FUNCTION
 167 runs with interrupts disabled but WITH-INTERRUPTS is allowed.")
 168
 169 (defun timer-name (timer)
 170   "Return the name of TIMER."
 171   (%timer-name timer))
 172
 173 (defun timer-scheduled-p (timer &key (delta 0))
 174   "See if TIMER will still need to be triggered after DELTA seconds
 175 from now. For timers with a repeat interval it returns true."
 176   (symbol-macrolet ((expire-time (%timer-expire-time timer))
 177                     (repeat-interval (%timer-repeat-interval timer)))
 178     (or (and repeat-interval (plusp repeat-interval))
 179         (and expire-time
 180              (<= (+ (get-internal-real-time) delta)
 181                  expire-time)))))
 182
 183 ;;; The scheduler
 184
 185 (define-load-time-global *scheduler-lock* (sb!thread:make-mutex :name "Scheduler lock"))
 186
 187 (defmacro with-scheduler-lock ((&optional) &body body)
 188   ;; Don't let the SIGALRM handler mess things up.
 189   `(sb!thread::with-system-mutex (*scheduler-lock*)
 190      ,@body))
 191
 192 (defun under-scheduler-lock-p ()
 193   (sb!thread:holding-mutex-p *scheduler-lock*))
 194
 195 (define-load-time-global *schedule* (make-priority-queue :key #'%timer-expire-time))
 196
 197 (defun peek-schedule ()
 198   (priority-queue-maximum *schedule*))
 199
 200 (defun time-left (timer)
 201   (- (%timer-expire-time timer) (get-internal-real-time)))
 202
 203 ;;; real time conversion
 204
 205 (defun delta->real (delta)
 206   (floor (* delta internal-time-units-per-second)))
 207
 208 ;;; Public interface
 209
 210 (defun make-cancellable-interruptor (timer)
 211   ;; return a list of two functions: one that does the same as
 212   ;; FUNCTION until the other is called, from when it does nothing.
 213   (let ((mutex (sb!thread:make-mutex))
 214         (cancelledp nil)
 215         (function (if (%timer-repeat-interval timer)
 216                       (lambda ()
 217                         (unwind-protect
 218                              (funcall (%timer-function timer))
 219                           (reschedule-timer timer)))
 220                       (%timer-function timer))))
 221     (values
 222      (lambda ()
 223        ;; Use WITHOUT-INTERRUPTS for the acquiring lock to avoid
 224        ;; unblocking deferrables unless it's inevitable.
 225        (without-interrupts
 226          (sb!thread:with-recursive-lock (mutex)
 227            (unless cancelledp
 228              (allow-with-interrupts
 229                (funcall function))))))
 230      (lambda ()
 231        (sb!thread:with-recursive-lock (mutex)
 232          (setq cancelledp t))))))
 233
 234 (defun %schedule-timer (timer)
 235   (let ((changed-p nil)
 236         (old-position (priority-queue-remove *schedule* timer)))
 237     ;; Make sure interruptors are cancelled even if this timer was
 238     ;; scheduled again since our last attempt.
 239     (when old-position
 240       (funcall (%timer-cancel-function timer)))
 241     (when (eql 0 old-position)
 242       (setq changed-p t))
 243     (when (zerop (priority-queue-insert *schedule* timer))
 244       (setq changed-p t))
 245     (setf (values (%timer-interrupt-function timer)
 246                   (%timer-cancel-function timer))
 247           (make-cancellable-interruptor timer))
 248     (when changed-p
 249       (set-system-timer)))
 250   (values))
 251
 252 (defun schedule-timer (timer time
 253                        &key
 254                        repeat-interval
 255                        absolute-p
 256                        (catch-up nil catch-up-p))
 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.
 260
 261 If REPEAT-INTERVAL is given, TIMER is automatically rescheduled upon
 262 expiry.
 263
 264 If REPEAT-INTERVAL is non-NIL, the Boolean CATCH-UP controls whether
 265 TIMER will \"catch up\" by repeatedly calling its function without
 266 delay in case calls are missed because of a clock discontinuity such
 267 as a suspend and resume cycle of the computer. The default is NIL,
 268 i.e. do not catch up."
 269   (when (and catch-up-p (not repeat-interval))
 270     (error "~@<~A does not make sense without ~A.~@:>"
 271            :catch-up :repeat-interval))
 272   ;; CANCEL-FUNCTION may block until all interruptors finish, let's
 273   ;; try to cancel without the scheduler lock first.
 274   (when (%timer-cancel-function timer)
 275     (funcall (%timer-cancel-function timer)))
 276   (with-scheduler-lock ()
 277     (let ((delta/real (delta->real
 278                        (if absolute-p
 279                            (- time (get-universal-time))
 280                            time))))
 281       (setf (%timer-expire-time timer) (+ (get-internal-real-time) delta/real)
 282             (%timer-repeat-interval timer) (when repeat-interval
 283                                              (delta->real repeat-interval))
 284             (%timer-catch-up timer) catch-up))
 285     (%schedule-timer timer)))
 286
 287 (defun unschedule-timer (timer)
 288   "Cancel TIMER. Once this function returns it is guaranteed that
 289 TIMER shall not be triggered again and there are no unfinished
 290 triggers."
 291   (let ((cancel-function (%timer-cancel-function timer)))
 292     (when cancel-function
 293       (funcall cancel-function)))
 294   (with-scheduler-lock ()
 295     (setf (%timer-expire-time timer) nil
 296           (%timer-repeat-interval timer) nil)
 297     (let ((old-position (priority-queue-remove *schedule* timer)))
 298       ;; Don't use cancel-function as the %timer-cancel-function
 299       ;; may have changed before we got the scheduler lock.
 300       (when old-position
 301         (funcall (%timer-cancel-function timer)))
 302       (when (eql 0 old-position)
 303         (set-system-timer))))
 304   (values))
 305
 306 (defun list-all-timers ()
 307   "Return a list of all timers in the system."
 308   (with-scheduler-lock ()
 309     (concatenate 'list (%pqueue-contents *schedule*))))
 310
 311 ;;; Not public, but related
 312
 313 (defun reschedule-timer (timer)
 314   ;; unless unscheduled
 315   (symbol-macrolet ((expire-time (%timer-expire-time timer))
 316                     (repeat-interval (%timer-repeat-interval timer))
 317                     (catch-up (%timer-catch-up timer))
 318                     (thread (%timer-thread timer)))
 319     (when expire-time
 320       (if (and (sb!thread::thread-p thread)
 321                (not (sb!thread:thread-alive-p thread)))
 322           (unschedule-timer timer)
 323           (with-scheduler-lock ()
 324             ;; Schedule at regular intervals. If TIMER has not finished
 325             ;; in time then it may catch up later.
 326             (incf expire-time repeat-interval)
 327             ;; If the internal real time had a discontinuity
 328             ;; (e.g. computer suspended and resumed), maybe adjust the
 329             ;; expiration time accordingly unless the timer is
 330             ;; configured to "catch up" by performing the missed calls
 331             ;; immediately.
 332             (unless catch-up
 333               (let ((now (get-internal-real-time)))
 334                 (when (< expire-time now)
 335                   (setf expire-time (+ now repeat-interval)))))
 336             (%schedule-timer timer))))))
 337
 338 ;;; setitimer is unavailable for win32, but we can emulate it when
 339 ;;; threads are available -- using win32 waitable timers.
 340 ;;;
 341 ;;; Conversely, when we want to minimize signal use on POSIX, we emulate
 342 ;;; win32 waitable timers using a timerfd-like portability layer in
 343 ;;; the runtime.
 344
 345 #!+sb-wtimer
 346 (define-alien-type wtimer
 347     #!+win32 system-area-pointer ;HANDLE, but that's not defined yet
 348     #!+sunos system-area-pointer ;struct os_wtimer *
 349     #!+(or android linux bsd) int)
 350
 351 #!+sb-wtimer
 352 (progn
 353   (define-alien-routine "os_create_wtimer" wtimer)
 354   (define-alien-routine "os_wait_for_wtimer" int (wt wtimer))
 355   (define-alien-routine "os_close_wtimer" void (wt wtimer))
 356   (define-alien-routine "os_cancel_wtimer" void (wt wtimer))
 357   (define-alien-routine "os_set_wtimer" void (wt wtimer) (sec int) (nsec int))
 358
 359   ;; scheduler lock already protects us
 360
 361   (defvar *waitable-timer-handle* nil)
 362
 363   (defvar *timer-thread* nil)
 364
 365   (defun get-waitable-timer ()
 366     (assert (under-scheduler-lock-p))
 367     (or *waitable-timer-handle*
 368         (prog1
 369             (setf *waitable-timer-handle* (os-create-wtimer))
 370           (setf *timer-thread*
 371                 (sb!thread:make-thread
 372                  (lambda ()
 373                    (loop while
 374                         (or (zerop
 375                              (os-wait-for-wtimer *waitable-timer-handle*))
 376                             *waitable-timer-handle*)
 377                         doing (run-expired-timers)))
 378                  :ephemeral t
 379                  :name "System timer watchdog thread")))))
 380
 381   (defun itimer-emulation-deinit ()
 382     (with-scheduler-lock ()
 383       (when *timer-thread*
 384         (sb!thread:terminate-thread *timer-thread*)
 385         (sb!thread:join-thread *timer-thread* :default nil))
 386       (when *waitable-timer-handle*
 387         (os-close-wtimer *waitable-timer-handle*)
 388         (setf *waitable-timer-handle* nil))))
 389
 390   (defun %clear-system-timer ()
 391     (os-cancel-wtimer (get-waitable-timer)))
 392
 393   (defun %set-system-timer (sec nsec)
 394     (os-set-wtimer (get-waitable-timer) sec nsec)))
 395
 396 ;;; Expiring timers
 397
 398 (defun real-time->sec-and-nsec (time)
 399   ;; KLUDGE: Always leave 0.0001 second for other stuff in order to
 400   ;; avoid starvation.
 401   (let ((min-nsec 100000))
 402     (if (minusp time)
 403         (values 0 min-nsec)
 404         (multiple-value-bind (s u) (floor time internal-time-units-per-second)
 405           (setf u (floor (* (/ u internal-time-units-per-second)
 406                             #.(expt 10 9))))
 407           (if (and (= 0 s) (< u min-nsec))
 408               ;; 0 0 means "shut down the timer" for setitimer
 409               (values 0 min-nsec)
 410               (values s u))))))
 411
 412 #!-(or sb-wtimer win32)
 413 (progn
 414   (defun %set-system-timer (sec nsec)
 415     (sb!unix:unix-setitimer :real 0 0 sec (ceiling nsec 1000)))
 416
 417   (defun %clear-system-timer ()
 418     (sb!unix:unix-setitimer :real 0 0 0 0)))
 419
 420 (defun set-system-timer ()
 421   (assert (under-scheduler-lock-p))
 422   (assert (not *interrupts-enabled*))
 423   (let ((next-timer (peek-schedule)))
 424     (if next-timer
 425         (let ((delta (- (%timer-expire-time next-timer)
 426                         (get-internal-real-time))))
 427           (multiple-value-call #'%set-system-timer
 428             (real-time->sec-and-nsec delta)))
 429         (%clear-system-timer))))
 430
 431 (defun run-timer (timer)
 432   (let ((function (%timer-interrupt-function timer))
 433         (thread (%timer-thread timer)))
 434     (if (eq t thread)
 435         (sb!thread:make-thread function :name (format nil "Timer ~A"
 436                                                       (%timer-name timer)))
 437         ;; Don't run the timer directly in the current thread.
 438         ;; The signal that interrupt-thread sends is blocked so it'll get queued
 439         ;; and processed after exiting from SIGALRM-HANDLER.
 440         ;; That way we process all pending signals and release the *SCHEDULER-LOCK*.
 441         (let ((thread (or thread sb!thread:*current-thread*)))
 442           (handler-case
 443               (sb!thread:interrupt-thread thread function)
 444             (sb!thread:interrupt-thread-error (c)
 445               (declare (ignore c))
 446               (warn "Timer ~S failed to interrupt thread ~S."
 447                     timer thread)))))))
 448
 449 ;;; Called from the signal handler. We loop until all the expired timers
 450 ;;; have been run.
 451 (defun run-expired-timers ()
 452   (loop
 453     (let ((now (get-internal-real-time))
 454           (timers nil))
 455       (flet ((run-timers ()
 456                (dolist (timer (nreverse timers))
 457                  (run-timer timer))))
 458         (with-scheduler-lock ()
 459           (loop for timer = (peek-schedule)
 460                 when (or (null timer) (< now (%timer-expire-time timer)))
 461                 ;; No more timers to run for now, reset the system timer.
 462                 do (run-timers)
 463                    (set-system-timer)
 464                    (return-from run-expired-timers nil)
 465                 else
 466                 do (assert (eq timer (priority-queue-extract-maximum *schedule*)))
 467                    (push timer timers)))
 468         (run-timers)))))
 469
 470 (defun timeout-cerror ()
 471   (cerror "Continue" 'timeout))
 472
 473 (defmacro with-timeout (expires &body body)
 474   "Execute the body, asynchronously interrupting it and signalling a TIMEOUT
 475 condition after at least EXPIRES seconds have passed.
 476
 477 Note that it is never safe to unwind from an asynchronous condition. Consider:
 478
 479   (defun call-with-foo (function)
 480     (let (foo)
 481       (unwind-protect
 482          (progn
 483            (setf foo (get-foo))
 484            (funcall function foo))
 485        (when foo
 486          (release-foo foo)))))
 487
 488 If TIMEOUT occurs after GET-FOO has executed, but before the assignment, then
 489 RELEASE-FOO will be missed. While individual sites like this can be made proof
 490 against asynchronous unwinds, this doesn't solve the fundamental issue, as all
 491 the frames potentially unwound through need to be proofed, which includes both
 492 system and application code -- and in essence proofing everything will make
 493 the system uninterruptible."
 494   `(dx-flet ((timeout-body () ,@body))
 495      (let ((expires ,expires))
 496        ;; FIXME: a temporary compatibility workaround for CLX, if unsafe
 497        ;; unwinds are handled revisit it.
 498        (if (> expires 0)
 499            (let ((timer (make-timer #'timeout-cerror)))
 500              (schedule-timer timer expires)
 501              (unwind-protect (timeout-body)
 502                (unschedule-timer timer)))
 503            (timeout-body)))))