95 lines
3.4 KiB
Racket
95 lines
3.4 KiB
Racket
#lang racket/base
|
|
;; Breaking the infinite tower of nested Worlds, connecting to the "real" world at the fracture line.
|
|
|
|
(require racket/async-channel)
|
|
(require racket/set)
|
|
(require racket/match)
|
|
(require racket/list)
|
|
(require "core.rkt")
|
|
(require "gestalt.rkt")
|
|
(require "trace/stderr.rkt")
|
|
|
|
(provide (struct-out event)
|
|
send-ground-message
|
|
run-ground)
|
|
|
|
;; A GroundEvent is a pair of a Racket (evt?) event and its yielded
|
|
;; results.
|
|
;; - (event RacketEvent (Listof Any))
|
|
(struct event (descriptor values) #:prefab)
|
|
|
|
;; (Parameterof (Option AsyncChannel))
|
|
;; Communication channel from auxiliary (usually driver) threads to
|
|
;; the currently-active ground VM.
|
|
(define current-ground-event-async-channel (make-parameter (make-async-channel)))
|
|
|
|
;; Any -> Void
|
|
;; Sends a (non-feedback) message at the ground-VM metalevel.
|
|
(define (send-ground-message body)
|
|
(async-channel-put (current-ground-event-async-channel) (send body)))
|
|
|
|
;; RacketEvent -> RacketEvent
|
|
;; Wraps a CML-style Racket event with a handler that sends the event
|
|
;; results via the ground VM.
|
|
(define (event-handler descriptor)
|
|
(handle-evt descriptor (lambda vs (send (event descriptor vs)))))
|
|
|
|
;; GestaltProjection
|
|
;; Used to extract event descriptors and results from subscriptions
|
|
;; from the ground VM's contained World.
|
|
(define event-projection (project-subs (event (?!) ?)))
|
|
|
|
;; Gestalt -> (Listof RacketEvent)
|
|
;; Projects out the active event subscriptions from the given gestalt.
|
|
(define (extract-active-events gestalt)
|
|
(define es (gestalt-project/single gestalt event-projection))
|
|
;; TODO: how should the following error be handled, ideally?
|
|
;; In principle, security restrictions should make it impossible.
|
|
;; But absent those, what should be done? Should an offending
|
|
;; process be identified and terminated?
|
|
(unless es (error 'extract-active-events "User program subscribed to wildcard event"))
|
|
(for/list [(e (in-set es))] (event-handler e)))
|
|
|
|
;; RacketEvent
|
|
;; Used only when the system is not provably inert, in order to let it
|
|
;; take further internal reductions.
|
|
(define idle-handler
|
|
(handle-evt (system-idle-evt) (lambda _ #f)))
|
|
|
|
;; Action* -> Void
|
|
;; Runs a ground VM, booting the outermost World with the given Actions.
|
|
(define (run-ground . boot-actions)
|
|
(let await-interrupt ((inert? #f)
|
|
(p (spawn-process (spawn-world boot-actions))) ;; we are guaranteed boot-proc is ignorable here
|
|
(active-events '()))
|
|
(define active-gestalt (process-gestalt p))
|
|
(define event-list (if inert?
|
|
active-events
|
|
(cons idle-handler active-events)))
|
|
(if (and (null? event-list) (gestalt-empty? active-gestalt))
|
|
(begin (log-info "run-ground: Terminating because inert")
|
|
(void))
|
|
(let ((e (apply sync (current-ground-event-async-channel) event-list)))
|
|
(match (deliver-event e -2 p)
|
|
[#f ;; inert
|
|
(await-interrupt #t p active-events)]
|
|
[(transition new-state actions)
|
|
(let process-actions ((actions (flatten actions)) (g active-gestalt))
|
|
(match actions
|
|
['()
|
|
(await-interrupt #f
|
|
(struct-copy process p
|
|
[gestalt g]
|
|
[state new-state])
|
|
(extract-active-events g))]
|
|
[(cons a actions)
|
|
(match a
|
|
[(routing-update gestalt)
|
|
(process-actions actions gestalt)]
|
|
[(quit)
|
|
(log-info "run-ground: Terminating by request")
|
|
(void)]
|
|
[_
|
|
(log-warning "run-ground: ignoring useless meta-action ~v" a)
|
|
(process-actions actions g)])]))])))))
|