129 lines
5.0 KiB
Racket
129 lines
5.0 KiB
Racket
#lang racket/base
|
|
;; Timer driver.
|
|
|
|
;; 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 racket/set)
|
|
(require racket/match)
|
|
(require data/heap)
|
|
(require "../main.rkt")
|
|
|
|
(struct pending-timer (deadline label) #:transparent)
|
|
|
|
(provide (struct-out set-timer)
|
|
(struct-out timer-expired)
|
|
spawn-timer-driver)
|
|
|
|
(struct set-timer (label msecs kind) #:prefab)
|
|
(struct timer-expired (label msecs) #:prefab)
|
|
|
|
(define expiry-projection (at-meta (?! (timer-expired ? ?))))
|
|
|
|
(define (spawn-timer-driver)
|
|
(define control-ch (make-channel))
|
|
(thread (lambda () (timer-driver-thread-main control-ch)))
|
|
(define (timer-driver e count)
|
|
(match e
|
|
[(patch added _removed)
|
|
;; Previously, this driver caused the background thread to call
|
|
;; send-ground-message to indicate that a timer had expired.
|
|
;; However, this can lead to a race! In cases where a timer
|
|
;; expires very soon, the channel-put of the set-timer
|
|
;; instruction leads shortly thereafter to a
|
|
;; send-ground-message which then races the establishment of
|
|
;; the metalevel-1 subscription to the timer-expired events
|
|
;; that are coming from the background thread.
|
|
;;
|
|
;; The race cannot occur in the sequential implementation
|
|
;; because the network makes sure to enqueue the transition
|
|
;; actions resulting from the set-timer message delivery ahead
|
|
;; of any enqueueing of the timer-expired ground message, so
|
|
;; that by the time the ground message is processed, the
|
|
;; relevant subscription always exists.
|
|
;;
|
|
;; In a looser implementation, however, this level of
|
|
;; synchronised activity may not exist, and the ground message
|
|
;; may overtake the subscription establishment.
|
|
;;
|
|
;; Therefore, I've changed the driver to instead use ground
|
|
;; /assertions/ to signal expired timers. Upon processing of
|
|
;; such an assertion, the driver cleans it up. This is very
|
|
;; similar to hardware interrupts, where the driver has to
|
|
;; "clear the interrupt" in order to let the system continue
|
|
;; properly.
|
|
(define-values (new-count actions-rev interrupt-clearing-patch)
|
|
(for/fold [(count count)
|
|
(actions-rev '())
|
|
(interrupt-clearing-patch patch-empty)]
|
|
[(expiry (trie-project/set/single added expiry-projection))]
|
|
(values (- count 1)
|
|
(cons (message expiry) actions-rev)
|
|
(patch-seq interrupt-clearing-patch
|
|
(retract expiry)))))
|
|
(send-ground-patch interrupt-clearing-patch)
|
|
(transition new-count
|
|
(cons (reverse actions-rev)
|
|
(when (zero? new-count) (unsub (timer-expired ? ?) #:meta-level 1))))]
|
|
[(message (and instruction (set-timer _ _ _)))
|
|
(channel-put control-ch instruction)
|
|
(transition (+ count 1)
|
|
(when (= count 0) (sub (timer-expired ? ?) #:meta-level 1)))]
|
|
[_ #f]))
|
|
(spawn timer-driver
|
|
0 ;; initial count
|
|
(patch-seq (sub (set-timer ? ? ?))
|
|
(pub (timer-expired ? ?)))))
|
|
|
|
(define (timer-driver-thread-main control-ch)
|
|
(define heap (make-timer-heap))
|
|
(let loop ()
|
|
(sync (match (next-timer heap)
|
|
[#f never-evt]
|
|
[t (handle-evt (timer-evt (pending-timer-deadline t))
|
|
(lambda (now)
|
|
(send-ground-patch
|
|
(for/fold [(interrupt-asserting-patch patch-empty)]
|
|
[(expiry (fire-timers! heap now))]
|
|
(patch-seq interrupt-asserting-patch (assert expiry))))
|
|
(loop)))])
|
|
(handle-evt control-ch
|
|
(match-lambda
|
|
[(set-timer label msecs 'relative)
|
|
(install-timer! heap label (+ (current-inexact-milliseconds) msecs))
|
|
(loop)]
|
|
[(set-timer label msecs 'absolute)
|
|
(install-timer! heap label msecs)
|
|
(loop)]
|
|
['quit (void)])))))
|
|
|
|
(define (make-timer-heap)
|
|
(make-heap (lambda (t1 t2) (<= (pending-timer-deadline t1) (pending-timer-deadline t2)))))
|
|
|
|
(define (next-timer heap)
|
|
(and (positive? (heap-count heap))
|
|
(heap-min heap)))
|
|
|
|
(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)))
|
|
'()))))
|
|
|
|
(define (install-timer! heap label deadline)
|
|
(define now (current-inexact-milliseconds))
|
|
(heap-add! heap (pending-timer deadline label)))
|
|
|
|
;; 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)
|
|
(handle-evt (alarm-evt msecs)
|
|
(lambda (_) (current-inexact-milliseconds))))
|