WIP toward ground-vm
This commit is contained in:
parent
dac24674ad
commit
4eeaf3dcbb
64
os2.rkt
64
os2.rkt
|
@ -280,3 +280,67 @@
|
||||||
[(? send-message?) preaction]
|
[(? send-message?) preaction]
|
||||||
[(spawn thunk k)
|
[(spawn thunk k)
|
||||||
(spawn thunk (wrap-trapk pid k))]))
|
(spawn thunk (wrap-trapk pid k))]))
|
||||||
|
|
||||||
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
|
(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)
|
||||||
|
|
||||||
|
(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")])))
|
Loading…
Reference in New Issue