racket-dns-2012/os.rkt

#lang racket/base

;; Virtualized operating system.

(require racket/match)
(require racket/list)
(require "functional-queue.rkt")

(provide
 ;; Actions/Events
 (struct-out message)
 (struct-out process)

 ;; Kernel Events
 (struct-out meta-message)

 ;; Event handlers and kernel requests
 (struct-out event-handler)
 (struct-out kernel-mode-transition)

 ;; VMs
 make-vm
 run-vm
)

;; Each VM hosts 0 or more *multiplexed* processes. Each process has
;; its own state record. In between schedulings, a process consists of
;; 1 or more event handlers. An event handler is a pair of an event
;; recogniser and a procedure taking an event and a process state to a
;; new process state.
;;
;; Each VM provides a *communication bus* for its processes to
;; use. The communication bus is the only form of IPC the VM provides.
;;
;; Some processes *relay* messages out from the VM to other
;; VMs. Because the "tree" of VMs so formed has to be a tree - See
;; Shivers & Might 2006 for a discussion of this - we gather together
;; all the interactions between the supervenient VM and its support VM
;; into a single channel of communication. The relaying processes are,
;; in effect, device-drivers, providing application-specific
;; communication services to other processes in the VM.
;;
;; We split processes into "user" processes, permitted only to spawn
;; other user processes and send messages on the VM's bus, and
;; "kernel" processes, permitted also to spawn other kernel processes
;; and send messages to the VM's container.
;;
;; Time plays an interesting role in a distributed system: if the
;; medium messages are sent through isn't cooperative enough to let us
;; know of a failed conversational participant, our only recourse is
;; /timeout/. Therefore, we require every level of the machine to
;; support timeouts, though we do not require such timeouts to be tied
;; to real, wall-clock time: simulated time is just fine. This helps
;; with testability.
;;
;; 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.

;; VMs are parameterised over:
;;  - the type of messages carried on the bus, Message
;;  - the type of patterns over Messages, MessageEvent
;;  - the type of messages to other VMs, MetaMessage
;;  - the type of patterns over MetaMessages, MetaMessageEvent

;; A VM is a (vm ListBagOf<Subscription>
;;               QueueOf<Event>). ;; TODO: make unordered?
(struct vm (subscriptions pending-events) #:transparent)

;; A UserEvent is one of
;; -- (message Message), a message emitted onto the bus
;; -- (process BootK), a new sibling process to start
(struct message (body) #:transparent)
(struct process (boot) #:transparent)

;; A KernelEvent is one of
;; -- (meta-message MetaMessage), a message emitted onto the
;; containing bus
(struct meta-message (body) #:transparent)

;; An Event is a UserEvent or a KernelEvent.

;; An EventHandler is an (event-handler Boolean (Event -> Boolean) TrapK<Event>)
(struct event-handler (meta? matcher k) #:transparent)

;; A TrapK<X> is a X -> InterruptK, representing a suspended process
;; waiting for some information from the VM before it can continue.

;; An InterruptK is a
;;   ProcessState -> KernelModeTransition
;; representing a suspended process that can run instantly without
;; waiting for more information from the VM. The input is the state of
;; the process, and the output is the information passed back to the
;; VM when the process yields the CPU.

;; A BootK is a ( -> KernelModeTransition), effectively an InterruptK
;; with a void initial process state.

;; A KernelModeTransition is a
;; (kernel-mode-transition ProcessState
;;                         ListBagOf<Event>
;;			   ListBagOf<EventHandler>)
;; representing a new process state, a list of events to emit and a
;; list of events to wait for before resuming the process taking the
;; transition.
(struct kernel-mode-transition (state
				events
				event-handlers) #:transparent)

;; A ListBagOf<X> is a ListOf<X> with the additional constraint that
;; order isn't meaningful.

;; A Subscription is a (subscription ProcessState ListBagOf<EventHandler>).
(struct subscription (state event-handlers) #:transparent)

;; TODO: is timeout really primitive? If so, isn't presence primitive?
;; TODO: what about metatimeout?
;; TODO: what about spawn-meta-process etc? Come back to this later.

;; TODO: enforce user-mode restrictions

;; TODO: timeouts

(define (make-vm boot)
  (boot-process boot (vm (list) (make-queue))))

(define (subscribe-process process-state event-handlers state)
  (if (null? event-handlers)
      state ;; dead process because no continuations offered
      (struct-copy vm state [subscriptions (cons (subscription process-state
							       event-handlers)
						 (vm-subscriptions state))])))

(define (enqueue-event event state)
  (struct-copy vm state [pending-events (cons event (vm-pending-events state))]))

;; VM -> KernelModeTransition
;; (A kind of Meta-InterruptK)
(define (run-vm state)
  (define state-after-timeouts state) ;; TODO
  (define state-after-events
    (foldl dispatch-event
	   (struct-copy vm state-after-timeouts [pending-events (make-queue)])
	   (queue->list (vm-pending-events state))))
  (trap-to-metalevel state-after-events))

(define (dispatch-event event state)
  (foldl (match-subscription event)
	 (struct-copy vm state [subscriptions '()])
	 (vm-subscriptions state)))

(define ((match-subscription event) sub state)
  (let search-handlers ((event-handlers (subscription-event-handlers sub)))
    (cond
     [(null? event-handlers)
      ;; No handler matched this event. Put the subscription
      ;; back on the list for some future event.
      (struct-copy vm state [subscriptions (cons sub (vm-subscriptions state))])]
     [((event-handler-matcher (car event-handlers)) event)
      (run-process (subscription-state sub)
		   (event-handler-k (car event-handlers))
		   state)]
     [else
      (search-handlers (cdr event-handlers))])))

(define (boot-process k state)
  (run-process (void) (lambda (dummy) (k)) state))

(define (run-process process-state k state)
  (match (k process-state)
    [(kernel-mode-transition new-process-state
			     outbound-events
			     new-event-handlers)
     (subscribe-process new-process-state
			new-event-handlers
			(foldl enqueue-event state outbound-events))]
    [other
     (error 'vm "Processes must return a kernel-mode-transition struct; got ~v" other)]))

(define (trap-to-metalevel state)
  (define-values (meta-messages non-meta-messages)
    (partition meta-message? (queue->list (vm-pending-events state))))
  (define-values (processes remainder)
    (partition process? non-meta-messages))
  (define-values (messages junk)
    (partition message? remainder))
  (define final-state
    (struct-copy vm (foldl (lambda (p state) (boot-process (process-boot p) state))
			   state
			   processes)
		 [pending-events (list->queue messages)]))
  (define outbound-meta-messages 
    (map (lambda (mm) (message (meta-message-body mm))) meta-messages))
  (kernel-mode-transition
   final-state
   (if (null? messages) ;; only block if there are no messages left to process
       outbound-meta-messages
       (cons (process (lambda (dummy) run-vm)) outbound-meta-messages))
   (append-map (lambda (sub)
		 (map rewrite-event-handler
		      (filter event-handler-meta? (subscription-event-handlers sub))))
	       (vm-subscriptions final-state))))

(define (rewrite-event-handler eh)
  (event-handler #f ;; we rewrite a handler of metaevents to a meta handler of events
		 (event-handler-matcher eh)
		 inject-meta-event))

(define ((inject-meta-event e) state)
  (run-vm (enqueue-event (meta-message e) state)))