#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)
	 message-handlers
	 meta-message-handlers
	 userland

	 send
	 meta-send
	 send*

	 wait
	 poll

	 spawn)

(struct wait-clause (pattern handler-proc) #:transparent)

(define-syntax message-handlers
  (syntax-rules ()
    ((_ (pattern body ...) ...)
     (list (wait-clause (match-lambda (pattern #t) (_ #f))
			(match-lambda (pattern body ...)))
	   ...))))

(define-syntax meta-message-handlers
  (syntax-rules (=>)
    ((_ [(raw-pattern => pattern) body ...] ...)
     (list (wait-clause raw-pattern
			(match-lambda (pattern body ...)))
	   ...))))

(define prompt (make-continuation-prompt-tag 'os-userland))

(define (userland main)
  (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)
			    (map (lambda (t) (runnable (void) (lambda (_) (userland t))))
				 (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 (subscription k
			    (and polling? (lambda (k) (start-transaction (k void))))
			    (wrap-handlers mhs)
			    (wrap-handlers mmhs)))]
    [`finish
     (syscall (subscription '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))))

(define (send message)
  (actions (list message) '() '()))

(define (meta-send meta-message)
  (actions '() (list meta-message) '()))

(define (send* messages [meta-messages '()])
  (actions messages meta-messages '()))

(define (wait mhs [mmhs '()])
  (call-in-kernel-context (lambda (k) `(wait #f ,mhs ,mmhs ,k))))

(define (poll [mhs '()] [mmhs '()])
  (call-in-kernel-context (lambda (k) `(wait #t ,mhs ,mmhs ,k))))

(define (spawn thunk)
  (actions '() '() (list thunk)))