1.0.9.18: Instrument COMPUTE-CALLING-FRAME for non-x86 with /noshow0.
[sbcl.git] / 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 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   (when (< (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   contents
85   keyfun)
86
87 (defun make-priority-queue (&key (key #'identity) (element-type t))
88   (let ((contents (make-array 100
89                               :adjustable t
90                               :fill-pointer 0
91                               :element-type element-type)))
92     (%make-priority-queue :keyfun key
93                           :contents contents)))
94
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)))))
99
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))))
105
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 #'<=))))
112
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 #'<=)))
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   "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)))
127       (when i
128         (heap-extract contents i :key keyfun :test #'<=)
129         i))))
130
131 ;;; thread utility
132
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))
137         (cancelled-p nil))
138     (list
139      #'(lambda ()
140          (sb!thread:with-recursive-lock (mutex)
141            (unless cancelled-p
142              (funcall function))))
143      #'(lambda ()
144          (sb!thread:with-recursive-lock (mutex)
145            (setq cancelled-p t))))))
146
147 ;;; timers
148
149 (defstruct (timer
150              (:conc-name %timer-)
151              (:constructor %make-timer))
152   #!+sb-doc
153   "Timer type. Do not rely on timers being structs as it may change in
154 future versions."
155   name
156   function
157   expire-time
158   repeat-interval
159   (thread nil :type (or sb!thread:thread (member t nil)))
160   interrupt-function
161   cancel-function)
162
163 (def!method print-object ((timer timer) stream)
164   (let ((name (%timer-name timer)))
165     (if name
166         (print-unreadable-object (timer stream :type t :identity t)
167           (prin1 name stream))
168         (print-unreadable-object (timer stream :type t :identity t)
169           ;; body is empty => there is only one space between type and
170           ;; identity
171           ))))
172
173 (defun make-timer (function &key name (thread sb!thread:*current-thread*))
174   #!+sb-doc
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
179 thread."
180   (%make-timer :name name :function function :thread thread))
181
182 (defun timer-name (timer)
183   #!+sb-doc
184   "Return the name of TIMER."
185   (%timer-name timer))
186
187 (defun timer-scheduled-p (timer &key (delta 0))
188   #!+sb-doc
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))
194           (and expire-time
195                (<= (+ (get-internal-real-time) delta)
196                    expire-time)))))
197
198 ;;; The scheduler
199
200 (defvar *scheduler-lock* (sb!thread:make-mutex :name "Scheduler lock"))
201
202 (defmacro with-scheduler-lock ((&optional) &body body)
203   ;; don't let the SIGALRM handler mess things up
204   `(sb!thread::call-with-system-mutex (lambda () ,@body) *scheduler-lock*))
205
206 (defun under-scheduler-lock-p ()
207   #!-sb-thread
208   t
209   #!+sb-thread
210   (eq sb!thread:*current-thread* (sb!thread:mutex-value *scheduler-lock*)))
211
212 (defparameter *schedule* (make-priority-queue :key #'%timer-expire-time))
213
214 (defun peek-schedule ()
215   (priority-queue-maximum *schedule*))
216
217 (defun time-left (timer)
218   (- (%timer-expire-time timer) (get-internal-real-time)))
219
220 ;;; real time conversion
221
222 (defun delta->real (delta)
223   (floor (* delta internal-time-units-per-second)))
224
225 ;;; Public interface
226
227 (defun %schedule-timer (timer)
228   (let ((changed-p nil)
229         (old-position (priority-queue-remove *schedule* timer)))
230     ;; Make sure interruptors are cancelled even if this timer was
231     ;; scheduled again since our last attempt.
232     (when old-position
233       (funcall (%timer-cancel-function timer)))
234     (when (eql 0 old-position)
235       (setq changed-p t))
236     (when (zerop (priority-queue-insert *schedule* timer))
237       (setq changed-p t))
238     (setf (values (%timer-interrupt-function timer)
239                   (%timer-cancel-function timer))
240           (values-list (make-cancellable-interruptor
241                         (%timer-function timer))))
242     (when changed-p
243       (set-system-timer)))
244   (values))
245
246 (defun schedule-timer (timer time &key repeat-interval absolute-p)
247   #!+sb-doc
248   "Schedule TIMER to be triggered at TIME. If ABSOLUTE-P then TIME is
249 universal time, but non-integral values are also allowed, else TIME is
250 measured as the number of seconds from the current time. If
251 REPEAT-INTERVAL is given, TIMER is automatically rescheduled upon
252 expiry."
253   ;; CANCEL-FUNCTION may block until all interruptors finish, let's
254   ;; try to cancel without the scheduler lock first.
255   (when (%timer-cancel-function timer)
256     (funcall (%timer-cancel-function timer)))
257   (with-scheduler-lock ()
258     (setf (%timer-expire-time timer) (+ (get-internal-real-time)
259                                         (delta->real
260                                          (if absolute-p
261                                              (- time (get-universal-time))
262                                              time)))
263           (%timer-repeat-interval timer) (if repeat-interval
264                                              (delta->real repeat-interval)
265                                              nil))
266     (%schedule-timer timer)))
267
268 (defun unschedule-timer (timer)
269   #!+sb-doc
270   "Cancel TIMER. Once this function returns it is guaranteed that
271 TIMER shall not be triggered again and there are no unfinished
272 triggers."
273   (let ((cancel-function (%timer-cancel-function timer)))
274     (when cancel-function
275       (funcall cancel-function)))
276   (with-scheduler-lock ()
277     (setf (%timer-expire-time timer) nil
278           (%timer-repeat-interval timer) nil)
279     (let ((old-position (priority-queue-remove *schedule* timer)))
280       (when old-position
281         (funcall (%timer-cancel-function timer)))
282       (when (eql 0 old-position)
283         (set-system-timer))))
284   (values))
285
286 (defun list-all-timers ()
287   #!+sb-doc
288   "Return a list of all timers in the system."
289   (with-scheduler-lock ()
290     (concatenate 'list (%pqueue-contents *schedule*))))
291
292 ;;; Not public, but related
293
294 (defun reschedule-timer (timer)
295   (with-scheduler-lock ()
296     (setf (%timer-expire-time timer) (+ (get-internal-real-time)
297                                         (%timer-repeat-interval timer)))
298     (%schedule-timer timer)))
299
300 ;;; Expiring timers
301
302 (defun real-time->sec-and-usec(time)
303   (if (minusp time)
304       (list 0 1)
305       (multiple-value-bind (s u) (floor time internal-time-units-per-second)
306         (setf u (floor (* (/ u internal-time-units-per-second) 1000000)))
307         (if (= 0 s u)
308             ;; 0 0 means "shut down the timer" for setitimer
309             (list 0 1)
310             (list s u)))))
311
312 (defun set-system-timer ()
313   (assert (under-scheduler-lock-p))
314   (let ((next-timer (peek-schedule)))
315     (if next-timer
316         (let ((delta (- (%timer-expire-time next-timer)
317                         (get-internal-real-time))))
318           (apply #'sb!unix:unix-setitimer
319                  :real 0 0 (real-time->sec-and-usec delta)))
320         (sb!unix:unix-setitimer :real 0 0 0 0))))
321
322 (defun run-timer (timer)
323   (symbol-macrolet ((function (%timer-function timer))
324                     (repeat-interval (%timer-repeat-interval timer))
325                     (thread (%timer-thread timer)))
326     (when repeat-interval
327       (reschedule-timer timer))
328     (cond ((null thread)
329            (funcall function))
330           ((eq t thread)
331            (sb!thread:make-thread function))
332           (t
333            (handler-case
334                (sb!thread:interrupt-thread thread function)
335              (sb!thread:interrupt-thread-error (c)
336                (declare (ignore c))
337                (warn "Timer ~S failed to interrupt thread ~S."
338                      timer thread)))))))
339
340 ;; Called from the signal handler.
341 (defun run-expired-timers ()
342   (unwind-protect
343        (with-interrupts
344          (let (timer)
345            (loop
346             (with-scheduler-lock ()
347               (setq timer (peek-schedule))
348               (unless (and timer
349                            (> (get-internal-real-time)
350                               (%timer-expire-time timer)))
351                 (return-from run-expired-timers nil))
352               (assert (eq timer (priority-queue-extract-maximum *schedule*))))
353             ;; run the timer without the lock
354             (run-timer timer))))
355     (with-scheduler-lock ()
356       (set-system-timer))))
357
358 (defmacro sb!ext:with-timeout (expires &body body)
359   #!+sb-doc
360   "Execute the body, asynchronously interrupting it and signalling a TIMEOUT
361 condition after at least EXPIRES seconds have passed.
362
363 Note that it is never safe to unwind from an asynchronous condition. Consider:
364
365   (defun call-with-foo (function)
366     (let (foo)
367       (unwind-protect
368          (progn
369            (setf foo (get-foo))
370            (funcall function foo))
371        (when foo
372          (release-foo foo)))))
373
374 If TIMEOUT occurs after GET-FOO has executed, but before the assignment, then
375 RELEASE-FOO will be missed. While individual sites like this can be made proof
376 against asynchronous unwinds, this doesn't solve the fundamental issue, as all
377 the frames potentially unwound through need to be proofed, which includes both
378 system and application code -- and in essence proofing everything will make
379 the system uninterruptible."
380   (with-unique-names (timer)
381     ;; FIXME: a temporary compatibility workaround for CLX, if unsafe
382     ;; unwinds are handled revisit it.
383     `(if (> ,expires 0)
384          (let ((,timer (make-timer (lambda ()
385                                      (cerror "Continue" 'sb!ext::timeout)))))
386            (schedule-timer ,timer ,expires)
387            (unwind-protect
388                 (progn ,@body)
389              (unschedule-timer ,timer)))
390          (progn ,@body))))