2018-04-29 21:27:55 +00:00
|
|
|
#lang imperative-syndicate
|
|
|
|
;; Timer driver.
|
|
|
|
|
|
|
|
;; Uses mutable state internally, but because the scope of the
|
|
|
|
;; mutation is limited to each timer process alone, it's easy to show
|
|
|
|
;; correct linear use of the various pointers.
|
|
|
|
|
|
|
|
(provide (struct-out set-timer)
|
|
|
|
(struct-out timer-expired)
|
|
|
|
(struct-out later-than)
|
|
|
|
on-timeout
|
|
|
|
stop-when-timeout
|
|
|
|
sleep)
|
|
|
|
|
|
|
|
(define-logger syndicate/drivers/timer)
|
|
|
|
|
|
|
|
(require racket/set)
|
|
|
|
(require data/heap)
|
|
|
|
|
|
|
|
(message-struct set-timer (label msecs kind))
|
|
|
|
(message-struct timer-expired (label msecs))
|
|
|
|
|
|
|
|
(assertion-struct later-than (msecs))
|
|
|
|
|
|
|
|
(spawn #:name 'drivers/timer
|
|
|
|
(define control-ch (make-channel))
|
|
|
|
|
|
|
|
(thread (lambda ()
|
|
|
|
(struct pending-timer (deadline label) #:transparent)
|
|
|
|
|
|
|
|
(define heap
|
|
|
|
(make-heap (lambda (t1 t2) (<= (pending-timer-deadline t1)
|
|
|
|
(pending-timer-deadline t2)))))
|
|
|
|
|
2018-08-14 11:33:50 +00:00
|
|
|
(define timers (make-hash))
|
|
|
|
|
2018-04-29 21:27:55 +00:00
|
|
|
(define (next-timer)
|
|
|
|
(and (positive? (heap-count heap))
|
|
|
|
(heap-min heap)))
|
|
|
|
|
|
|
|
(define (fire-timers! now)
|
|
|
|
(define count-fired 0)
|
|
|
|
(let loop ()
|
|
|
|
(when (positive? (heap-count heap))
|
|
|
|
(let ((m (heap-min heap)))
|
|
|
|
(when (<= (pending-timer-deadline m) now)
|
2018-08-14 11:33:50 +00:00
|
|
|
(define label (pending-timer-label m))
|
|
|
|
(heap-remove-min! heap)
|
|
|
|
(hash-remove! timers label)
|
|
|
|
(log-syndicate/drivers/timer-debug "expired timer ~a" label)
|
|
|
|
(ground-send! (timer-expired label now))
|
|
|
|
(set! count-fired (+ count-fired 1))
|
|
|
|
(loop)))))
|
2018-04-29 21:27:55 +00:00
|
|
|
(signal-background-activity! (- count-fired)))
|
|
|
|
|
2018-08-14 11:33:50 +00:00
|
|
|
(define (clear-timer! label)
|
|
|
|
(match (hash-ref timers label #f)
|
|
|
|
[#f (void)]
|
|
|
|
[deadline
|
|
|
|
(heap-remove! heap (pending-timer deadline label))
|
|
|
|
(hash-remove! timers label)
|
|
|
|
(signal-background-activity! -1)]))
|
|
|
|
|
2018-04-29 21:27:55 +00:00
|
|
|
(define (install-timer! label deadline)
|
2018-08-14 11:33:50 +00:00
|
|
|
(clear-timer! label)
|
2018-04-29 21:27:55 +00:00
|
|
|
(heap-add! heap (pending-timer deadline label))
|
2018-08-14 11:33:50 +00:00
|
|
|
(hash-set! timers label deadline)
|
2018-04-29 21:27:55 +00:00
|
|
|
(signal-background-activity! +1))
|
|
|
|
|
|
|
|
(let loop ()
|
|
|
|
(sync (match (next-timer)
|
|
|
|
[#f never-evt]
|
|
|
|
[t (handle-evt (alarm-evt (pending-timer-deadline t))
|
|
|
|
(lambda (_dummy)
|
|
|
|
(define now (current-inexact-milliseconds))
|
|
|
|
(fire-timers! now)
|
|
|
|
(loop)))])
|
|
|
|
(handle-evt control-ch
|
|
|
|
(match-lambda
|
2018-08-14 11:33:50 +00:00
|
|
|
[(set-timer label _ 'clear)
|
|
|
|
(clear-timer! label)
|
|
|
|
(loop)]
|
2018-04-29 21:27:55 +00:00
|
|
|
[(set-timer label msecs 'relative)
|
|
|
|
(define deadline (+ (current-inexact-milliseconds) msecs))
|
|
|
|
(install-timer! label deadline)
|
|
|
|
(loop)]
|
|
|
|
[(set-timer label deadline 'absolute)
|
|
|
|
(install-timer! label deadline)
|
|
|
|
(loop)]))))))
|
|
|
|
|
|
|
|
(on (message ($ instruction (set-timer _ _ _)))
|
|
|
|
(log-syndicate/drivers/timer-debug "received instruction ~a" instruction)
|
|
|
|
(channel-put control-ch instruction))
|
|
|
|
|
|
|
|
(during (observe (later-than $msecs))
|
|
|
|
(log-syndicate/drivers/timer-debug "observing (later-than ~a) at ~a"
|
|
|
|
msecs
|
|
|
|
(current-inexact-milliseconds))
|
|
|
|
(define timer-id (gensym 'timestate))
|
|
|
|
(on-start (send! (set-timer timer-id msecs 'absolute)))
|
2018-08-14 11:33:50 +00:00
|
|
|
(on-stop (send! (set-timer timer-id msecs 'clear)))
|
2018-04-29 21:27:55 +00:00
|
|
|
(on (message (timer-expired timer-id _))
|
|
|
|
(react (assert (later-than msecs))))))
|
|
|
|
|
|
|
|
(define-syntax-rule (on-timeout relative-msecs body ...)
|
|
|
|
(let ((timer-id (gensym 'timeout)))
|
|
|
|
(on-start (send! (set-timer timer-id relative-msecs 'relative)))
|
|
|
|
(on (message (timer-expired timer-id _)) body ...)))
|
|
|
|
|
|
|
|
(define-syntax-rule (stop-when-timeout relative-msecs body ...)
|
|
|
|
(on-timeout relative-msecs (stop-current-facet body ...)))
|
|
|
|
|
|
|
|
(define (sleep sec)
|
|
|
|
(define timer-id (gensym 'sleep))
|
|
|
|
(until (message (timer-expired timer-id _))
|
|
|
|
(on-start (send! (set-timer timer-id (* sec 1000.0) 'relative)))))
|