Avoid manipulating `in-script?` all the time
This commit is contained in:
Tony Garnock-Jones
parent
c2cb624e42
commit
14ee4f70ef
|
|
@ -2,6 +2,7 @@
|
|||
|
||||
(provide make-dataspace ;; TODO: how to cleanly provide this?
|
||||
with-current-facet ;; TODO: shouldn't be provided
|
||||
with-non-script-context ;; TODO: shouldn't be provided
|
||||
run-scripts! ;; TODO: how to cleanly provide this?
|
||||
|
||||
message-struct
|
||||
|
|
@ -272,12 +273,11 @@
|
|||
(for [(a filtered-initial-assertions)]
|
||||
(adhoc-retract! the-actor a)))))
|
||||
|
||||
(define-syntax-rule (with-current-facet [a0 f0 script?] body ...)
|
||||
(define-syntax-rule (with-current-facet [a0 f0] body ...)
|
||||
(let ((a a0)
|
||||
(f f0))
|
||||
(parameterize ((current-actor a)
|
||||
(current-facet f)
|
||||
(in-script? script?))
|
||||
(current-facet f))
|
||||
(with-handlers ([(lambda (e) (not (exn:break? e)))
|
||||
(lambda (e)
|
||||
((current-actor-crash-logger) a e)
|
||||
|
|
@ -288,11 +288,15 @@
|
|||
body ...))
|
||||
(void)))))
|
||||
|
||||
(define-syntax-rule (with-non-script-context body ...)
|
||||
(parameterize ((in-script? #f))
|
||||
body ...))
|
||||
|
||||
(define (capture-facet-context proc)
|
||||
(let ((a (current-actor))
|
||||
(f (current-facet)))
|
||||
(lambda args
|
||||
(with-current-facet [a f #t]
|
||||
(with-current-facet [a f]
|
||||
(apply proc args)))))
|
||||
|
||||
(define (pop-next-script! ac)
|
||||
|
|
@ -315,22 +319,23 @@
|
|||
(loop))))))
|
||||
|
||||
(define (refresh-facet-assertions! ds)
|
||||
(dataflow-repair-damage! (dataspace-dataflow ds)
|
||||
(lambda (subject-id)
|
||||
(match-define (list f eid) subject-id)
|
||||
(when (facet-live? f) ;; TODO: necessary test, or tautological?
|
||||
(define ac (facet-actor f))
|
||||
(with-current-facet [ac f #f]
|
||||
(define ep (hash-ref (facet-endpoints f) eid))
|
||||
(match-define (endpoint _ old-assertion old-handler update-fn) ep)
|
||||
(define-values (new-assertion new-handler) (update-fn))
|
||||
(when (not (equal? old-assertion new-assertion))
|
||||
(retract! ac old-assertion)
|
||||
(when old-handler (dataspace-unsubscribe! ds old-handler))
|
||||
(set-endpoint-assertion! ep new-assertion)
|
||||
(set-endpoint-handler! ep new-handler)
|
||||
(assert! ac new-assertion)
|
||||
(when new-handler (dataspace-subscribe! ds new-handler))))))))
|
||||
(with-non-script-context
|
||||
(dataflow-repair-damage! (dataspace-dataflow ds)
|
||||
(lambda (subject-id)
|
||||
(match-define (list f eid) subject-id)
|
||||
(when (facet-live? f) ;; TODO: necessary test, or tautological?
|
||||
(define ac (facet-actor f))
|
||||
(with-current-facet [ac f]
|
||||
(define ep (hash-ref (facet-endpoints f) eid))
|
||||
(match-define (endpoint _ old-assertion old-handler update-fn) ep)
|
||||
(define-values (new-assertion new-handler) (update-fn))
|
||||
(when (not (equal? old-assertion new-assertion))
|
||||
(retract! ac old-assertion)
|
||||
(when old-handler (dataspace-unsubscribe! ds old-handler))
|
||||
(set-endpoint-assertion! ep new-assertion)
|
||||
(set-endpoint-handler! ep new-handler)
|
||||
(assert! ac new-assertion)
|
||||
(when new-handler (dataspace-subscribe! ds new-handler)))))))))
|
||||
|
||||
(define (commit-actions! ds ac)
|
||||
(define pending (actor-pending-actions ac))
|
||||
|
|
@ -409,8 +414,9 @@
|
|||
;; root facet should be allowed?
|
||||
(error 'add-facet! "INTERNAL ERROR: Attempt to add second root facet"))
|
||||
(set-actor-root-facet! actor f)))
|
||||
(with-current-facet [actor f #f]
|
||||
(boot-proc))
|
||||
(with-current-facet [actor f]
|
||||
(with-non-script-context
|
||||
(boot-proc)))
|
||||
(push-script! actor (lambda ()
|
||||
(when (or (and parent (not (facet-live? parent))) (facet-inert? f))
|
||||
(terminate-facet! f)))))
|
||||
|
|
@ -471,7 +477,7 @@
|
|||
;; Run stop-scripts after terminating children. This means that
|
||||
;; children's stop-scripts run before ours.
|
||||
(schedule-script! ac (lambda ()
|
||||
(with-current-facet [ac f #t]
|
||||
(with-current-facet [ac f]
|
||||
(for [(script (in-list (reverse (facet-stop-scripts f))))]
|
||||
(script)))))
|
||||
|
||||
|
|
@ -485,7 +491,7 @@
|
|||
|
||||
(define (stop-facet! f stop-script)
|
||||
(define ac (facet-actor f))
|
||||
(with-current-facet [ac (facet-parent f) #f] ;; run in parent context wrt terminating facet
|
||||
(with-current-facet [ac (facet-parent f)] ;; run in parent context wrt terminating facet
|
||||
(schedule-script! ac (lambda ()
|
||||
(terminate-facet! f)
|
||||
(schedule-script! ac stop-script)))))
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@
|
|||
(push-script!
|
||||
outer-actor
|
||||
(lambda ()
|
||||
(with-current-facet [outer-actor outer-facet #t]
|
||||
(with-current-facet [outer-actor outer-facet]
|
||||
(defer-turn! (lambda ()
|
||||
(when (run-scripts! inner-ds)
|
||||
(schedule-inner!))))))))
|
||||
|
|
@ -61,61 +61,65 @@
|
|||
|
||||
(on (asserted (observe (inbound $x)))
|
||||
;; (log-info "~a (asserted (observe (inbound ~v)))" inner-actor x)
|
||||
(with-current-facet [outer-actor outer-facet #f]
|
||||
(define i (skeleton-interest
|
||||
(term->skeleton x)
|
||||
(term->skeleton-proj x)
|
||||
(term->key x)
|
||||
(term->capture-proj x)
|
||||
(lambda (op . captured-values)
|
||||
(define term (inbound (instantiate-term->value x captured-values)))
|
||||
(push-script! inner-actor
|
||||
(lambda ()
|
||||
;; (log-info "~a (~a) ~v" inner-actor op term)
|
||||
(match op
|
||||
['+ (adhoc-assert! inner-actor term)]
|
||||
['- (adhoc-retract! inner-actor term)]
|
||||
['! (enqueue-send! inner-actor term)])))
|
||||
(schedule-inner!))
|
||||
(lambda (cache)
|
||||
(push-script! inner-actor
|
||||
(lambda ()
|
||||
(for [(captured-values (in-bag cache))]
|
||||
(define term
|
||||
(inbound (instantiate-term->value x captured-values)))
|
||||
;; (log-info "~a (cleanup) ~v" inner-actor term)
|
||||
(adhoc-retract! inner-actor term))))
|
||||
(schedule-inner!))))
|
||||
(hash-set! inbound-endpoints
|
||||
x
|
||||
(add-endpoint! outer-facet
|
||||
"dataspace-relay (observe (inbound ...))"
|
||||
#t
|
||||
(lambda () (values (observe x) i))))))
|
||||
(with-current-facet [outer-actor outer-facet]
|
||||
(with-non-script-context
|
||||
(define i (skeleton-interest
|
||||
(term->skeleton x)
|
||||
(term->skeleton-proj x)
|
||||
(term->key x)
|
||||
(term->capture-proj x)
|
||||
(lambda (op . captured-values)
|
||||
(define term (inbound (instantiate-term->value x captured-values)))
|
||||
(push-script! inner-actor
|
||||
(lambda ()
|
||||
;; (log-info "~a (~a) ~v" inner-actor op term)
|
||||
(match op
|
||||
['+ (adhoc-assert! inner-actor term)]
|
||||
['- (adhoc-retract! inner-actor term)]
|
||||
['! (enqueue-send! inner-actor term)])))
|
||||
(schedule-inner!))
|
||||
(lambda (cache)
|
||||
(push-script! inner-actor
|
||||
(lambda ()
|
||||
(for [(captured-values (in-bag cache))]
|
||||
(define term
|
||||
(inbound (instantiate-term->value x captured-values)))
|
||||
;; (log-info "~a (cleanup) ~v" inner-actor term)
|
||||
(adhoc-retract! inner-actor term))))
|
||||
(schedule-inner!))))
|
||||
(hash-set! inbound-endpoints
|
||||
x
|
||||
(add-endpoint! outer-facet
|
||||
"dataspace-relay (observe (inbound ...))"
|
||||
#t
|
||||
(lambda () (values (observe x) i)))))))
|
||||
|
||||
(on (retracted (observe (inbound $x)))
|
||||
;; (log-info "~a (retracted (observe (inbound ~v)))" inner-actor x)
|
||||
(with-current-facet [outer-actor outer-facet #f]
|
||||
(remove-endpoint! outer-facet (hash-ref inbound-endpoints x))
|
||||
(hash-remove! inbound-endpoints x)))
|
||||
(with-current-facet [outer-actor outer-facet]
|
||||
(with-non-script-context
|
||||
(remove-endpoint! outer-facet (hash-ref inbound-endpoints x))
|
||||
(hash-remove! inbound-endpoints x))))
|
||||
|
||||
(on (asserted (outbound $x))
|
||||
;; (log-info "~a (asserted (outbound ~v))" inner-actor x)
|
||||
(with-current-facet [outer-actor outer-facet #f]
|
||||
(hash-set! outbound-endpoints
|
||||
x
|
||||
(add-endpoint! outer-facet
|
||||
"dataspace-relay (outbound ...)"
|
||||
#t
|
||||
(lambda () (values x #f))))))
|
||||
(with-current-facet [outer-actor outer-facet]
|
||||
(with-non-script-context
|
||||
(hash-set! outbound-endpoints
|
||||
x
|
||||
(add-endpoint! outer-facet
|
||||
"dataspace-relay (outbound ...)"
|
||||
#t
|
||||
(lambda () (values x #f)))))))
|
||||
|
||||
(on (retracted (outbound $x))
|
||||
;; (log-info "~a (retracted (outbound ~v))" inner-actor x)
|
||||
(with-current-facet [outer-actor outer-facet #f]
|
||||
(remove-endpoint! outer-facet (hash-ref outbound-endpoints x))
|
||||
(hash-remove! outbound-endpoints x)))
|
||||
(with-current-facet [outer-actor outer-facet]
|
||||
(with-non-script-context
|
||||
(remove-endpoint! outer-facet (hash-ref outbound-endpoints x))
|
||||
(hash-remove! outbound-endpoints x))))
|
||||
|
||||
(on (message (outbound $x))
|
||||
;; (log-info "~a (message (outbound ~v))" inner-actor x)
|
||||
(with-current-facet [outer-actor outer-facet #f]
|
||||
(with-current-facet [outer-actor outer-facet]
|
||||
(send! x))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue