diff --git a/syndicate/dataspace.rkt b/syndicate/dataspace.rkt index 9084c59..9f63d3e 100644 --- a/syndicate/dataspace.rkt +++ b/syndicate/dataspace.rkt @@ -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))))) diff --git a/syndicate/relay.rkt b/syndicate/relay.rkt index f837cca..9a21a90 100644 --- a/syndicate/relay.rkt +++ b/syndicate/relay.rkt @@ -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))))