Use a heap to change O(n) active subscriptions to O(1).

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<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
 ;; 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<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
-;; 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?)))]))))