diff --git a/os-timer.rkt b/os-timer.rkt index 2542d60..6691a14 100644 --- a/os-timer.rkt +++ b/os-timer.rkt @@ -1,6 +1,11 @@ #lang racket/base -;; Timer drivers for os.rkt +;; Timer drivers for os.rkt. +;; 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. + +(require data/heap) (require racket/match) (require "os-big-bang.rkt") @@ -10,17 +15,26 @@ 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. +;; The timer driver and timer relays listen for messages of this type, +;; and when they hear one, they set 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. +;; Message sent by the timer driver or a timer relay 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) +;; (pending-timer AbsoluteSeconds Any Boolean) +;; An outstanding timer being managed by the timer-driver. +(struct pending-timer (deadline label) #:transparent) + +;; (relay-state ExactPositiveInteger Hash) +;; State of a timer-relay, including the next timer number and a +;; mapping from timer number to timer label. +(struct relay-state (next-counter active-timers) #:transparent) + ;; 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 @@ -30,43 +44,78 @@ ;; 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)) +(define (timer-evt msecs) + (wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds)))) +;; -> Heap +(define (make-timer-heap) + (make-heap (lambda (t1 t2) (<= (pending-timer-deadline t1) (pending-timer-deadline t2))))) + +;; Heap -> Maybe +;; Retrieves the earliest-deadline timer from the heap, if there is +;; one. +(define (next-timer! heap) + (if (zero? (heap-count heap)) + #f + (heap-min heap))) + +;; Heap AbsoluteSeconds -> ListOf +;; Retrieves (and removes) all timers from the heap that have deadline +;; earlier or equal to the time passed in. +(define (fire-timers! heap now) + (if (zero? (heap-count heap)) + '() + (let ((m (heap-min heap))) + (if (<= (pending-timer-deadline m) now) + (begin (heap-remove-min! heap) + (cons (timer-expired (pending-timer-label m) now) + (fire-timers! heap now))) + '())))) + ;; [Symbol] -> BootK -;; Process for mapping this-level timer requests to meta-level timer +;; Process for mapping this-level timer requests to ground-level timer ;; events and back. -(define (timer-driver [self-id 'timer-driver]) - (os-big-bang 'no-state +(define (timer-driver self-id) + (os-big-bang (make-timer-heap) (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)))])))])))) + (message-handlers heap + [(set-timer label msecs relative?) + (define deadline (if relative? (+ (current-inexact-milliseconds) msecs) msecs)) + (define new-timer (pending-timer deadline label)) + (heap-add! heap new-timer) + (let loop ((heap heap)) + (define next (next-timer! heap)) + (transition heap + (unsubscribe 'time-listener) + (if next + (subscribe 'time-listener + (ground-message-handler heap + [((list self-id 'time-listener) + (timer-evt (pending-timer-deadline next)) + => now) + (define to-send (fire-timers! heap now)) + ;; Note: compute to-send before calling loop, because of side-effects on heap + (extend-transition (loop heap) (map send-message to-send))])) + '())))])))) ;; [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)))])))])))) +(define (timer-relay self-id) + (os-big-bang (relay-state 0 (hash)) + (subscribe 'timer-relay-up + (meta-message-handlers (relay-state next-counter active-timers) + [(timer-expired (list (== self-id) counter) now) + (if (hash-has-key? active-timers counter) + (transition (relay-state next-counter + (hash-remove active-timers counter)) + (send-message (timer-expired (hash-ref active-timers counter) now))) + active-timers)])) + (subscribe 'timer-relay-down + (message-handlers (relay-state next-counter active-timers) + [(set-timer label msecs relative?) + (transition (relay-state (+ next-counter 1) + (hash-set active-timers next-counter label)) + (send-meta-message (set-timer (list self-id next-counter) msecs relative?)))]))))