diff --git a/os2.rkt b/os2.rkt index 371e572..3165896 100644 --- a/os2.rkt +++ b/os2.rkt @@ -144,6 +144,9 @@ ;; QuasiQueue (define empty-quasi-queue '()) +;; QuasiQueue -> Boolean +(define quasi-queue-empty? null?) + ;; X QuasiQueue -> QuasiQueue (define (quasi-enqueue-one thing existing-quasi-queue) (cons thing existing-quasi-queue)) @@ -351,63 +354,29 @@ (lambda () (run-vm (make-vm boot)))) (define (ground-vm boot) - (let run-kernel ((transition (run-vm (make-vm boot))) - (endpoints (hash)) - (next-eid-number 0)) - (let integrate-delta ((state (transition-state transition)) - (actions (transition-actions transition)) - (endpoints endpoints) - (next-eid-number 0)) - (match actions - ['() - (define interruptk (apply sync - (for/list ([(eid e) (in-hash events)]) - (wrap-evt (endpoint-topic e) - (lambda (message) - (run-user-code - ((handlers-message (endpoint-handlers e)) - eid - (endpoint-topic e) - message))))))) - (run-kernel (run-user-code (interruptk state)))] - [(cons preaction rest) - (match preaction - [(add-role topic hs k) + (let loop ((state (make-vm boot))) + (match (run-vm state) + [(transition state actions) + (when (not (null? actions)) + (error 'ground-vm "No meta-actions available in ground-vm: ~v" actions)) + (define waiting? (quasi-queue-empty? (vm-pending-actions state))) + (define active-events (for/list ([(eid e) (in-hash (vm-endpoints state))] + #:when (eq? (topic-role (endpoint-topic e)) 'subscriber)) + (define evt (topic-pattern (endpoint-topic e))) + (wrap-evt evt (lambda (message) + (lambda (state) + (route-and-deliver (topic-publisher evt) + message + state)))))) + (if (and waiting? (null? active-events)) + ;; About to block, and nothing can wake us + 'done + (let ((interruptk (apply sync + (if waiting? + never-evt + (wrap-evt always-evt (lambda (dummy) values))) + active-events))) + (loop (interruptk state))))]))) - (integrate-delta (run-user-code - ((run-user-code (k next-eid-number)) - 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")]))) \ No newline at end of file +;;(require racket/trace) +;;(trace perform-action) \ No newline at end of file