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