Support yielding, i.e. polling for outside events.
This commit is contained in:
parent
112b417f1c
commit
8f10b2ad4d
|
@ -3,4 +3,4 @@
|
||||||
(mapcar #'(lambda (x) (put x 'scheme-indent-function 1))
|
(mapcar #'(lambda (x) (put x 'scheme-indent-function 1))
|
||||||
'(transition extend-transition))
|
'(transition extend-transition))
|
||||||
(mapcar #'(lambda (x) (put x 'scheme-indent-function 2))
|
(mapcar #'(lambda (x) (put x 'scheme-indent-function 2))
|
||||||
'(role)))
|
'(role yield)))
|
||||||
|
|
50
os2.rkt
50
os2.rkt
|
@ -33,6 +33,8 @@
|
||||||
(rename-out [make-spawn spawn])
|
(rename-out [make-spawn spawn])
|
||||||
(except-out (struct-out kill) kill)
|
(except-out (struct-out kill) kill)
|
||||||
(rename-out [make-kill kill])
|
(rename-out [make-kill kill])
|
||||||
|
(except-out (struct-out yield) yield)
|
||||||
|
(rename-out [yield-macro yield])
|
||||||
|
|
||||||
(struct-out at-meta-level)
|
(struct-out at-meta-level)
|
||||||
|
|
||||||
|
@ -46,6 +48,7 @@
|
||||||
(rename-out [send-message <send-message>])
|
(rename-out [send-message <send-message>])
|
||||||
(rename-out [spawn <spawn>])
|
(rename-out [spawn <spawn>])
|
||||||
(rename-out [kill <kill>])
|
(rename-out [kill <kill>])
|
||||||
|
(rename-out [yield <yield>])
|
||||||
(rename-out [at-meta-level <at-meta-level>])
|
(rename-out [at-meta-level <at-meta-level>])
|
||||||
|
|
||||||
;; Reexports from unify.rkt for convenience
|
;; Reexports from unify.rkt for convenience
|
||||||
|
@ -140,14 +143,17 @@
|
||||||
;; (kill Maybe<PID> Any)
|
;; (kill Maybe<PID> Any)
|
||||||
(struct kill (pid reason) #:prefab)
|
(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)
|
(struct at-meta-level (preaction) #:prefab)
|
||||||
|
|
||||||
;;---------------------------------------------------------------------------
|
;;---------------------------------------------------------------------------
|
||||||
;; role macro
|
;; role & yield macros
|
||||||
|
|
||||||
(require (for-syntax syntax/parse))
|
(require (for-syntax syntax/parse))
|
||||||
(require (for-syntax racket/base))
|
(require (for-syntax racket/base))
|
||||||
|
|
||||||
(define-syntax role
|
(define-syntax role
|
||||||
(lambda (stx)
|
(lambda (stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
|
@ -178,6 +184,9 @@
|
||||||
topics-expr
|
topics-expr
|
||||||
(handlers presence-handler absence-handler message-handler)))])))
|
(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.
|
;; Smarter constructors for transitions and preactions.
|
||||||
|
|
||||||
|
@ -251,15 +260,23 @@
|
||||||
(outbound-actions '()))
|
(outbound-actions '()))
|
||||||
(match remaining-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)
|
[(cons (cons pid action) rest)
|
||||||
(match action
|
(match action
|
||||||
[(at-meta-level preaction)
|
[(at-meta-level preaction)
|
||||||
(define transformed-preaction (transform-meta-action pid preaction))
|
(define transformed-preaction (transform-meta-action pid preaction))
|
||||||
(loop rest state (cons transformed-preaction outbound-actions))]
|
(loop rest state (cons transformed-preaction outbound-actions))]
|
||||||
|
[(yield k)
|
||||||
|
(loop rest (run-ready state pid k) outbound-actions)]
|
||||||
[preaction
|
[preaction
|
||||||
(loop rest (perform-action pid preaction state) outbound-actions)])])))
|
(loop rest (perform-action pid preaction state) outbound-actions)])])))
|
||||||
|
|
||||||
|
(define (vm-idle? state)
|
||||||
|
(null? (vm-pending-actions state)))
|
||||||
|
|
||||||
(define (collect-dead-processes state)
|
(define (collect-dead-processes state)
|
||||||
(struct-copy vm state
|
(struct-copy vm state
|
||||||
[processes (for/hash ([(pid p) (in-hash (vm-processes state))]
|
[processes (for/hash ([(pid p) (in-hash (vm-processes state))]
|
||||||
|
@ -437,6 +454,7 @@
|
||||||
|
|
||||||
(define (action? a)
|
(define (action? a)
|
||||||
(or (preaction? a)
|
(or (preaction? a)
|
||||||
|
(yield? a)
|
||||||
(and (at-meta-level? a)
|
(and (at-meta-level? a)
|
||||||
(preaction? (at-meta-level-preaction a)))))
|
(preaction? (at-meta-level-preaction a)))))
|
||||||
|
|
||||||
|
@ -478,27 +496,27 @@
|
||||||
(let loop ((state (make-vm boot)))
|
(let loop ((state (make-vm boot)))
|
||||||
(match (run-vm state)
|
(match (run-vm state)
|
||||||
[(transition state actions)
|
[(transition state actions)
|
||||||
(when (not (null? actions))
|
(define is-blocking?
|
||||||
(error 'ground-vm "Cannot process meta-actions because no further meta-level exists: ~v"
|
(match actions
|
||||||
actions))
|
['() #t] ;; no "yield" action -> certainly blocking
|
||||||
(define waiting? (null? (vm-pending-actions state)))
|
[(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
|
(define active-events
|
||||||
(for*/fold ([acc '()])
|
(for*/fold ([acc '()])
|
||||||
([(eid e) (in-hash (vm-endpoints state))]
|
([(eid e) (in-hash (vm-endpoints state))]
|
||||||
[active-topic (in-set (endpoint-topics e))])
|
[active-topic (in-set (endpoint-topics e))])
|
||||||
(match active-topic
|
(match active-topic
|
||||||
[(topic 'subscriber (cons (? evt? evt) _) #f)
|
[(topic 'subscriber (cons (? evt? evt) _) #f)
|
||||||
(cons (wrap-evt evt (lambda (message)
|
(define ((evt-handler message) state)
|
||||||
(lambda (state)
|
(route-and-deliver 'publisher (cons evt message) state))
|
||||||
(route-and-deliver 'publisher
|
(cons (wrap-evt evt evt-handler) acc)]
|
||||||
(cons evt message)
|
|
||||||
state))))
|
|
||||||
acc)]
|
|
||||||
[_ acc])))
|
[_ acc])))
|
||||||
(if (and waiting? (null? active-events))
|
(if (and is-blocking? (null? active-events))
|
||||||
'done ;; About to block, and nothing can wake us
|
'done ;; Not polling, and no events that could wake us from blocking, so quit
|
||||||
(let ((interruptk (apply sync
|
(let ((interruptk (apply sync
|
||||||
(if waiting?
|
(if is-blocking?
|
||||||
never-evt
|
never-evt
|
||||||
(wrap-evt always-evt (lambda (dummy) values)))
|
(wrap-evt always-evt (lambda (dummy) values)))
|
||||||
active-events)))
|
active-events)))
|
||||||
|
|
Loading…
Reference in New Issue