#lang racket/base
;; Timer drivers for os2.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/set)
(require racket/match)
(require "os2.rkt")

(provide (struct-out set-timer)
	 (struct-out timer-expired)
	 timer-driver
	 timer-relay)

;; (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 kind) #:prefab)

;; (timer-expired Any Number)
;; 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)

;; (driver-state Symbol Maybe<EID> Heap<PendingTimer>)
;; State of a timer-driver, including the identifier of the driver,
;; the currently-active subscription to ground time events (if any),
;; and the heap of all remaining timers.
(struct driver-state (self-id heap) #: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
;; system clock.

;; 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)
  (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 (send-message (timer-expired (pending-timer-label m) now))
			 (fire-timers! heap now)))
	    '()))))

;; [Symbol] -> BootK
;; Process for mapping this-level timer requests to ground-level timer
;; events and back.
(define (timer-driver self-id)
  (transition (driver-state self-id (make-timer-heap))
    (role (set (topic-subscriber (set-timer (wild) (wild) (wild)))
	       (topic-publisher (timer-expired (wild) (wild))))
      #:state state
      [(set-timer label msecs 'relative)
       (install-timer! state label (+ (current-inexact-milliseconds) msecs))]
      [(set-timer label msecs 'absolute)
       (install-timer! state label msecs)])))

;; DriverState Any AbsoluteSeconds -> Transition
(define (install-timer! state label deadline)
  (heap-add! (driver-state-heap state) (pending-timer deadline label))
  (update-time-listener! state))

;; DriverState -> Transition
(define (update-time-listener! state)
  (define next (next-timer! (driver-state-heap state)))
  (transition state
    (delete-role 'time-listener)
    (and next
	 (role (topic-subscriber (cons (timer-evt (pending-timer-deadline next)) (wild)))
	   #:name 'time-listener
	   #:state state
	   [(cons (? evt?) now)
	    (define to-send (fire-timers! (driver-state-heap state) now))
	    ;; Note: compute to-send before recursing, because of side-effects on heap
	    (sequence-actions (transition state)
	      update-time-listener!
	      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)
  (transition (relay-state 0 (hash))
    (at-meta-level
     (role (topic-subscriber (timer-expired (wild) (wild)))
       #:state (relay-state next-counter active-timers)
       [(timer-expired (list (== self-id) counter) now)
	(transition (relay-state next-counter (hash-remove active-timers counter))
	  (and (hash-has-key? active-timers counter)
	       (send-message (timer-expired (hash-ref active-timers counter) now))))]))
    (role (set (topic-subscriber (set-timer (wild) (wild) (wild)))
	       (topic-publisher (timer-expired (wild) (wild))))
      #:state (relay-state next-counter active-timers)
      [(set-timer label msecs kind)
       (transition (relay-state (+ next-counter 1) (hash-set active-timers next-counter label))
	 (at-meta-level
	  (send-message (set-timer (list self-id next-counter) msecs kind))))])))