#lang racket/base
;; Timer drivers for os.rkt

(require racket/match)
(require "os-big-bang.rkt")

(provide (struct-out set-timer)
	 (struct-out timer-expired)
	 timer-driver
	 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.
(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.
(struct timer-expired (label msecs) #:prefab)

;; 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 relative?)
  (wrap-evt (alarm-evt (if relative? (+ (current-inexact-milliseconds) msecs) msecs))
	    (lambda (_) (current-inexact-milliseconds))))

;; [Symbol] -> BootK
;; Process for mapping this-level timer requests to meta-level timer
;; events and back.
(define (timer-driver [self-id 'timer-driver])
  (os-big-bang 'no-state
    (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)))])))]))))

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