Port timer driver from older syndicate/rkt implementation
This commit is contained in:
parent
ee5a5d9f5f
commit
82648dc0da
|
@ -0,0 +1,124 @@
|
||||||
|
#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)
|
||||||
|
spawn-timer-driver
|
||||||
|
on-timeout
|
||||||
|
stop-when-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)
|
||||||
|
|
||||||
|
(define spawn-timer-driver
|
||||||
|
(action (ds)
|
||||||
|
(spawn
|
||||||
|
#:name 'timer-driver
|
||||||
|
#:daemon? #t
|
||||||
|
|
||||||
|
(define control-ch (make-channel))
|
||||||
|
|
||||||
|
(linked-thread
|
||||||
|
#:name 'timer-driver-thread
|
||||||
|
this-turn
|
||||||
|
(ref (entity #:name 'timer-monitor #:retract (action (_handle) (stop-current-facet))))
|
||||||
|
(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)
|
||||||
|
(turn-freshen this-turn (action () (send! ds (TimerExpired label now))))
|
||||||
|
(set! count-fired (+ count-fired 1))
|
||||||
|
(loop)))))
|
||||||
|
(adjust-inhabitant-count! (actor-engine this-actor) (- 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! (actor-engine this-actor) -1)]))
|
||||||
|
|
||||||
|
(define (install-timer! label deadline)
|
||||||
|
(clear-timer! label)
|
||||||
|
(heap-add! heap (pending-timer deadline label))
|
||||||
|
(hash-set! timers label deadline)
|
||||||
|
(adjust-inhabitant-count! (actor-engine this-actor) 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
|
||||||
|
(when (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! ds (SetTimer timer-id msecs (TimerKind-absolute))))
|
||||||
|
(on-stop (send! ds (SetTimer timer-id msecs (TimerKind-clear))))
|
||||||
|
(at ds
|
||||||
|
(when (message (TimerExpired timer-id _))
|
||||||
|
(react (at ds (assert (LaterThan msecs)))))))))))
|
||||||
|
|
||||||
|
(define-syntax-rule (on-timeout relative-msecs body ...)
|
||||||
|
(let ((timer-id (gensym 'timeout)))
|
||||||
|
(on-start (send! this-target (SetTimer timer-id relative-msecs (TimerKind-relative))))
|
||||||
|
(at this-target
|
||||||
|
(when (message (TimerExpired timer-id _))
|
||||||
|
body ...))))
|
||||||
|
|
||||||
|
(define-syntax-rule (stop-when-timeout relative-msecs body ...)
|
||||||
|
(on-timeout relative-msecs (stop-current-facet body ...)))
|
||||||
|
|
||||||
|
(module+ main
|
||||||
|
(actor-system/dataspace (ds)
|
||||||
|
(spawn-timer-driver this-turn ds)
|
||||||
|
(spawn (at ds
|
||||||
|
(stop-when-timeout 2000
|
||||||
|
(log-info "hi!"))))))
|
|
@ -0,0 +1,7 @@
|
||||||
|
version 1 .
|
||||||
|
|
||||||
|
SetTimer = <set-timer @label any @msecs double @kind TimerKind>.
|
||||||
|
TimerExpired = <timer-expired @label any @msecs double>.
|
||||||
|
TimerKind = =relative / =absolute / =clear .
|
||||||
|
|
||||||
|
LaterThan = <later-than @msecs double>.
|
Loading…
Reference in New Issue