Remove struct runnable; provide default pattern-predicate; make os-big-bang virtualizable

os-big-bang-example.rkt

@@ -37,35 +37,37 @@
 			     (send-message `(tick ,counter ,now))
 			     (loop now (+ counter 1)))]))))
 
-(os-big-bang 'none
+(ground-vm
-	     (subscribe 'display-driver display-driver-handler)
+ (os-big-bang 'none
-	     (subscribe 'read-line-driver read-line-driver-handler)
+	      (subscribe 'display-driver display-driver-handler)
-	     (tick-driver 'ticker 1000)
+	      (subscribe 'read-line-driver read-line-driver-handler)
-	     (send-message 'greet-loop)
+	      (tick-driver 'ticker 1000)
-	     (subscribe 'greet-loop-handler
+	      (send-message `(display "Hello! "))
-			(message-handlers w
+	      (send-message 'greet-loop)
-			 ['greet-loop
+	      (subscribe 'greet-loop-handler
-			  (transition w
+			 (message-handlers w
-				      (send-message `(display "Hello! Enter your name:\n"))
+			  ['greet-loop
-				      (send-message `(request read-name read-line)))]))
+			   (transition w
-	     (subscribe 'ticker-handler
+				       (send-message `(display "Enter your name:\n"))
-			(message-handlers w
+				       (send-message `(request read-name read-line)))]))
-			 [`(tick ,counter ,_)
+	      (subscribe 'ticker-handler
-			  (transition w
+			 (message-handlers w
-				      (send-message
+			  [`(tick ,counter ,_)
-				       `(display ,(string-append "TICK "
+			   (transition w
-								 (number->string counter)
+				       (send-message
-								 "\n"))))]))
+					`(display ,(string-append "TICK "
-	     (subscribe 'read-line-result-handler
+								  (number->string counter)
-			(message-handlers w
+								  "\n"))))]))
-			 [`(reply read-name ,(== eof))
+	      (subscribe 'read-line-result-handler
-			  (transition w
+			 (message-handlers w
-				      (send-message `(display "Goodbye!\n")))]
+			  [`(reply read-name ,(== eof))
-			 [`(reply read-name ,name)
+			   (transition w
-			  (transition w
+				       (send-message `(display "Goodbye!\n")))]
-				      (send-message `(display "Hello, "))
+			  [`(reply read-name ,name)
-				      (send-message `(display ,name))
+			   (transition w
-				      (send-message `(display "!\n"))
+				       (send-message `(display "Hello, "))
-				      (unsubscribe 'ticker)
+				       (send-message `(display ,name))
-				      (send-message 'greet-loop)
+				       (send-message `(display "!\n"))
-				      )])))
+				       (unsubscribe 'ticker)
+				       (send-message 'greet-loop)
+				       )]))))

os-big-bang.rkt

@@ -20,6 +20,7 @@
 	 (except-out (struct-out transition) transition)
 	 (rename-out [make-transition transition])
 
+	 ground-vm ;; reprovided from os.rkt for convenience
 	 os-big-bang)
 
 ;; A SID is an Any, a world-specific identifier for subscriptions.
@@ -120,16 +121,9 @@
 
 (define (spawn->runnable s)
   (match-define (spawn initial-state initial-actions) s)
-  (runnable (void)
+  (apply os-big-bang initial-state initial-actions))
-	    (lambda (_) (boot-task initial-state initial-actions))))
 
-(define (boot-task initial-state initial-actions)
+(define (os-big-bang initial-state . initial-actions)
-  (transition->os-transition (world (void) (hash))
+  (lambda () 
-			     (transition initial-state initial-actions)))
+    (transition->os-transition (world (void) (hash))
-
+			       (transition initial-state initial-actions))))
-(define (os-big-bang initial-state
-		     #:pattern-predicate [pattern-predicate (lambda (p m) (p m))]
-		     . initial-actions)
-  (ground-vm pattern-predicate
-	     (lambda ()
-	       (boot-task initial-state initial-actions))))

os-example.rkt

@@ -41,7 +41,7 @@
   (kernel-mode-transition (subscription 'none (lambda (_) (k)) '() '())
 			  '()
 			  '()
-			  (list (runnable 'none (lambda (_) (thunk))))))
+			  (list thunk)))
 
 (define (example-process delay)
   (print "SLEEPING"
@@ -53,8 +53,7 @@
 				  (print "HELLO"
 					 quit))))))))
 
