syndicate-rkt/syndicate/drivers/timer.rkt

120 lines
5.0 KiB
Racket

;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#lang 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)))))
(define timers (make-hash))
(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)
(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)))))
(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 ()
(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
[(set-timer label _ 'clear)
(clear-timer! label)
(loop)]
[(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)))
(on-stop (send! (set-timer timer-id msecs 'clear)))
(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)))))