Clear no-longer-interesting timers
This commit is contained in:
parent
979d057f3f
commit
e9457af8c2
|
@ -32,6 +32,8 @@
|
||||||
(make-heap (lambda (t1 t2) (<= (pending-timer-deadline t1)
|
(make-heap (lambda (t1 t2) (<= (pending-timer-deadline t1)
|
||||||
(pending-timer-deadline t2)))))
|
(pending-timer-deadline t2)))))
|
||||||
|
|
||||||
|
(define timers (make-hash))
|
||||||
|
|
||||||
(define (next-timer)
|
(define (next-timer)
|
||||||
(and (positive? (heap-count heap))
|
(and (positive? (heap-count heap))
|
||||||
(heap-min heap)))
|
(heap-min heap)))
|
||||||
|
@ -42,16 +44,27 @@
|
||||||
(when (positive? (heap-count heap))
|
(when (positive? (heap-count heap))
|
||||||
(let ((m (heap-min heap)))
|
(let ((m (heap-min heap)))
|
||||||
(when (<= (pending-timer-deadline m) now)
|
(when (<= (pending-timer-deadline m) now)
|
||||||
(begin (heap-remove-min! heap)
|
(define label (pending-timer-label m))
|
||||||
(log-syndicate/drivers/timer-debug "expired timer ~a"
|
(heap-remove-min! heap)
|
||||||
(pending-timer-label m))
|
(hash-remove! timers label)
|
||||||
(ground-send! (timer-expired (pending-timer-label m) now))
|
(log-syndicate/drivers/timer-debug "expired timer ~a" label)
|
||||||
(set! count-fired (+ count-fired 1))
|
(ground-send! (timer-expired label now))
|
||||||
(loop))))))
|
(set! count-fired (+ count-fired 1))
|
||||||
|
(loop)))))
|
||||||
(signal-background-activity! (- count-fired)))
|
(signal-background-activity! (- count-fired)))
|
||||||
|
|
||||||
|
(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)]))
|
||||||
|
|
||||||
(define (install-timer! label deadline)
|
(define (install-timer! label deadline)
|
||||||
|
(clear-timer! label)
|
||||||
(heap-add! heap (pending-timer deadline label))
|
(heap-add! heap (pending-timer deadline label))
|
||||||
|
(hash-set! timers label deadline)
|
||||||
(signal-background-activity! +1))
|
(signal-background-activity! +1))
|
||||||
|
|
||||||
(let loop ()
|
(let loop ()
|
||||||
|
@ -64,6 +77,9 @@
|
||||||
(loop)))])
|
(loop)))])
|
||||||
(handle-evt control-ch
|
(handle-evt control-ch
|
||||||
(match-lambda
|
(match-lambda
|
||||||
|
[(set-timer label _ 'clear)
|
||||||
|
(clear-timer! label)
|
||||||
|
(loop)]
|
||||||
[(set-timer label msecs 'relative)
|
[(set-timer label msecs 'relative)
|
||||||
(define deadline (+ (current-inexact-milliseconds) msecs))
|
(define deadline (+ (current-inexact-milliseconds) msecs))
|
||||||
(install-timer! label deadline)
|
(install-timer! label deadline)
|
||||||
|
@ -82,9 +98,7 @@
|
||||||
(current-inexact-milliseconds))
|
(current-inexact-milliseconds))
|
||||||
(define timer-id (gensym 'timestate))
|
(define timer-id (gensym 'timestate))
|
||||||
(on-start (send! (set-timer timer-id msecs 'absolute)))
|
(on-start (send! (set-timer timer-id msecs 'absolute)))
|
||||||
;; TODO: on-stop to delete irrelevant timers, so that their background-activity is
|
(on-stop (send! (set-timer timer-id msecs 'clear)))
|
||||||
;; removed, so that programs don't stay running uselessly while previously-set but
|
|
||||||
;; now-unwanted timers expire unobserved.
|
|
||||||
(on (message (timer-expired timer-id _))
|
(on (message (timer-expired timer-id _))
|
||||||
(react (assert (later-than msecs))))))
|
(react (assert (later-than msecs))))))
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue