diff --git a/indenting2.el b/indenting2.el index 28fda48..095c1a2 100644 --- a/indenting2.el +++ b/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))) \ No newline at end of file + '(role yield))) diff --git a/os2.rkt b/os2.rkt index 4a9c8ee..d5b4f35 100644 --- a/os2.rkt +++ b/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 ]) (rename-out [spawn ]) (rename-out [kill ]) + (rename-out [yield ]) (rename-out [at-meta-level ]) ;; Reexports from unify.rkt for convenience @@ -140,14 +143,17 @@ ;; (kill Maybe 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)))