My, what a small operating system you have

minified-os.rkt

#lang racket

(provide (struct-out subscription)
	 (struct-out message-handler)
	 (struct-out kernel-mode-transition)
	 make-vm
	 vm?
	 run-vm
	 nested-vm)

(struct vm (suspensions pending-messages pending-meta-messages pending-processes pattern-predicate) #:transparent)
(struct subscription (state k message-handlers meta-message-handlers) #:transparent)
(struct suspension (state k message-handlers meta-message-handlers) #:transparent)
(struct message-handler (pattern k) #:transparent)
(struct kernel-mode-transition (subscription messages meta-messages new-processes) #:transparent)

(define (make-vm boot pattern-predicate) (vm '() '() '() (list boot) pattern-predicate))

(define (run-vm state)
  (let* ((state (requeue-pollers state))
	 (runnables (reverse (vm-pending-processes state)))
	 (messages (reverse (vm-pending-messages state)))
	 (state (struct-copy vm state [pending-processes '()] [pending-messages '()]))
	 (state (foldl (lambda (r state) (perform-transition (r) state)) state runnables))
	 (state (foldl dispatch-message state messages))
	 (meta-messages (reverse (vm-pending-meta-messages state)))
	 (meta-handlers (append-map extract-downward-meta-message-handlers (vm-suspensions state)))
	 (poller-k (and (should-poll? state) run-vm)) ;; only block if there's nothing left to do
	 (state (struct-copy vm state [pending-meta-messages '()])))
    (kernel-mode-transition (subscription state poller-k meta-handlers '()) meta-messages '() '())))

(define (fold-suspensions state f) (foldl f (struct-copy vm state [suspensions '()]) (vm-suspensions state)))

(define (requeue-pollers state)
  (fold-suspensions state (lambda (susp state)
			    (if (suspension-polling? susp)
				(enqueue-runnable (lambda () ((suspension-k susp) (suspension-state susp))) state)
				(enqueue-suspension susp state)))))

(define (extract-downward-meta-message-handlers susp)
  (for/list ([(hid mmh) (in-hash (suspension-meta-message-handlers susp))])
    (message-handler (message-handler-pattern mmh) (dispatch-meta-message hid))))

(define (extract-upward-meta-message-handlers susp)
  (for/list ([(hid mmh) (in-hash (suspension-meta-message-handlers susp))])
    (message-handler hid (message-handler-k mmh))))

(define (((dispatch-meta-message hid) message) state)
  (run-vm (fold-suspensions state (match-suspension message
						    (lambda (handler-hid message) (equal? hid handler-hid))
						    extract-upward-meta-message-handlers))))

(define (perform-transition transition state)
  (match-define (kernel-mode-transition (subscription ps k mhs mmhs) messages meta-messages new-processes) transition)
  (let* ((state (foldl enqueue-message state messages))
	 (state (foldl enqueue-runnable state new-processes))
	 (state (enqueue-suspension (suspension ps k mhs (for/hash ([mmh mmhs]) (values (gensym 'hid) mmh))) state))
	 (state (foldl enqueue-meta-message state meta-messages)))
    state))

(define (enqueue-message message state)
  (struct-copy vm state [pending-messages (cons message (vm-pending-messages state))]))

(define (enqueue-runnable r state)
  (struct-copy vm state [pending-processes (cons r (vm-pending-processes state))]))

(define (enqueue-suspension susp state)
  (match susp
    [(suspension _ #f '() (? (lambda (h) (zero? (hash-count h))))) state]
    [(suspension _ _ _ _) (struct-copy vm state [suspensions (cons susp (vm-suspensions state))])]))

(define (enqueue-meta-message message state)
  (struct-copy vm state [pending-meta-messages (cons message (vm-pending-meta-messages state))]))

(define (dispatch-message message state)
  (fold-suspensions state (match-suspension message (vm-pattern-predicate state) suspension-message-handlers)))

(define ((match-suspension message apply-pattern handlers-getter) susp state)
  (let search-handlers ((message-handlers (handlers-getter susp)))
    (cond
     [(null? message-handlers) (enqueue-suspension susp state)]
     [(apply-pattern (message-handler-pattern (car message-handlers)) message)
      (perform-transition (((message-handler-k (car message-handlers)) message) (suspension-state susp)) state)]
     [else (search-handlers (cdr message-handlers))])))

(define (suspension-polling? susp) (not (eq? (suspension-k susp) #f)))

(define (should-poll? state)
  (or (not (null? (vm-pending-processes state)))
      (not (null? (vm-pending-messages state)))
      (ormap suspension-polling? (vm-suspensions state))))

(define (nested-vm boot pattern-predicate) (lambda () (run-vm (make-vm boot pattern-predicate))))