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