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   contents
  90   keyfun)
  91
  92 (def!method print-object ((object priority-queue) stream)
  93   (print-unreadable-object (object stream :type t :identity t)
  94     (format stream "~[empty~:;~:*~D item~:P~]"
  95             (length (%pqueue-contents object)))))
  96
  97 (defun priority-queue-maximum (priority-queue)
  98   #!+sb-doc
  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   #!+sb-doc
 106   "Remove and return the item in PRIORITY-QUEUE with the largest key."
 107   (symbol-macrolet ((contents (%pqueue-contents priority-queue))
 108                     (keyfun (%pqueue-keyfun priority-queue)))
 109     (unless (zerop (length contents))
 110       (heap-extract-maximum contents :key keyfun :test #'<=))))
 111
 112 (defun priority-queue-insert (priority-queue new-item)
 113   #!+sb-doc
 114   "Add NEW-ITEM to PRIORITY-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   #!+sb-doc
 124   "Remove and return ITEM from PRIORITY-QUEUE."
 125   (symbol-macrolet ((contents (%pqueue-contents priority-queue))
 126                     (keyfun (%pqueue-keyfun priority-queue)))
 127     (let ((i (position item contents :test test)))
 128       (when i
 129         (heap-extract contents i :key keyfun :test #'<=)
 130         i))))
 131
 132 ;;; timers
 133
 134 (defstruct (timer
 135              (:conc-name %timer-)
 136              (:constructor make-timer
 137                  (function &key name (thread sb!thread:*current-thread*))))
 138   #!+sb-doc
 139   "Timer type. Do not rely on timers being structs as it may change in
 140 future versions."
 141   name
 142   function
 143   expire-time
 144   repeat-interval
 145   (thread nil :type (or sb!thread:thread (member t nil)))
 146   interrupt-function
 147   cancel-function)
 148
 149 (def!method print-object ((timer timer) stream)
 150   (let ((name (%timer-name timer)))
 151     (if name
 152         (print-unreadable-object (timer stream :type t :identity t)
 153           (prin1 name stream))
 154         (print-unreadable-object (timer stream :type t :identity t)
 155           ;; body is empty => there is only one space between type and
 156           ;; identity
 157           ))))
 158   #!+sb-doc
 159 (setf (fdocumentation 'make-timer 'function)
 160       "Create a timer that runs FUNCTION when triggered.
 161
 162 If a THREAD is supplied, FUNCTION is run in that thread. If THREAD is
 163 T, a new thread is created for FUNCTION each time the timer is
 164 triggered. If THREAD is NIL, FUNCTION is run in an unspecified thread.
 165
 166 When THREAD is not T, INTERRUPT-THREAD is used to run FUNCTION and the
 167 ordering guarantees of INTERRUPT-THREAD apply. FUNCTION runs with
 168 interrupts disabled but WITH-INTERRUPTS is allowed.")
 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 ;;; setitimer is unavailable for win32, but we can emulate it when
 319 ;;; threads are available -- using win32 waitable timers.
 320 ;;;
 321 ;;; Conversely, when we want to minimize signal use on POSIX, we emulate
 322 ;;; win32 waitable timers using a timerfd-like portability layer in
 323 ;;; the runtime.
 324
 325 #!+sb-wtimer
 326 (define-alien-type wtimer
 327     #!+win32 system-area-pointer ;HANDLE, but that's not defined yet
 328     #!+sunos system-area-pointer ;struct os_wtimer *
 329     #!+(or android linux bsd) int)
 330
 331 #!+sb-wtimer
 332 (progn
 333   (define-alien-routine "os_create_wtimer" wtimer)
 334   (define-alien-routine "os_wait_for_wtimer" int (wt wtimer))
 335   (define-alien-routine "os_close_wtimer" void (wt wtimer))
 336   (define-alien-routine "os_cancel_wtimer" void (wt wtimer))
 337   (define-alien-routine "os_set_wtimer" void (wt wtimer) (sec int) (nsec int))
 338
 339   ;; scheduler lock already protects us
 340
 341   (defvar *waitable-timer-handle* nil)
 342
 343   (defvar *timer-thread* nil)
 344
 345   (defun get-waitable-timer ()
 346     (assert (under-scheduler-lock-p))
 347     (or *waitable-timer-handle*
 348         (prog1
 349             (setf *waitable-timer-handle* (os-create-wtimer))
 350           (setf *timer-thread*
 351                 (sb!thread:make-thread
 352                  (lambda ()
 353                    (loop while
 354                         (or (zerop
 355                              (os-wait-for-wtimer *waitable-timer-handle*))
 356                             *waitable-timer-handle*)
 357                         doing (run-expired-timers)))
 358                  :ephemeral t
 359                  :name "System timer watchdog thread")))))
 360
 361   (defun itimer-emulation-deinit ()
 362     (with-scheduler-lock ()
 363       (when *timer-thread*
 364         (sb!thread:terminate-thread *timer-thread*)
 365         (sb!thread:join-thread *timer-thread* :default nil))
 366       (when *waitable-timer-handle*
 367         (os-close-wtimer *waitable-timer-handle*)
 368         (setf *waitable-timer-handle* nil))))
 369
 370   (defun %clear-system-timer ()
 371     (os-cancel-wtimer (get-waitable-timer)))
 372
 373   (defun %set-system-timer (sec nsec)
 374     (os-set-wtimer (get-waitable-timer) sec nsec)))
 375
 376 ;;; Expiring timers
 377
 378 (defun real-time->sec-and-nsec (time)
 379   ;; KLUDGE: Always leave 0.0001 second for other stuff in order to
 380   ;; avoid starvation.
 381   (let ((min-nsec 100000))
 382     (if (minusp time)
 383         (values 0 min-nsec)
 384         (multiple-value-bind (s u) (floor time internal-time-units-per-second)
 385           (setf u (floor (* (/ u internal-time-units-per-second)
 386                             #.(expt 10 9))))
 387           (if (and (= 0 s) (< u min-nsec))
 388               ;; 0 0 means "shut down the timer" for setitimer
 389               (values 0 min-nsec)
 390               (values s u))))))
 391
 392 #!-(or sb-wtimer win32)
 393 (progn
 394   (defun %set-system-timer (sec nsec)
 395     (sb!unix:unix-setitimer :real 0 0 sec (ceiling nsec 1000)))
 396
 397   (defun %clear-system-timer ()
 398     (sb!unix:unix-setitimer :real 0 0 0 0)))
 399
 400 (defun set-system-timer ()
 401   (assert (under-scheduler-lock-p))
 402   (assert (not *interrupts-enabled*))
 403   (let ((next-timer (peek-schedule)))
 404     (if next-timer
 405         (let ((delta (- (%timer-expire-time next-timer)
 406                         (get-internal-real-time))))
 407           (multiple-value-call #'%set-system-timer
 408             (real-time->sec-and-nsec delta)))
 409         (%clear-system-timer))))
 410
 411 (defun run-timer (timer)
 412   (let ((function (%timer-interrupt-function timer))
 413         (thread (%timer-thread timer)))
 414     (if (eq t thread)
 415         (sb!thread:make-thread (without-interrupts
 416                                  (allow-with-interrupts
 417                                    function))
 418                                :name (format nil "Timer ~A"
 419                                              (%timer-name timer)))
 420         (let ((thread (or thread sb!thread:*current-thread*)))
 421           (handler-case
 422               (sb!thread:interrupt-thread thread function)
 423             (sb!thread:interrupt-thread-error (c)
 424               (declare (ignore c))
 425               (warn "Timer ~S failed to interrupt thread ~S."
 426                     timer thread)))))))
 427
 428 ;;; Called from the signal handler. We loop until all the expired timers
 429 ;;; have been run.
 430 (defun run-expired-timers ()
 431   (loop
 432     (let ((now (get-internal-real-time))
 433           (timers nil))
 434       (flet ((run-timers ()
 435                (dolist (timer (nreverse timers))
 436                  (run-timer timer))))
 437         (with-scheduler-lock ()
 438           (loop for timer = (peek-schedule)
 439                 when (or (null timer) (< now (%timer-expire-time timer)))
 440                 ;; No more timers to run for now, reset the system timer.
 441                 do (run-timers)
 442                    (set-system-timer)
 443                    (return-from run-expired-timers nil)
 444                 else
 445                 do (assert (eq timer (priority-queue-extract-maximum *schedule*)))
 446                    (push timer timers)))
 447         (run-timers)))))
 448
 449 (defun timeout-cerror ()
 450   (cerror "Continue" 'timeout))
 451
 452 (defmacro with-timeout (expires &body body)
 453   #!+sb-doc
 454   "Execute the body, asynchronously interrupting it and signalling a TIMEOUT
 455 condition after at least EXPIRES seconds have passed.
 456
 457 Note that it is never safe to unwind from an asynchronous condition. Consider:
 458
 459   (defun call-with-foo (function)
 460     (let (foo)
 461       (unwind-protect
 462          (progn
 463            (setf foo (get-foo))
 464            (funcall function foo))
 465        (when foo
 466          (release-foo foo)))))
 467
 468 If TIMEOUT occurs after GET-FOO has executed, but before the assignment, then
 469 RELEASE-FOO will be missed. While individual sites like this can be made proof
 470 against asynchronous unwinds, this doesn't solve the fundamental issue, as all
 471 the frames potentially unwound through need to be proofed, which includes both
 472 system and application code -- and in essence proofing everything will make
 473 the system uninterruptible."
 474   `(dx-flet ((timeout-body () ,@body))
 475      (let ((expires ,expires))
 476        ;; FIXME: a temporary compatibility workaround for CLX, if unsafe
 477        ;; unwinds are handled revisit it.
 478        (if (> expires 0)
 479            (let ((timer (make-timer #'timeout-cerror)))
 480              (schedule-timer timer expires)
 481              (unwind-protect (timeout-body)
 482                (unschedule-timer timer)))
 483            (timeout-body)))))