Delimited-continuation-based userland and example program

os-userland-example.rkt

@@ -0,0 +1,78 @@
+#lang racket/base
+
+(require racket/port)
+(require "os.rkt")
+(require "os-userland.rkt")
+
+(define (rpc req)
+  (define reply-addr (gensym 'reply-addr)) ;;; !!! TODO: remove side-effect?
+  (send `(request ,reply-addr ,req))
+  (wait (message-handlers
+	 [`(reply ,(? (lambda (v) (eq? v reply-addr))) ,v)
+	  v])))
+
+(define-syntax rpc-service
+  (syntax-rules ()
+    [(_ pattern body ...)
+     (let loop ()
+       (wait (message-handlers
+	      [`(request ,reply-addr ,pattern)
+	       (spawn (lambda ()
+			(define answer (begin body ...))
+			(send `(reply ,reply-addr ,answer))))
+	       (loop)])))]))
+
+(define (display-driver)
+  (define message (wait (message-handlers [`(display ,message) message])))
+  (meta-send (lambda ()
+	       (display message)
+	       (flush-output)))
+  (display-driver))
+
+(define (read-line-driver)
+  (rpc-service `read-line
+	       (wait (message-handlers)
+		     (meta-message-handlers
+		      [((read-line-evt (current-input-port) 'any) => line)
+		       line]))))
+
+(define (time-evt msecs)
+  (wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds))))
+
+(define (wait-until-time msecs)
+  (wait (message-handlers)
+	(meta-message-handlers
+	 [((time-evt msecs) => current-time)
+	  current-time])))
+
+(define (current-time)
+  (wait-until-time 0))
+
+(define (sleep-driver)
+  (rpc-service `(sleep ,msecs)
+	       (send `(display (Sleeping ,msecs)))
+	       (wait (message-handlers)
+		     (meta-message-handlers
+		      [((time-evt (+ (current-time) msecs)) => now)
+		       (send `(display "\n"))
+		       now]))))
+
+(define (main)
+  (spawn display-driver)
+  (spawn read-line-driver)
+  (spawn sleep-driver)
+  (spawn (lambda ()
+	   (send `(display "HI\n"))
+	   (rpc `(sleep 1000))
+	   (send `(display "THERE\n"))))
+  (poll)
+  (send `(display "Hello! Enter your name:\n"))
+  (define name (rpc 'read-line))
+  (send `(display "Hello, "))
+  (send `(display ,name))
+  (send `(display "!\n"))
+  (rpc `(sleep 1000))
+  (send `(display "Goodbye\n")))
+
+(ground-vm (lambda (p m) (p m)) ;; pattern-predicate
+	   (lambda () (userland main)))

os-userland.rkt

@@ -0,0 +1,107 @@
+#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)))