-(ground-vm (lambda (p m) (p m))
+(ground-vm (lambda ()
-	   (lambda ()
 	     (spawn (lambda ()
 		      (example-process 1000))
 		    (lambda ()

os-userland-stdlib.rkt

@@ -30,7 +30,7 @@
 	 receive/timeout)
 
 (define (ground-vm/userland/stdlib boot)
-  (ground-vm/userland (lambda (p m) (p m)) boot))
+  (ground-vm/userland boot #:pattern-predicate (lambda (p m) (p m))))
 
 (define-syntax message-handlers
   (syntax-rules ()

os-userland.rkt

@@ -30,8 +30,8 @@
 				  'finish))
 		      void)))
 
-(define (ground-vm/userland pattern-predicate boot)
+(define (ground-vm/userland boot #:pattern-predicate [pattern-predicate default-pattern-predicate])
-  (ground-vm pattern-predicate (lambda () (userland boot))))
+  (ground-vm (lambda () (userland boot)) #:pattern-predicate pattern-predicate))
 
 (define ((reply-to k) v)
   (call-with-continuation-prompt (lambda () (k (v))) prompt))
@@ -44,7 +44,7 @@
     (kernel-mode-transition sub
 			    (reverse messages)
 			    (reverse meta-messages)
-			    (map (lambda (t) (runnable (void) (lambda (_) (userland t))))
+			    (map (lambda (t) (lambda () (userland t)))
 				 (reverse new-threads))))
   (match action
     [`(actions ,ms ,mms ,thrs ,k)

os.rkt

@@ -7,9 +7,6 @@
 (require "functional-queue.rkt")
 
 (provide
- ;; Spawning processes
- (struct-out runnable)
-
  ;; Waiting for messages
  (struct-out subscription)
  (struct-out message-handler)
@@ -23,6 +20,7 @@
  run-vm
 
  ;; Grounding out the infinite tower of VMs
+ default-pattern-predicate
  ground-vm
  )
 
@@ -73,7 +71,7 @@
 ;; A VM is a (vm ListBagOf<Suspension>
 ;;               QueueOf<Message> ;; TODO: make unordered?
 ;;               QueueOf<MetaMessage> ;; TODO: make unordered?
-;;               QueueOf<Runnable>).
+;;               QueueOf<BootK>).
 (struct vm (suspensions
 	    pending-messages
 	    pending-meta-messages
@@ -90,9 +88,9 @@
 ;; the process, and the output is the information passed back to the
 ;; VM when the process yields the CPU.
 
-;; A Runnable is a (runnable ProcessState InterruptK), representing a
+;; A BootK is a ( -> KernelModeTransition), representing either a
-;; temporarily-suspended runnable process.
+;; fresh process or a previously-suspended process just about to
-(struct runnable (state k) #:transparent)
+;; resume.
 
 ;; A Subscription is a
 ;; (subscription ProcessState
@@ -128,7 +126,7 @@
 ;; (kernel-mode-transition Subscription
 ;;                         ListBagOf<Message>
 ;;			   ListBagOf<MetaMessage>
-;;                         ListBagOf<Runnable>)
+;;                         ListBagOf<BootK>)
 ;; representing the subscription for the transitioning process, a list
 ;; of messages to emit at both this VM's and its container's level,
 ;; and a list of new processes to create and schedule.
@@ -146,12 +144,12 @@
 ;; TODO: enforce user-mode restrictions
 ;; TODO: timeouts
 
-;; PatternPredicate ( -> KernelModeTransition ) -> VM
+;; PatternPredicate BootK -> VM
 (define (make-vm pattern-predicate boot)
   (vm (list)
       (make-queue)
       (make-queue)
-      (enqueue (make-queue) (runnable (void) (lambda (dummy) (boot))))
+      (enqueue (make-queue) boot)
       pattern-predicate))
 
 ;; VM -> KernelModeTransition
@@ -172,15 +170,14 @@
 (define (requeue-pollers state)
   (foldl (lambda (susp state)
 	   (if (suspension-polling? susp)
-	       (enqueue-runnable (runnable (suspension-state susp)
+	       (enqueue-runnable (lambda () ((suspension-k susp) (suspension-state susp)))
-					   (suspension-k susp))
 				 state)
 	       (enqueue-suspension susp state)))
 	 (struct-copy vm state [suspensions '()])
 	 (vm-suspensions state)))
 
 (define (run-runnables state)
-  (foldl (lambda (r state) (perform-transition ((runnable-k r) (runnable-state r)) state))
+  (foldl (lambda (r state) (perform-transition (r) state))
 	 (struct-copy vm state [pending-processes (make-queue)])
 	 (queue->list (vm-pending-processes state))))
 
@@ -283,13 +280,16 @@
      #t]
     [_ #f]))
 
+(define default-pattern-predicate
+  (lambda (p m) (p m)))
+
 ;; PatternPredicate ( -> KernelModeTransition ) -> Void
 ;; In this context,
 ;;   Message = a thunk
 ;;   MessagePattern = evt?
 ;;   MetaMessage, MetaMessagePattern = not defined because there's no outer level
 ;; Runs its argument VM until it becomes (provably) inert.
-(define (ground-vm pattern-predicate boot)
+(define (ground-vm boot #:pattern-predicate [pattern-predicate default-pattern-predicate])
   (let loop ((transition (run-vm (make-vm pattern-predicate boot))))
     (for-each (lambda (thunk) (thunk)) (kernel-mode-transition-messages transition))
     (when (not (nested-vm-inert? (kernel-mode-transition-subscription transition)))