107 lines
4.1 KiB
Racket
107 lines
4.1 KiB
Racket
#lang syndicate
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2018-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
|
|
(provide (all-from-out syndicate/schemas/gen/timer)
|
|
timeout)
|
|
|
|
(require syndicate/driver-support)
|
|
(require syndicate/engine)
|
|
(require syndicate/schemas/gen/timer)
|
|
(require syndicate/schemas/gen/dataspace-patterns)
|
|
(require data/heap)
|
|
|
|
(define-logger syndicate/drivers/timer)
|
|
|
|
(provide-service [ds]
|
|
(define control-ch (make-channel))
|
|
|
|
(linked-thread
|
|
#:name 'timer-driver-thread
|
|
(lambda (facet)
|
|
(struct pending-timer (deadline label) #:transparent)
|
|
|
|
(define engine (actor-engine (facet-actor facet)))
|
|
|
|
(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)
|
|
(turn! facet (lambda () (send! ds (TimerExpired label now))))
|
|
(set! count-fired (+ count-fired 1))
|
|
(loop)))))
|
|
(adjust-inhabitant-count! engine (- 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)
|
|
(adjust-inhabitant-count! engine -1)]))
|
|
|
|
(define (install-timer! label deadline)
|
|
(clear-timer! label)
|
|
(heap-add! heap (pending-timer deadline label))
|
|
(hash-set! timers label deadline)
|
|
(adjust-inhabitant-count! engine 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
|
|
(lambda (m)
|
|
(match (parse-SetTimer m)
|
|
[(SetTimer label _ (TimerKind-clear))
|
|
(clear-timer! label)
|
|
(loop)]
|
|
[(SetTimer label msecs (TimerKind-relative))
|
|
(define deadline (+ (current-inexact-milliseconds) msecs))
|
|
(install-timer! label deadline)
|
|
(loop)]
|
|
[(SetTimer label deadline (TimerKind-absolute))
|
|
(install-timer! label deadline)
|
|
(loop)])))))))
|
|
|
|
(at ds
|
|
(on (message ($ instruction (SetTimer _ _ _)))
|
|
(log-syndicate/drivers/timer-debug "received instruction ~a" instruction)
|
|
(channel-put control-ch instruction))
|
|
|
|
(during (Observe (:pattern (LaterThan ,(DLit $msecs))) _)
|
|
(log-syndicate/drivers/timer-debug "observing (later-than ~a) at ~a"
|
|
msecs
|
|
(current-inexact-milliseconds))
|
|
(define timer-id (gensym 'timestate))
|
|
(on-start (send! (SetTimer timer-id msecs (TimerKind-absolute))))
|
|
(on-stop (send! (SetTimer timer-id msecs (TimerKind-clear))))
|
|
(on (message (TimerExpired timer-id _))
|
|
(react (assert (LaterThan msecs)))))))
|
|
|
|
(define-event-expander timeout
|
|
(syntax-rules ()
|
|
[(_ [relative-msecs] body ...)
|
|
(let ((timer-id (gensym 'timeout)))
|
|
(on-start (send! (SetTimer timer-id relative-msecs (TimerKind-relative))))
|
|
(on (message (TimerExpired timer-id _)) body ...))]))
|