[266ccb]: src / code / timer.lisp Maximize Restore History

Download this file

timer.lisp    484 lines (415 with data), 17.7 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
;;;; a timer facility based heavily on the timer package by Zach Beane
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!IMPL")
;;; Heap (for the priority queue)
(declaim (inline heap-parent heap-left heap-right))
(defun heap-parent (i)
(ash (1- i) -1))
(defun heap-left (i)
(1+ (ash i 1)))
(defun heap-right (i)
(+ 2 (ash i 1)))
(defun heapify (heap start &key (key #'identity) (test #'>=))
(declare (function key test))
(flet ((key (obj) (funcall key obj))
(ge (i j) (funcall test i j)))
(let ((l (heap-left start))
(r (heap-right start))
(size (length heap))
largest)
(setf largest (if (and (< l size)
(not (ge (key (aref heap start))
(key (aref heap l)))))
l
start))
(when (and (< r size)
(not (ge (key (aref heap largest))
(key (aref heap r)))))
(setf largest r))
(when (/= largest start)
(rotatef (aref heap largest) (aref heap start))
(heapify heap largest :key key :test test)))
heap))
(defun heap-insert (heap new-item &key (key #'identity) (test #'>=))
(declare (function key test))
(flet ((key (obj) (funcall key obj))
(ge (i j) (funcall test i j)))
(vector-push-extend nil heap)
(loop for i = (1- (length heap)) then parent-i
for parent-i = (heap-parent i)
while (and (> i 0)
(not (ge (key (aref heap parent-i))
(key new-item))))
do (setf (aref heap i) (aref heap parent-i))
finally (setf (aref heap i) new-item)
(return-from heap-insert i))))
(defun heap-maximum (heap)
(unless (zerop (length heap))
(aref heap 0)))
(defun heap-extract (heap i &key (key #'identity) (test #'>=))
(unless (> (length heap) i)
(error "Heap underflow"))
(prog1
(aref heap i)
(setf (aref heap i) (aref heap (1- (length heap))))
(decf (fill-pointer heap))
(heapify heap i :key key :test test)))
(defun heap-extract-maximum (heap &key (key #'identity) (test #'>=))
(heap-extract heap 0 :key key :test test))
;;; Priority queue
(defstruct (priority-queue
(:conc-name %pqueue-)
(:constructor %make-priority-queue))
contents
keyfun)
(defun make-priority-queue (&key (key #'identity) (element-type t))
(let ((contents (make-array 100
:adjustable t
:fill-pointer 0
:element-type element-type)))
(%make-priority-queue :keyfun key
:contents contents)))
(def!method print-object ((object priority-queue) stream)
(print-unreadable-object (object stream :type t :identity t)
(format stream "~[empty~:;~:*~D item~:P~]"
(length (%pqueue-contents object)))))
(defun priority-queue-maximum (priority-queue)
"Return the item in PRIORITY-QUEUE with the largest key."
(symbol-macrolet ((contents (%pqueue-contents priority-queue)))
(unless (zerop (length contents))
(heap-maximum contents))))
(defun priority-queue-extract-maximum (priority-queue)
"Remove and return the item in PRIORITY-QUEUE with the largest key."
(symbol-macrolet ((contents (%pqueue-contents priority-queue))
(keyfun (%pqueue-keyfun priority-queue)))
(unless (zerop (length contents))
(heap-extract-maximum contents :key keyfun :test #'<=))))
(defun priority-queue-insert (priority-queue new-item)
"Add NEW-ITEM to PRIOIRITY-QUEUE."
(symbol-macrolet ((contents (%pqueue-contents priority-queue))
(keyfun (%pqueue-keyfun priority-queue)))
(heap-insert contents new-item :key keyfun :test #'<=)))
(defun priority-queue-empty-p (priority-queue)
(zerop (length (%pqueue-contents priority-queue))))
(defun priority-queue-remove (priority-queue item &key (test #'eq))
"Remove and return ITEM from PRIORITY-QUEUE."
(symbol-macrolet ((contents (%pqueue-contents priority-queue))
(keyfun (%pqueue-keyfun priority-queue)))
(let ((i (position item contents :test test)))
(when i
(heap-extract contents i :key keyfun :test #'<=)
i))))
;;; timers
(defstruct (timer
(:conc-name %timer-)
(:constructor %make-timer))
#!+sb-doc
"Timer type. Do not rely on timers being structs as it may change in
future versions."
name
function
expire-time
repeat-interval
(thread nil :type (or sb!thread:thread (member t nil)))
interrupt-function
cancel-function)
(def!method print-object ((timer timer) stream)
(let ((name (%timer-name timer)))
(if name
(print-unreadable-object (timer stream :type t :identity t)
(prin1 name stream))
(print-unreadable-object (timer stream :type t :identity t)
;; body is empty => there is only one space between type and
;; identity
))))
(defun make-timer (function &key name (thread sb!thread:*current-thread*))
#!+sb-doc
"Create a timer that runs FUNCTION when triggered.
If a THREAD is supplied, FUNCTION is run in that thread. If THREAD is
T, a new thread is created for FUNCTION each time the timer is
triggered. If THREAD is NIL, FUNCTION is run in an unspecified thread.
When THREAD is not T, INTERRUPT-THREAD is used to run FUNCTION and the
ordering guarantees of INTERRUPT-THREAD apply. FUNCTION runs with
interrupts disabled but WITH-INTERRUPTS is allowed."
(%make-timer :name name :function function :thread thread))
(defun timer-name (timer)
#!+sb-doc
"Return the name of TIMER."
(%timer-name timer))
(defun timer-scheduled-p (timer &key (delta 0))
#!+sb-doc
"See if TIMER will still need to be triggered after DELTA seconds
from now. For timers with a repeat interval it returns true."
(symbol-macrolet ((expire-time (%timer-expire-time timer))
(repeat-interval (%timer-repeat-interval timer)))
(or (and repeat-interval (plusp repeat-interval))
(and expire-time
(<= (+ (get-internal-real-time) delta)
expire-time)))))
;;; The scheduler
(defvar *scheduler-lock* (sb!thread:make-mutex :name "Scheduler lock"))
(defmacro with-scheduler-lock ((&optional) &body body)
;; Don't let the SIGALRM handler mess things up.
`(sb!thread::with-system-mutex (*scheduler-lock*)
,@body))
(defun under-scheduler-lock-p ()
(sb!thread:holding-mutex-p *scheduler-lock*))
(defparameter *schedule* (make-priority-queue :key #'%timer-expire-time))
(defun peek-schedule ()
(priority-queue-maximum *schedule*))
(defun time-left (timer)
(- (%timer-expire-time timer) (get-internal-real-time)))
;;; real time conversion
(defun delta->real (delta)
(floor (* delta internal-time-units-per-second)))
;;; Public interface
(defun make-cancellable-interruptor (timer)
;; return a list of two functions: one that does the same as
;; FUNCTION until the other is called, from when it does nothing.
(let ((mutex (sb!thread:make-mutex))
(cancelledp nil)
(function (if (%timer-repeat-interval timer)
(lambda ()
(unwind-protect
(funcall (%timer-function timer))
(reschedule-timer timer)))
(%timer-function timer))))
(list
(lambda ()
;; Use WITHOUT-INTERRUPTS for the acquiring lock to avoid
;; unblocking deferrables unless it's inevitable.
(without-interrupts
(sb!thread:with-recursive-lock (mutex)
(unless cancelledp
(allow-with-interrupts
(funcall function))))))
(lambda ()
(sb!thread:with-recursive-lock (mutex)
(setq cancelledp t))))))
(defun %schedule-timer (timer)
(let ((changed-p nil)
(old-position (priority-queue-remove *schedule* timer)))
;; Make sure interruptors are cancelled even if this timer was
;; scheduled again since our last attempt.
(when old-position
(funcall (%timer-cancel-function timer)))
(when (eql 0 old-position)
(setq changed-p t))
(when (zerop (priority-queue-insert *schedule* timer))
(setq changed-p t))
(setf (values (%timer-interrupt-function timer)
(%timer-cancel-function timer))
(values-list (make-cancellable-interruptor timer)))
(when changed-p
(set-system-timer)))
(values))
(defun schedule-timer (timer time &key repeat-interval absolute-p)
#!+sb-doc
"Schedule TIMER to be triggered at TIME. If ABSOLUTE-P then TIME is
universal time, but non-integral values are also allowed, else TIME is
measured as the number of seconds from the current time. If
REPEAT-INTERVAL is given, TIMER is automatically rescheduled upon
expiry."
;; CANCEL-FUNCTION may block until all interruptors finish, let's
;; try to cancel without the scheduler lock first.
(when (%timer-cancel-function timer)
(funcall (%timer-cancel-function timer)))
(with-scheduler-lock ()
(setf (%timer-expire-time timer) (+ (get-internal-real-time)
(delta->real
(if absolute-p
(- time (get-universal-time))
time)))
(%timer-repeat-interval timer) (if repeat-interval
(delta->real repeat-interval)
nil))
(%schedule-timer timer)))
(defun unschedule-timer (timer)
#!+sb-doc
"Cancel TIMER. Once this function returns it is guaranteed that
TIMER shall not be triggered again and there are no unfinished
triggers."
(let ((cancel-function (%timer-cancel-function timer)))
(when cancel-function
(funcall cancel-function)))
(with-scheduler-lock ()
(setf (%timer-expire-time timer) nil
(%timer-repeat-interval timer) nil)
(let ((old-position (priority-queue-remove *schedule* timer)))
;; Don't use cancel-function as the %timer-cancel-function
;; may have changed before we got the scheduler lock.
(when old-position
(funcall (%timer-cancel-function timer)))
(when (eql 0 old-position)
(set-system-timer))))
(values))
(defun list-all-timers ()
#!+sb-doc
"Return a list of all timers in the system."
(with-scheduler-lock ()
(concatenate 'list (%pqueue-contents *schedule*))))
;;; Not public, but related
(defun reschedule-timer (timer)
;; unless unscheduled
(when (%timer-expire-time timer)
(let ((thread (%timer-thread timer)))
(if (and (sb!thread::thread-p thread)
(not (sb!thread:thread-alive-p thread)))
(unschedule-timer timer)
(with-scheduler-lock ()
;; Schedule at regular intervals. If TIMER has not finished
;; in time then it may catch up later.
(incf (%timer-expire-time timer) (%timer-repeat-interval timer))
(%schedule-timer timer))))))
;;; setitimer is unavailable for win32, but we can emulate it when
;;; threads are available -- using win32 waitable timers.
;;;
;;; Conversely, when we want to minimize signal use on POSIX, we emulate
;;; win32 waitable timers using a timerfd-like portability layer in
;;; the runtime.
#!+sb-wtimer
(define-alien-type wtimer
#!+win32 system-area-pointer ;HANDLE, but that's not defined yet
#!+sunos system-area-pointer ;struct os_wtimer *
#!+(or linux bsd) int)
#!+sb-wtimer
(progn
(define-alien-routine "os_create_wtimer" wtimer)
(define-alien-routine "os_wait_for_wtimer" int (wt wtimer))
(define-alien-routine "os_close_wtimer" void (wt wtimer))
(define-alien-routine "os_cancel_wtimer" void (wt wtimer))
(define-alien-routine "os_set_wtimer" void (wt wtimer) (sec int) (nsec int))
;; scheduler lock already protects us
(defvar *waitable-timer-handle* nil)
(defvar *timer-thread* nil)
(defun get-waitable-timer ()
(assert (under-scheduler-lock-p))
(or *waitable-timer-handle*
(prog1
(setf *waitable-timer-handle* (os-create-wtimer))
(setf *timer-thread*
(sb!thread:make-thread
(lambda ()
(loop while
(or (zerop
(os-wait-for-wtimer *waitable-timer-handle*))
*waitable-timer-handle*)
doing (run-expired-timers)))
:ephemeral t
:name "System timer watchdog thread")))))
(defun itimer-emulation-deinit ()
(with-scheduler-lock ()
(when *timer-thread*
(sb!thread:terminate-thread *timer-thread*)
(sb!thread:join-thread *timer-thread* :default nil))
(when *waitable-timer-handle*
(os-close-wtimer *waitable-timer-handle*)
(setf *waitable-timer-handle* nil))))
(defun %clear-system-timer ()
(os-cancel-wtimer (get-waitable-timer)))
(defun %set-system-timer (sec nsec)
(os-set-wtimer (get-waitable-timer) sec nsec)))
;;; Expiring timers
(defun real-time->sec-and-nsec (time)
;; KLUDGE: Always leave 0.0001 second for other stuff in order to
;; avoid starvation.
(let ((min-nsec 100000))
(if (minusp time)
(values 0 min-nsec)
(multiple-value-bind (s u) (floor time internal-time-units-per-second)
(setf u (floor (* (/ u internal-time-units-per-second)
#.(expt 10 9))))
(if (and (= 0 s) (< u min-nsec))
;; 0 0 means "shut down the timer" for setitimer
(values 0 min-nsec)
(values s u))))))
#!-(or sb-wtimer win32)
(progn
(defun %set-system-timer (sec nsec)
(sb!unix:unix-setitimer :real 0 0 sec (ceiling nsec 1000)))
(defun %clear-system-timer ()
(sb!unix:unix-setitimer :real 0 0 0 0)))
(defun set-system-timer ()
(assert (under-scheduler-lock-p))
(assert (not *interrupts-enabled*))
(let ((next-timer (peek-schedule)))
(if next-timer
(let ((delta (- (%timer-expire-time next-timer)
(get-internal-real-time))))
(multiple-value-call #'%set-system-timer
(real-time->sec-and-nsec delta)))
(%clear-system-timer))))
(defun run-timer (timer)
(let ((function (%timer-interrupt-function timer))
(thread (%timer-thread timer)))
(if (eq t thread)
(sb!thread:make-thread (without-interrupts
(allow-with-interrupts
function))
:name (format nil "Timer ~A"
(%timer-name timer)))
(let ((thread (or thread sb!thread:*current-thread*)))
(handler-case
(sb!thread:interrupt-thread thread function)
(sb!thread:interrupt-thread-error (c)
(declare (ignore c))
(warn "Timer ~S failed to interrupt thread ~S."
timer thread)))))))
;;; Called from the signal handler. We loop until all the expired timers
;;; have been run.
(defun run-expired-timers ()
(loop
(let ((now (get-internal-real-time))
(timers nil))
(flet ((run-timers ()
(dolist (timer (nreverse timers))
(run-timer timer))))
(with-scheduler-lock ()
(loop for timer = (peek-schedule)
when (or (null timer) (< now (%timer-expire-time timer)))
;; No more timers to run for now, reset the system timer.
do (run-timers)
(set-system-timer)
(return-from run-expired-timers nil)
else
do (assert (eq timer (priority-queue-extract-maximum *schedule*)))
(push timer timers)))
(run-timers)))))
(defun timeout-cerror ()
(cerror "Continue" 'sb!ext::timeout))
(defmacro sb!ext:with-timeout (expires &body body)
#!+sb-doc
"Execute the body, asynchronously interrupting it and signalling a TIMEOUT
condition after at least EXPIRES seconds have passed.
Note that it is never safe to unwind from an asynchronous condition. Consider:
(defun call-with-foo (function)
(let (foo)
(unwind-protect
(progn
(setf foo (get-foo))
(funcall function foo))
(when foo
(release-foo foo)))))
If TIMEOUT occurs after GET-FOO has executed, but before the assignment, then
RELEASE-FOO will be missed. While individual sites like this can be made proof
against asynchronous unwinds, this doesn't solve the fundamental issue, as all
the frames potentially unwound through need to be proofed, which includes both
system and application code -- and in essence proofing everything will make
the system uninterruptible."
`(dx-flet ((timeout-body () ,@body))
(let ((expires ,expires))
;; FIXME: a temporary compatibility workaround for CLX, if unsafe
;; unwinds are handled revisit it.
(if (> expires 0)
(let ((timer (make-timer #'timeout-cerror)))
(schedule-timer timer expires)
(unwind-protect (timeout-body)
(unschedule-timer timer)))
(timeout-body)))))