Support yielding, i.e. polling for outside events.

indenting2.el

@@ -3,4 +3,4 @@
   (mapcar #'(lambda (x) (put x 'scheme-indent-function 1))
 	  '(transition extend-transition))
   (mapcar #'(lambda (x) (put x 'scheme-indent-function 2))
-	  '(role)))
+	  '(role yield)))

os2.rkt

@@ -33,6 +33,8 @@
 	 (rename-out [make-spawn spawn])
 	 (except-out (struct-out kill) kill)
 	 (rename-out [make-kill kill])
+	 (except-out (struct-out yield) yield)
+	 (rename-out [yield-macro yield])
 
 	 (struct-out at-meta-level)
 
@@ -46,6 +48,7 @@
 	 (rename-out [send-message <send-message>])
 	 (rename-out [spawn <spawn>])
 	 (rename-out [kill <kill>])
+	 (rename-out [yield <yield>])
 	 (rename-out [at-meta-level <at-meta-level>])
 
 	 ;; Reexports from unify.rkt for convenience
@@ -140,14 +143,17 @@
 ;; (kill Maybe<PID> Any)
 (struct kill (pid reason) #:prefab)
 
-;; An Action is either a Preaction or an (at-meta-level Preaction).
+;; An Action is either a Preaction or a (yield InterruptK) or an
+;; (at-meta-level Preaction).
+(struct yield (k) #:prefab)
 (struct at-meta-level (preaction) #:prefab)
 
 ;;---------------------------------------------------------------------------
-;; role macro
+;; role & yield macros
 
 (require (for-syntax syntax/parse))
 (require (for-syntax racket/base))
+
 (define-syntax role
   (lambda (stx)
     (syntax-parse stx
@@ -178,6 +184,9 @@
 		     topics-expr
 		     (handlers presence-handler absence-handler message-handler)))])))
 
+(define-syntax-rule (yield-macro #:state state-pattern body ...)
+  (yield (match-lambda [state-pattern body ...])))
+
 ;;---------------------------------------------------------------------------
 ;; Smarter constructors for transitions and preactions.
 
@@ -251,15 +260,23 @@
 	     (outbound-actions '()))
     (match remaining-actions
       ['()
-       (transition (collect-dead-processes state) (reverse outbound-actions))]
+       (let ((state (collect-dead-processes state)))
+	 (transition state (reverse (if (vm-idle? state)
+					outbound-actions
+					(cons (yield run-vm) outbound-actions)))))]
       [(cons (cons pid action) rest)
        (match action
 	 [(at-meta-level preaction)
 	  (define transformed-preaction (transform-meta-action pid preaction))
 	  (loop rest state (cons transformed-preaction outbound-actions))]
+	 [(yield k)
+	  (loop rest (run-ready state pid k) outbound-actions)]
 	 [preaction
 	  (loop rest (perform-action pid preaction state) outbound-actions)])])))
 
+(define (vm-idle? state)
+  (null? (vm-pending-actions state)))
+
 (define (collect-dead-processes state)
   (struct-copy vm state
 	       [processes (for/hash ([(pid p) (in-hash (vm-processes state))]
@@ -437,6 +454,7 @@
 
 (define (action? a)
   (or (preaction? a)
+      (yield? a)
       (and (at-meta-level? a)
 	   (preaction? (at-meta-level-preaction a)))))
 
@@ -478,27 +496,27 @@
   (let loop ((state (make-vm boot)))
     (match (run-vm state)
       [(transition state actions)
-       (when (not (null? actions))
-	 (error 'ground-vm "Cannot process meta-actions because no further meta-level exists: ~v"
-		actions))
-       (define waiting? (null? (vm-pending-actions state)))
+       (define is-blocking?
+	 (match actions
+	   ['() #t] ;; no "yield" action -> certainly blocking
+	   [(list (yield _)) #f] ;; single "yield", with k statically known to be run-vm -> poll
+	   [_ (error 'ground-vm
+		     "Cannot process meta-actions ~v because no further metalevel exists"
+		     actions)]))
        (define active-events
 	 (for*/fold ([acc '()])
 	     ([(eid e) (in-hash (vm-endpoints state))]
 	      [active-topic (in-set (endpoint-topics e))])
 	   (match active-topic
 	     [(topic 'subscriber (cons (? evt? evt) _) #f)
-	      (cons (wrap-evt evt (lambda (message)
-				    (lambda (state)
-				      (route-and-deliver 'publisher
-							 (cons evt message)
-							 state))))
-		    acc)]
+	      (define ((evt-handler message) state)
+		(route-and-deliver 'publisher (cons evt message) state))
+	      (cons (wrap-evt evt evt-handler) acc)]
 	     [_ acc])))
-       (if (and waiting? (null? active-events))
-	   'done ;; About to block, and nothing can wake us
+       (if (and is-blocking? (null? active-events))
+	   'done ;; Not polling, and no events that could wake us from blocking, so quit
 	   (let ((interruptk (apply sync
-				    (if waiting?
+				    (if is-blocking?
 					never-evt
 					(wrap-evt always-evt (lambda (dummy) values)))
 				    active-events)))