69 lines
2.1 KiB
Racket
69 lines
2.1 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/match)
|
|
(require "structs.rkt")
|
|
(require "roles.rkt")
|
|
(require "vm.rkt")
|
|
(require "log.rkt")
|
|
(require "process.rkt")
|
|
(require "actions.rkt")
|
|
(require "action-send-message.rkt")
|
|
(require "quasiqueue.rkt")
|
|
|
|
(provide run-ground-vm)
|
|
|
|
;; run-ground-vm : process-spec -> Void
|
|
(define (run-ground-vm boot)
|
|
(let loop ((state (make-vm boot)))
|
|
(match (run-vm state)
|
|
[(transition state actions)
|
|
(define is-blocking?
|
|
(match (quasiqueue->list (action-tree->quasiqueue actions))
|
|
['()
|
|
;; no "yield" action -> certainly blocking
|
|
#t]
|
|
[(list (yield (== run-vm)))
|
|
;; single "yield", with k statically known to be run-vm -> poll
|
|
#f]
|
|
[_
|
|
;; uh-oh
|
|
(error 'ground-vm
|
|
"Cannot process meta-actions ~v because no further metalevel exists"
|
|
actions)]))
|
|
(define active-events
|
|
(endpoint-fold extract-ground-event-subscriptions '() state))
|
|
(if (and is-blocking?
|
|
(null? active-events))
|
|
(begin
|
|
;; Not polling, and no events that could wake us from blocking, so quit
|
|
(marketplace-log 'debug "Ground VM returning normally.")
|
|
(sleep 0.2) ;; give the log-receivers a chance to drain (!)
|
|
(void))
|
|
(let ((interruptk (apply sync
|
|
(if is-blocking?
|
|
never-evt
|
|
(wrap-evt always-evt (lambda (dummy) values)))
|
|
active-events)))
|
|
(loop (interruptk state))))])))
|
|
|
|
;; extract-ground-event-subscriptions :
|
|
;; (All (State) (process State) (endpoint State) (Listof Evt) -> (Listof Evt))
|
|
(define (extract-ground-event-subscriptions old-p ep acc)
|
|
(define pid (process-pid old-p))
|
|
(match (endpoint-role ep)
|
|
[(role 'subscriber (cons (? evt? evt) _) 'participant)
|
|
;; evt-handler : Any -> (vm -> vm)
|
|
(define ((evt-handler message) state)
|
|
(let-values (((state wp) (extract-process state pid)))
|
|
(if (not wp)
|
|
state
|
|
(let ((p wp))
|
|
(let-values
|
|
(((p state)
|
|
(do-send-message 'publisher (cons evt message) p state)))
|
|
(if p
|
|
(inject-process state p)
|
|
state))))))
|
|
(cons (wrap-evt evt evt-handler) acc)]
|
|
[_ acc]))
|