73 lines
2.5 KiB
Racket
73 lines
2.5 KiB
Racket
#lang racket/base
|
|
;; Timer drivers for os.rkt
|
|
|
|
(require racket/match)
|
|
(require "os-big-bang.rkt")
|
|
|
|
(provide (struct-out set-timer)
|
|
(struct-out timer-expired)
|
|
timer-driver
|
|
timer-relay)
|
|
|
|
;; (set-timer Any Number Boolean)
|
|
;; The timer driver listens for messages of this type, and when it
|
|
;; hears one, sets an alarm that will later send a corresponding
|
|
;; timer-expired message.
|
|
(struct set-timer (label msecs relative?) #:prefab)
|
|
|
|
;; (timer-expired Any Number)
|
|
;; Message sent by the timer driver upon expiry of a timer. Contains
|
|
;; the label specified in the corresponding set-timer message, and
|
|
;; also the current absolute time from the outside world.
|
|
(struct timer-expired (label msecs) #:prefab)
|
|
|
|
;; Note that (set-timer 'current-time 0 #f) causes an immediate reply
|
|
;; of (timer-expired 'current-time (current-inexact-milliseconds)),
|
|
;; which can be used for an event-oriented interface to reading the
|
|
;; system clock.
|
|
|
|
;; Racket's alarm-evt is almost the right design for timeouts: its
|
|
;; synchronisation value should be the (or some) value of the clock
|
|
;; after the asked-for time. That way it serves as timeout and
|
|
;; clock-reader in one.
|
|
(define (timer-evt msecs relative?)
|
|
(wrap-evt (alarm-evt (if relative? (+ (current-inexact-milliseconds) msecs) msecs))
|
|
(lambda (_) (current-inexact-milliseconds))))
|
|
|
|
;; [Symbol] -> BootK
|
|
;; Process for mapping this-level timer requests to meta-level timer
|
|
;; events and back.
|
|
(define (timer-driver [self-id 'timer-driver])
|
|
(os-big-bang 'no-state
|
|
(subscribe 'timer-setter
|
|
(message-handlers w
|
|
[(set-timer reply-label msecs relative?)
|
|
(transition w
|
|
(subscribe/fresh label
|
|
(ground-message-handler w
|
|
[((list self-id label)
|
|
(timer-evt msecs relative?)
|
|
=> now)
|
|
(transition w
|
|
(unsubscribe label)
|
|
(send-message (timer-expired reply-label now)))])))]))))
|
|
|
|
;; [Symbol] -> BootK
|
|
;; Process for mapping this-level timer requests to meta-level timer
|
|
;; requests. Useful when running nested VMs: essentially extends timer
|
|
;; support up the branches of the VM tree toward the leaves.
|
|
(define (timer-relay [self-id 'timer-relay])
|
|
(os-big-bang 'no-state
|
|
(subscribe 'timer-relay
|
|
(message-handlers w
|
|
[(set-timer reply-label msecs relative?)
|
|
(define timer-id (list self-id reply-label))
|
|
(transition w
|
|
(send-meta-message (set-timer timer-id msecs relative?))
|
|
(subscribe/fresh label
|
|
(meta-message-handlers w
|
|
[(timer-expired (== timer-id) now)
|
|
(transition w
|
|
(unsubscribe label)
|
|
(send-message (timer-expired reply-label now)))])))]))))
|