Implement ground-vm. It's so much smaller and nicer!
This commit is contained in:
parent
a26fec6b1d
commit
ae51097c59
87
os2.rkt
87
os2.rkt
|
@ -144,6 +144,9 @@
|
||||||
;; QuasiQueue<X>
|
;; QuasiQueue<X>
|
||||||
(define empty-quasi-queue '())
|
(define empty-quasi-queue '())
|
||||||
|
|
||||||
|
;; QuasiQueue<X> -> Boolean
|
||||||
|
(define quasi-queue-empty? null?)
|
||||||
|
|
||||||
;; X QuasiQueue<X> -> QuasiQueue<X>
|
;; X QuasiQueue<X> -> QuasiQueue<X>
|
||||||
(define (quasi-enqueue-one thing existing-quasi-queue)
|
(define (quasi-enqueue-one thing existing-quasi-queue)
|
||||||
(cons thing existing-quasi-queue))
|
(cons thing existing-quasi-queue))
|
||||||
|
@ -351,63 +354,29 @@
|
||||||
(lambda () (run-vm (make-vm boot))))
|
(lambda () (run-vm (make-vm boot))))
|
||||||
|
|
||||||
(define (ground-vm boot)
|
(define (ground-vm boot)
|
||||||
(let run-kernel ((transition (run-vm (make-vm boot)))
|
(let loop ((state (make-vm boot)))
|
||||||
(endpoints (hash))
|
(match (run-vm state)
|
||||||
(next-eid-number 0))
|
[(transition state actions)
|
||||||
(let integrate-delta ((state (transition-state transition))
|
(when (not (null? actions))
|
||||||
(actions (transition-actions transition))
|
(error 'ground-vm "No meta-actions available in ground-vm: ~v" actions))
|
||||||
(endpoints endpoints)
|
(define waiting? (quasi-queue-empty? (vm-pending-actions state)))
|
||||||
(next-eid-number 0))
|
(define active-events (for/list ([(eid e) (in-hash (vm-endpoints state))]
|
||||||
(match actions
|
#:when (eq? (topic-role (endpoint-topic e)) 'subscriber))
|
||||||
['()
|
(define evt (topic-pattern (endpoint-topic e)))
|
||||||
(define interruptk (apply sync
|
(wrap-evt evt (lambda (message)
|
||||||
(for/list ([(eid e) (in-hash events)])
|
(lambda (state)
|
||||||
(wrap-evt (endpoint-topic e)
|
(route-and-deliver (topic-publisher evt)
|
||||||
(lambda (message)
|
message
|
||||||
(run-user-code
|
state))))))
|
||||||
((handlers-message (endpoint-handlers e))
|
(if (and waiting? (null? active-events))
|
||||||
eid
|
;; About to block, and nothing can wake us
|
||||||
(endpoint-topic e)
|
'done
|
||||||
message)))))))
|
(let ((interruptk (apply sync
|
||||||
(run-kernel (run-user-code (interruptk state)))]
|
(if waiting?
|
||||||
[(cons preaction rest)
|
never-evt
|
||||||
(match preaction
|
(wrap-evt always-evt (lambda (dummy) values)))
|
||||||
[(add-role topic hs k)
|
active-events)))
|
||||||
|
(loop (interruptk state))))])))
|
||||||
|
|
||||||
(integrate-delta (run-user-code
|
;;(require racket/trace)
|
||||||
((run-user-code (k next-eid-number))
|
;;(trace perform-action)
|
||||||
state))
|
|
||||||
|
|
||||||
rest
|
|
||||||
(hash-set endpoints
|
|
||||||
next-eid-number
|
|
||||||
(endpoint next-eid-number
|
|
||||||
|
|
||||||
[(delete-role eid reason) ...]
|
|
||||||
[(send-message topic body) ...]
|
|
||||||
[(spawn thunk k) ...])]))))
|
|
||||||
|
|
||||||
(for-each (lambda (thunk) (thunk)) (kernel-mode-transition-messages transition))
|
|
||||||
(when (not (nested-vm-inert? (kernel-mode-transition-suspension transition)))
|
|
||||||
(match transition
|
|
||||||
[(kernel-mode-transition (suspension new-state
|
|
||||||
polling-k
|
|
||||||
message-handlers
|
|
||||||
'())
|
|
||||||
_
|
|
||||||
'()
|
|
||||||
'())
|
|
||||||
(define inbound-messages
|
|
||||||
(map (match-lambda [(message-handler (ground-event-pattern tag evt) k)
|
|
||||||
(wrap-evt evt (lambda (v) (cons (ground-event-value tag v) k)))])
|
|
||||||
message-handlers))
|
|
||||||
(match-define (cons inbound-value inbound-continuation)
|
|
||||||
(apply sync
|
|
||||||
(wrap-evt (if polling-k always-evt never-evt)
|
|
||||||
(lambda (v) (cons (ground-event-value 'idle (void))
|
|
||||||
(lambda (dummy) polling-k))))
|
|
||||||
inbound-messages))
|
|
||||||
(loop ((inbound-continuation inbound-value) new-state))]
|
|
||||||
[_
|
|
||||||
(error 'ground-vm
|
|
||||||
"Outermost VM may not spawn new siblings or send or receive metamessages")])))
|
|
Loading…
Reference in New Issue