#lang racket/base
; Userland for os.rkt: use of delimited continuations to invoke kernel services

(require racket/match)
(require racket/list)
(require "os.rkt")

(provide (struct-out wait-clause)

	 ground-vm ;; convenience re-export
	 (struct-out ground-event-pattern) ;; convenience re-export
	 (struct-out ground-event-value) ;; convenience re-export

	 userland

	 send
	 meta-send
	 send*

	 wait
	 poll

	 spawn)

;; A WaitClause is a (wait-clause PatternPredicate ([Meta]Message -> Any))
;; Used to build up what amount to wrapped events in Racket's CMLish
;; terminology, for use with wait (which is analogous to sync).
(struct wait-clause (pattern handler-proc) #:transparent)

;; Our internal prompt tag.
(define prompt (make-continuation-prompt-tag 'os-userland))

;; ( -> Void) -> BootK
;; Wraps a thunk that uses the userland continuation-based approach to
;; simulating side effects so that it can be used as a BootK with a
;; KernelModeTransition.
(define (userland main)
  (lambda ()
    (start-transaction ((reply-to (lambda (_)
				    (main)
				    'finish))
			void))))

(define ((reply-to k) v)
  (call-with-continuation-prompt (lambda () (k (v))) prompt))

(define (start-transaction first-action)
  (accumulate-transaction '() '() '() first-action))

(define (accumulate-transaction messages meta-messages new-threads action)
  (define (syscall sub)
    (kernel-mode-transition sub
			    (reverse messages)
			    (reverse meta-messages)
			    (reverse new-threads)))
  (match action
    [`(actions ,ms ,mms ,thrs ,k)
     (accumulate-transaction (append (reverse ms) messages)
			     (append (reverse mms) meta-messages)
			     (append (reverse thrs) new-threads)
			     (k void))]
    [`(wait ,polling? ,mhs ,mmhs ,k)
     (syscall (suspension k
			  (and polling? (lambda (k) (start-transaction (k void))))
			  (wrap-handlers mhs)
			  (wrap-handlers mmhs)))]
    [`finish
     (syscall (suspension 'finished #f '() '()))]))

(define (((invoke-handler proc) v) k)
  (start-transaction (k (lambda () (proc v)))))

(define (wrap-handlers hs)
  (map (lambda (h) (message-handler (wait-clause-pattern h)
				    (invoke-handler (wait-clause-handler-proc h))))
       (flatten hs)))

(define (call-in-kernel-context proc)
  (call-with-composable-continuation
   (lambda (k) (abort-current-continuation prompt
	         (lambda () (proc (reply-to k)))))
   prompt))

(define (actions ms mms thrs)
  (call-in-kernel-context (lambda (k) `(actions ,ms ,mms ,thrs ,k))))

;; Message -> Void
;; Sends a message at this level.
(define (send message)
  (actions (list message) '() '()))

;; MetaMessage -> Void
;; Sends a message at this VM's container's level.
(define (meta-send meta-message)
  (actions '() (list meta-message) '()))

;; ListOf<Message> [ListOf<MetaMessage>] -> Void
;; Sends any number of messages, possibly at multiple levels.
(define (send* messages [meta-messages '()])
  (actions messages meta-messages '()))

;; ConsTreeOf<WaitClause> [ConsTreeOf<WaitClause>] -> Any
;; Synchronizes on a collection of possible events.
(define (wait mhs [mmhs '()])
  (call-in-kernel-context (lambda (k) `(wait #f ,mhs ,mmhs ,k))))

;; [ConsTreeOf<WaitClause>] [ConsTreeOf<WaitClause>] -> Any
;; Synchronizes on a collection of possible events, returning
;; "immediately" if none of them are ready to fire.
(define (poll [mhs '()] [mmhs '()])
  (call-in-kernel-context (lambda (k) `(wait #t ,mhs ,mmhs ,k))))

;; BootK -> Void
;; Spawns the given BootK within the current VM.
(define (spawn thunk)
  (actions '() '() (list thunk)))