From af941dc8d15ef1a94601f1960ffa6512b4aaf2d9 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sun, 19 Feb 2012 17:09:23 -0500 Subject: [PATCH] Switch to symbolic specification of relative timeouts --- os-timer.rkt | 53 ++++++++++++++++++++++++++++++---------------------- 1 file changed, 31 insertions(+), 22 deletions(-) diff --git a/os-timer.rkt b/os-timer.rkt index 6691a14..f9a058d 100644 --- a/os-timer.rkt +++ b/os-timer.rkt @@ -14,11 +14,11 @@ timer-driver timer-relay) -;; (set-timer Any Number Boolean) +;; (set-timer Any Number (or 'relative 'absolute)) ;; 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) +(struct set-timer (label msecs kind) #:prefab) ;; (timer-expired Any Number) ;; Message sent by the timer driver or a timer relay upon expiry of a @@ -80,24 +80,33 @@ (os-big-bang (make-timer-heap) (subscribe 'timer-setter (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))])) - '())))])))) + [(set-timer label msecs 'relative) + (install-timer! self-id heap label (+ (current-inexact-milliseconds) msecs))] + [(set-timer label msecs 'absolute) + (install-timer! self-id heap label msecs)])))) + +;; Symbol Heap Any AbsoluteSeconds -> Transition +(define (install-timer! self-id heap label deadline) + (define new-timer (pending-timer deadline label)) + (heap-add! heap new-timer) + (update-time-listener! self-id heap)) + +;; Symbol Heap -> Transition +(define (update-time-listener! self-id 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 recursing, because of side-effects on heap + (extend-transition (update-time-listener! self-id heap) + (map send-message to-send))])) + '()))) ;; [Symbol] -> BootK ;; Process for mapping this-level timer requests to meta-level timer @@ -115,7 +124,7 @@ active-timers)])) (subscribe 'timer-relay-down (message-handlers (relay-state next-counter active-timers) - [(set-timer label msecs relative?) + [(set-timer label msecs kind) (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?)))])))) + (send-meta-message (set-timer (list self-id next-counter) msecs kind)))]))))