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 #'<=)
135 (:constructor %make-timer))
140 (thread nil :type (or sb!thread:thread (member t nil))))
142 (def!method print-object ((timer timer) stream)
143 (let ((name (%timer-name timer)))
145 (print-unreadable-object (timer stream :type t :identity t)
147 (print-unreadable-object (timer stream :type t :identity t)
148 ;; body is empty => there is only one space between type and
152 (defun make-timer (function &key name (thread sb!thread:*current-thread*))
153 (%make-timer :name name :function function :thread thread))
155 (defun timer-name (timer)
158 (defun timer-expired-p (timer &optional (delta 0))
159 (symbol-macrolet ((expire-time (%timer-expire-time timer))
160 (repeat-interval (%timer-repeat-interval timer)))
161 (and (not (and repeat-interval (plusp repeat-interval)))
162 (or (null expire-time)
164 (+ (get-internal-real-time) delta))))))
168 (defvar *scheduler-lock* (sb!thread:make-mutex :name "Scheduler lock"))
170 (defmacro with-scheduler-lock ((&optional) &body body)
171 ;; don't let the SIGALRM handler mess things up
172 `(sb!sys:without-interrupts
173 (sb!thread:with-mutex (*scheduler-lock*)
176 (defun under-scheduler-lock-p ()
180 (eq sb!thread:*current-thread* (sb!thread:mutex-value *scheduler-lock*)))
182 (defparameter *schedule* (make-priority-queue :key #'%timer-expire-time))
184 (defun peek-schedule ()
185 (priority-queue-maximum *schedule*))
187 (defun time-left (timer)
188 (- (%timer-expire-time timer) (get-internal-real-time)))
190 ;;; real time conversion
192 (defun delta->real (delta)
193 (floor (* delta internal-time-units-per-second)))
197 (defun %schedule-timer (timer)
198 (let ((changed-p nil))
199 (when (eql 0 (priority-queue-remove *schedule* timer))
201 (when (zerop (priority-queue-insert *schedule* timer))
207 (defun schedule-timer (timer time &key repeat-interval absolute-p)
208 (with-scheduler-lock ()
209 (setf (%timer-expire-time timer) (+ (get-internal-real-time)
212 (- time (get-universal-time))
214 (%timer-repeat-interval timer) (if repeat-interval
215 (delta->real repeat-interval)
217 (%schedule-timer timer)))
219 (defun unschedule-timer (timer)
220 (with-scheduler-lock ()
221 (setf (%timer-expire-time timer) nil
222 (%timer-repeat-interval timer) nil)
223 (when (eql 0 (priority-queue-remove *schedule* timer))
227 (defun list-all-timers ()
228 (with-scheduler-lock ()
229 (concatenate 'list (%pqueue-contents *schedule*))))
231 ;;; Not public, but related
233 (defun reschedule-timer (timer)
234 (with-scheduler-lock ()
235 (setf (%timer-expire-time timer) (+ (get-internal-real-time)
236 (%timer-repeat-interval timer)))
237 (%schedule-timer timer)))
241 (defun real-time->sec-and-usec(time)
244 (multiple-value-bind (s u) (floor time internal-time-units-per-second)
245 (setf u (floor (* (/ u internal-time-units-per-second) 1000000)))
247 ;; 0 0 means "shut down the timer" for setitimer
251 (defun set-system-timer ()
252 (assert (under-scheduler-lock-p))
253 (let ((next-timer (peek-schedule)))
255 (let ((delta (- (%timer-expire-time next-timer)
256 (get-internal-real-time))))
257 (apply #'sb!unix:unix-setitimer
258 :real 0 0 (real-time->sec-and-usec delta)))
259 (sb!unix:unix-setitimer :real 0 0 0 0))))
261 (defun run-timer (timer)
262 (symbol-macrolet ((function (%timer-function timer))
263 (repeat-interval (%timer-repeat-interval timer))
264 (thread (%timer-thread timer)))
265 (when repeat-interval
266 (reschedule-timer timer))
270 (sb!thread:make-thread function))
273 (sb!thread:interrupt-thread thread function)
274 (sb!thread:interrupt-thread-error (c)
277 (defun run-expired-timers ()
281 (with-scheduler-lock ()
282 (setq timer (peek-schedule))
284 (> (get-internal-real-time)
285 (%timer-expire-time timer)))
286 (return-from run-expired-timers nil))
287 (assert (eq timer (priority-queue-extract-maximum *schedule*))))
288 ;; run the timer without the lock
290 (with-scheduler-lock ()
291 (set-system-timer))))
293 (defmacro sb!ext:with-timeout (expires &body body)
294 "Execute the body, asynchronously interrupting it and signalling a
295 TIMEOUT condition after at least EXPIRES seconds have passed."
296 (with-unique-names (timer)
297 `(let ((,timer (make-timer (lambda ()
298 (cerror "Continue" 'sb!ext::timeout)))))
299 (schedule-timer ,timer ,expires)
302 (unschedule-timer ,timer)))))