Port timer driver from older syndicate/rkt implementation

syndicate/drivers/timer.rkt

@@ -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!"))))))

syndicate/schemas/timer.prs

@@ -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>.