1 ;;;; a timer facility based heavily on the timer package by Zach Beane
3 ;;;; This software is part of the SBCL system. See the README file for
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.
12 (in-package "SB!IMPL")
14 ;;; Heap (for the priority queue)
16 (declaim (inline heap-parent heap-left heap-right))
18 (defun heap-parent (i)
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))
35 (setf largest (if (and (< l size)
36 (not (ge (key (aref heap start))
37 (key (aref heap l)))))
41 (not (ge (key (aref heap largest))
42 (key (aref heap r)))))
44 (when (/= largest start)
45 (rotatef (aref heap largest) (aref heap start))
46 (heapify heap largest :key key :test test)))
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)
57 (not (ge (key (aref heap parent-i))
59 do (setf (aref heap i) (aref heap parent-i))
60 finally (setf (aref heap i) new-item)
61 (return-from heap-insert i))))
63 (defun heap-maximum (heap)
64 (unless (zerop (length heap))
67 (defun heap-extract (heap i &key (key #'identity) (test #'>=))
68 (when (< (length heap) i)
69 (error "Heap underflow"))
72 (setf (aref heap i) (aref heap (1- (length heap))))
73 (decf (fill-pointer heap))
74 (heapify heap i :key key :test test)))
76 (defun heap-extract-maximum (heap &key (key #'identity) (test #'>=))
77 (heap-extract heap 0 :key key :test test))
81 (defstruct (priority-queue
83 (:constructor %make-priority-queue))
87 (defun make-priority-queue (&key (key #'identity) (element-type t))
88 (let ((contents (make-array 100
91 :element-type element-type)))
92 (%make-priority-queue :keyfun key
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)))))
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))))
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 #'<=))))
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 #'<=)))
119 (defun priority-queue-empty-p (priority-queue)
120 (zerop (length (%pqueue-contents priority-queue))))
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)))
128 (heap-extract contents i :key keyfun :test #'<=)
133 (defun make-cancellable-interruptor (function)
134 ;; return a list of two functions: one that does the same as
135 ;; FUNCTION until the other is called, from when it does nothing.
136 (let ((mutex (sb!thread:make-mutex))
140 (sb!thread:with-recursive-lock (mutex)
142 (funcall function))))
144 (sb!thread:with-recursive-lock (mutex)
145 (setq cancelled-p t))))))
151 (:constructor %make-timer))
153 "Timer type. Do not rely on timers being structs as it may change in
159 (thread nil :type (or sb!thread:thread (member t nil)))
163 (def!method print-object ((timer timer) stream)
164 (let ((name (%timer-name timer)))
166 (print-unreadable-object (timer stream :type t :identity t)
168 (print-unreadable-object (timer stream :type t :identity t)
169 ;; body is empty => there is only one space between type and
173 (defun make-timer (function &key name (thread sb!thread:*current-thread*))
175 "Create a timer object that's when scheduled runs FUNCTION. If
176 THREAD is a thread then that thread is to be interrupted with
177 FUNCTION. If THREAD is T then a new thread is created each timer
178 FUNCTION is run. If THREAD is NIL then FUNCTION can be run in any
180 (%make-timer :name name :function function :thread thread))
182 (defun timer-name (timer)
184 "Return the name of TIMER."
187 (defun timer-scheduled-p (timer &key (delta 0))
189 "See if TIMER will still need to be triggered after DELTA seconds
190 from now. For timers with a repeat interval it returns true."
191 (symbol-macrolet ((expire-time (%timer-expire-time timer))
192 (repeat-interval (%timer-repeat-interval timer)))
193 (or (and repeat-interval (plusp repeat-interval))
195 (<= (+ (get-internal-real-time) delta)
200 (defvar *scheduler-lock* (sb!thread:make-mutex :name "Scheduler lock"))
202 (defmacro with-scheduler-lock ((&optional) &body body)
203 ;; don't let the SIGALRM handler mess things up
204 `(sb!sys:without-interrupts
205 (sb!thread:with-mutex (*scheduler-lock*)
208 (defun under-scheduler-lock-p ()
212 (eq sb!thread:*current-thread* (sb!thread:mutex-value *scheduler-lock*)))
214 (defparameter *schedule* (make-priority-queue :key #'%timer-expire-time))
216 (defun peek-schedule ()
217 (priority-queue-maximum *schedule*))
219 (defun time-left (timer)
220 (- (%timer-expire-time timer) (get-internal-real-time)))
222 ;;; real time conversion
224 (defun delta->real (delta)
225 (floor (* delta internal-time-units-per-second)))
229 (defun %schedule-timer (timer)
230 (let ((changed-p nil)
231 (old-position (priority-queue-remove *schedule* timer)))
232 ;; Make sure interruptors are cancelled even if this timer was
233 ;; scheduled again since our last attempt.
235 (funcall (%timer-cancel-function timer)))
236 (when (eql 0 old-position)
238 (when (zerop (priority-queue-insert *schedule* timer))
240 (setf (values (%timer-interrupt-function timer)
241 (%timer-cancel-function timer))
242 (values-list (make-cancellable-interruptor
243 (%timer-function timer))))
248 (defun schedule-timer (timer time &key repeat-interval absolute-p)
250 "Schedule TIMER to be triggered at TIME. If ABSOLUTE-P then TIME is
251 universal time, but non-integral values are also allowed, else TIME is
252 measured as the number of seconds from the current time. If
253 REPEAT-INTERVAL is given, TIMER is automatically rescheduled upon
255 ;; CANCEL-FUNCTION may block until all interruptors finish, let's
256 ;; try to cancel without the scheduler lock first.
257 (when (%timer-cancel-function timer)
258 (funcall (%timer-cancel-function timer)))
259 (with-scheduler-lock ()
260 (setf (%timer-expire-time timer) (+ (get-internal-real-time)
263 (- time (get-universal-time))
265 (%timer-repeat-interval timer) (if repeat-interval
266 (delta->real repeat-interval)
268 (%schedule-timer timer)))
270 (defun unschedule-timer (timer)
272 "Cancel TIMER. Once this function returns it is guaranteed that
273 TIMER shall not be triggered again and there are no unfinished
275 (let ((cancel-function (%timer-cancel-function timer)))
276 (when cancel-function
277 (funcall cancel-function)))
278 (with-scheduler-lock ()
279 (setf (%timer-expire-time timer) nil
280 (%timer-repeat-interval timer) nil)
281 (let ((old-position (priority-queue-remove *schedule* timer)))
283 (funcall (%timer-cancel-function timer)))
284 (when (eql 0 old-position)
285 (set-system-timer))))
288 (defun list-all-timers ()
290 "Return a list of all timers in the system."
291 (with-scheduler-lock ()
292 (concatenate 'list (%pqueue-contents *schedule*))))
294 ;;; Not public, but related
296 (defun reschedule-timer (timer)
297 (with-scheduler-lock ()
298 (setf (%timer-expire-time timer) (+ (get-internal-real-time)
299 (%timer-repeat-interval timer)))
300 (%schedule-timer timer)))
304 (defun real-time->sec-and-usec(time)
307 (multiple-value-bind (s u) (floor time internal-time-units-per-second)
308 (setf u (floor (* (/ u internal-time-units-per-second) 1000000)))
310 ;; 0 0 means "shut down the timer" for setitimer
314 (defun set-system-timer ()
315 (assert (under-scheduler-lock-p))
316 (let ((next-timer (peek-schedule)))
318 (let ((delta (- (%timer-expire-time next-timer)
319 (get-internal-real-time))))
320 (apply #'sb!unix:unix-setitimer
321 :real 0 0 (real-time->sec-and-usec delta)))
322 (sb!unix:unix-setitimer :real 0 0 0 0))))
324 (defun run-timer (timer)
325 (symbol-macrolet ((function (%timer-function timer))
326 (repeat-interval (%timer-repeat-interval timer))
327 (thread (%timer-thread timer)))
328 (when repeat-interval
329 (reschedule-timer timer))
333 (sb!thread:make-thread function))
336 (sb!thread:interrupt-thread thread function)
337 (sb!thread:interrupt-thread-error (c)
340 (defun run-expired-timers ()
344 (with-scheduler-lock ()
345 (setq timer (peek-schedule))
347 (> (get-internal-real-time)
348 (%timer-expire-time timer)))
349 (return-from run-expired-timers nil))
350 (assert (eq timer (priority-queue-extract-maximum *schedule*))))
351 ;; run the timer without the lock
353 (with-scheduler-lock ()
354 (set-system-timer))))
356 (defmacro sb!ext:with-timeout (expires &body body)
358 "Execute the body, asynchronously interrupting it and signalling a
359 TIMEOUT condition after at least EXPIRES seconds have passed."
360 (with-unique-names (timer)
361 `(let ((,timer (make-timer (lambda ()
362 (cerror "Continue" 'sb!ext::timeout)))))
363 (schedule-timer ,timer ,expires)
366 (unschedule-timer ,timer)))))