Use a heap to change O(n) active subscriptions to O(1).
This commit is contained in:
parent
b3c2dd96d3
commit
481db45230
123
os-timer.rkt
123
os-timer.rkt
|
@ -1,6 +1,11 @@
|
||||||
#lang racket/base
|
#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 racket/match)
|
||||||
(require "os-big-bang.rkt")
|
(require "os-big-bang.rkt")
|
||||||
|
|
||||||
|
@ -10,17 +15,26 @@
|
||||||
timer-relay)
|
timer-relay)
|
||||||
|
|
||||||
;; (set-timer Any Number Boolean)
|
;; (set-timer Any Number Boolean)
|
||||||
;; The timer driver listens for messages of this type, and when it
|
;; The timer driver and timer relays listen for messages of this type,
|
||||||
;; hears one, sets an alarm that will later send a corresponding
|
;; and when they hear one, they set an alarm that will later send a
|
||||||
;; timer-expired message.
|
;; corresponding timer-expired message.
|
||||||
(struct set-timer (label msecs relative?) #:prefab)
|
(struct set-timer (label msecs relative?) #:prefab)
|
||||||
|
|
||||||
;; (timer-expired Any Number)
|
;; (timer-expired Any Number)
|
||||||
;; Message sent by the timer driver upon expiry of a timer. Contains
|
;; Message sent by the timer driver or a timer relay upon expiry of a
|
||||||
;; the label specified in the corresponding set-timer message, and
|
;; timer. Contains the label specified in the corresponding set-timer
|
||||||
;; also the current absolute time from the outside world.
|
;; message, and also the current absolute time from the outside world.
|
||||||
(struct timer-expired (label msecs) #:prefab)
|
(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<ExactPositiveInteger,Any>)
|
||||||
|
;; 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
|
;; Note that (set-timer 'current-time 0 #f) causes an immediate reply
|
||||||
;; of (timer-expired 'current-time (current-inexact-milliseconds)),
|
;; of (timer-expired 'current-time (current-inexact-milliseconds)),
|
||||||
;; which can be used for an event-oriented interface to reading the
|
;; 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
|
;; synchronisation value should be the (or some) value of the clock
|
||||||
;; after the asked-for time. That way it serves as timeout and
|
;; after the asked-for time. That way it serves as timeout and
|
||||||
;; clock-reader in one.
|
;; clock-reader in one.
|
||||||
(define (timer-evt msecs relative?)
|
(define (timer-evt msecs)
|
||||||
(wrap-evt (alarm-evt (if relative? (+ (current-inexact-milliseconds) msecs) msecs))
|
(wrap-evt (alarm-evt msecs)
|
||||||
(lambda (_) (current-inexact-milliseconds))))
|
(lambda (_) (current-inexact-milliseconds))))
|
||||||
|
|
||||||
|
;; -> Heap<PendingTimer>
|
||||||
|
(define (make-timer-heap)
|
||||||
|
(make-heap (lambda (t1 t2) (<= (pending-timer-deadline t1) (pending-timer-deadline t2)))))
|
||||||
|
|
||||||
|
;; Heap<PendingTimer> -> Maybe<PendingTimer>
|
||||||
|
;; 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<PendingTimer> AbsoluteSeconds -> ListOf<TimerExpired>
|
||||||
|
;; 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
|
;; [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.
|
;; events and back.
|
||||||
(define (timer-driver [self-id 'timer-driver])
|
(define (timer-driver self-id)
|
||||||
(os-big-bang 'no-state
|
(os-big-bang (make-timer-heap)
|
||||||
(subscribe 'timer-setter
|
(subscribe 'timer-setter
|
||||||
(message-handlers w
|
(message-handlers heap
|
||||||
[(set-timer reply-label msecs relative?)
|
[(set-timer label msecs relative?)
|
||||||
(transition w
|
(define deadline (if relative? (+ (current-inexact-milliseconds) msecs) msecs))
|
||||||
(subscribe/fresh label
|
(define new-timer (pending-timer deadline label))
|
||||||
(ground-message-handler w
|
(heap-add! heap new-timer)
|
||||||
[((list self-id label)
|
(let loop ((heap heap))
|
||||||
(timer-evt msecs relative?)
|
(define next (next-timer! heap))
|
||||||
=> now)
|
(transition heap
|
||||||
(transition w
|
(unsubscribe 'time-listener)
|
||||||
(unsubscribe label)
|
(if next
|
||||||
(send-message (timer-expired reply-label now)))])))]))))
|
(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
|
;; [Symbol] -> BootK
|
||||||
;; Process for mapping this-level timer requests to meta-level timer
|
;; Process for mapping this-level timer requests to meta-level timer
|
||||||
;; requests. Useful when running nested VMs: essentially extends timer
|
;; requests. Useful when running nested VMs: essentially extends timer
|
||||||
;; support up the branches of the VM tree toward the leaves.
|
;; support up the branches of the VM tree toward the leaves.
|
||||||
(define (timer-relay [self-id 'timer-relay])
|
(define (timer-relay self-id)
|
||||||
(os-big-bang 'no-state
|
(os-big-bang (relay-state 0 (hash))
|
||||||
(subscribe 'timer-relay
|
(subscribe 'timer-relay-up
|
||||||
(message-handlers w
|
(meta-message-handlers (relay-state next-counter active-timers)
|
||||||
[(set-timer reply-label msecs relative?)
|
[(timer-expired (list (== self-id) counter) now)
|
||||||
(define timer-id (list self-id reply-label))
|
(if (hash-has-key? active-timers counter)
|
||||||
(transition w
|
(transition (relay-state next-counter
|
||||||
(send-meta-message (set-timer timer-id msecs relative?))
|
(hash-remove active-timers counter))
|
||||||
(subscribe/fresh label
|
(send-message (timer-expired (hash-ref active-timers counter) now)))
|
||||||
(meta-message-handlers w
|
active-timers)]))
|
||||||
[(timer-expired (== timer-id) now)
|
(subscribe 'timer-relay-down
|
||||||
(transition w
|
(message-handlers (relay-state next-counter active-timers)
|
||||||
(unsubscribe label)
|
[(set-timer label msecs relative?)
|
||||||
(send-message (timer-expired reply-label now)))])))]))))
|
(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?)))]))))
|
||||||
|
|
Loading…
Reference in New Issue