syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Avoid manipulating `in-script?` all the time

This commit is contained in:
Tony Garnock-Jones 2018-04-30 10:44:35 +01:00
parent c2cb624e42
commit 14ee4f70ef
2 changed files with 80 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
syndicate/dataspace.rkt
View File

@ -2,6 +2,7 @@
(provide make-dataspace ;; TODO: how to cleanly provide this? (provide make-dataspace ;; TODO: how to cleanly provide this?
with-current-facet ;; TODO: shouldn't be provided 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? run-scripts! ;; TODO: how to cleanly provide this?
message-struct message-struct
@ -272,12 +273,11 @@
(for [(a filtered-initial-assertions)] (for [(a filtered-initial-assertions)]
(adhoc-retract! the-actor a))))) (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) (let ((a a0)
(f f0)) (f f0))
(parameterize ((current-actor a) (parameterize ((current-actor a)
(current-facet f) (current-facet f))
(in-script? script?))
(with-handlers ([(lambda (e) (not (exn:break? e))) (with-handlers ([(lambda (e) (not (exn:break? e)))
(lambda (e) (lambda (e)
((current-actor-crash-logger) a e) ((current-actor-crash-logger) a e)
@ -288,11 +288,15 @@
body ...)) body ...))
(void))))) (void)))))
(define-syntax-rule (with-non-script-context body ...)
(parameterize ((in-script? #f))
body ...))
(define (capture-facet-context proc) (define (capture-facet-context proc)
(let ((a (current-actor)) (let ((a (current-actor))
(f (current-facet))) (f (current-facet)))
(lambda args (lambda args
(with-current-facet [a f #t] (with-current-facet [a f]
(apply proc args))))) (apply proc args)))))
(define (pop-next-script! ac) (define (pop-next-script! ac)
@ -315,22 +319,23 @@
(loop)))))) (loop))))))
(define (refresh-facet-assertions! ds) (define (refresh-facet-assertions! ds)
(dataflow-repair-damage! (dataspace-dataflow ds) (with-non-script-context
(lambda (subject-id) (dataflow-repair-damage! (dataspace-dataflow ds)
(match-define (list f eid) subject-id) (lambda (subject-id)
(when (facet-live? f) ;; TODO: necessary test, or tautological? (match-define (list f eid) subject-id)
(define ac (facet-actor f)) (when (facet-live? f) ;; TODO: necessary test, or tautological?
(with-current-facet [ac f #f] (define ac (facet-actor f))
(define ep (hash-ref (facet-endpoints f) eid)) (with-current-facet [ac f]
(match-define (endpoint _ old-assertion old-handler update-fn) ep) (define ep (hash-ref (facet-endpoints f) eid))
(define-values (new-assertion new-handler) (update-fn)) (match-define (endpoint _ old-assertion old-handler update-fn) ep)
(when (not (equal? old-assertion new-assertion)) (define-values (new-assertion new-handler) (update-fn))
(retract! ac old-assertion) (when (not (equal? old-assertion new-assertion))
(when old-handler (dataspace-unsubscribe! ds old-handler)) (retract! ac old-assertion)
(set-endpoint-assertion! ep new-assertion) (when old-handler (dataspace-unsubscribe! ds old-handler))
(set-endpoint-handler! ep new-handler) (set-endpoint-assertion! ep new-assertion)
(assert! ac new-assertion) (set-endpoint-handler! ep new-handler)
(when new-handler (dataspace-subscribe! ds new-handler)))))))) (assert! ac new-assertion)
(when new-handler (dataspace-subscribe! ds new-handler)))))))))
(define (commit-actions! ds ac) (define (commit-actions! ds ac)
(define pending (actor-pending-actions ac)) (define pending (actor-pending-actions ac))
@ -409,8 +414,9 @@
;; root facet should be allowed? ;; root facet should be allowed?
(error 'add-facet! "INTERNAL ERROR: Attempt to add second root facet")) (error 'add-facet! "INTERNAL ERROR: Attempt to add second root facet"))
(set-actor-root-facet! actor f))) (set-actor-root-facet! actor f)))
(with-current-facet [actor f #f] (with-current-facet [actor f]
(boot-proc)) (with-non-script-context
(boot-proc)))
(push-script! actor (lambda () (push-script! actor (lambda ()
(when (or (and parent (not (facet-live? parent))) (facet-inert? f)) (when (or (and parent (not (facet-live? parent))) (facet-inert? f))
(terminate-facet! f))))) (terminate-facet! f)))))
@ -471,7 +477,7 @@
;; Run stop-scripts after terminating children. This means that ;; Run stop-scripts after terminating children. This means that
;; children's stop-scripts run before ours. ;; children's stop-scripts run before ours.
(schedule-script! ac (lambda () (schedule-script! ac (lambda ()
(with-current-facet [ac f #t] (with-current-facet [ac f]
(for [(script (in-list (reverse (facet-stop-scripts f))))] (for [(script (in-list (reverse (facet-stop-scripts f))))]
(script))))) (script)))))
@ -485,7 +491,7 @@
(define (stop-facet! f stop-script) (define (stop-facet! f stop-script)
(define ac (facet-actor f)) (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 () (schedule-script! ac (lambda ()
(terminate-facet! f) (terminate-facet! f)
(schedule-script! ac stop-script))))) (schedule-script! ac stop-script)))))

96
syndicate/relay.rkt
View File

@ -36,7 +36,7 @@
(push-script! (push-script!
outer-actor outer-actor
(lambda () (lambda ()
(with-current-facet [outer-actor outer-facet #t] (with-current-facet [outer-actor outer-facet]
(defer-turn! (lambda () (defer-turn! (lambda ()
(when (run-scripts! inner-ds) (when (run-scripts! inner-ds)
(schedule-inner!)))))))) (schedule-inner!))))))))
@ -61,61 +61,65 @@
(on (asserted (observe (inbound $x))) (on (asserted (observe (inbound $x)))
;; (log-info "~a (asserted (observe (inbound ~v)))" inner-actor x) ;; (log-info "~a (asserted (observe (inbound ~v)))" inner-actor x)
(with-current-facet [outer-actor outer-facet #f] (with-current-facet [outer-actor outer-facet]
(define i (skeleton-interest (with-non-script-context
(term->skeleton x) (define i (skeleton-interest
(term->skeleton-proj x) (term->skeleton x)
(term->key x) (term->skeleton-proj x)
(term->capture-proj x) (term->key x)
(lambda (op . captured-values) (term->capture-proj x)
(define term (inbound (instantiate-term->value x captured-values))) (lambda (op . captured-values)
(push-script! inner-actor (define term (inbound (instantiate-term->value x captured-values)))
(lambda () (push-script! inner-actor
;; (log-info "~a (~a) ~v" inner-actor op term) (lambda ()
(match op ;; (log-info "~a (~a) ~v" inner-actor op term)
['+ (adhoc-assert! inner-actor term)] (match op
['- (adhoc-retract! inner-actor term)] ['+ (adhoc-assert! inner-actor term)]
['! (enqueue-send! inner-actor term)]))) ['- (adhoc-retract! inner-actor term)]
(schedule-inner!)) ['! (enqueue-send! inner-actor term)])))
(lambda (cache) (schedule-inner!))
(push-script! inner-actor (lambda (cache)
(lambda () (push-script! inner-actor
(for [(captured-values (in-bag cache))] (lambda ()
(define term (for [(captured-values (in-bag cache))]
(inbound (instantiate-term->value x captured-values))) (define term
;; (log-info "~a (cleanup) ~v" inner-actor term) (inbound (instantiate-term->value x captured-values)))
(adhoc-retract! inner-actor term)))) ;; (log-info "~a (cleanup) ~v" inner-actor term)
(schedule-inner!)))) (adhoc-retract! inner-actor term))))
(hash-set! inbound-endpoints (schedule-inner!))))
x (hash-set! inbound-endpoints
(add-endpoint! outer-facet x
"dataspace-relay (observe (inbound ...))" (add-endpoint! outer-facet
#t "dataspace-relay (observe (inbound ...))"
(lambda () (values (observe x) i)))))) #t
(lambda () (values (observe x) i)))))))
(on (retracted (observe (inbound $x))) (on (retracted (observe (inbound $x)))
;; (log-info "~a (retracted (observe (inbound ~v)))" inner-actor x) ;; (log-info "~a (retracted (observe (inbound ~v)))" inner-actor x)
(with-current-facet [outer-actor outer-facet #f] (with-current-facet [outer-actor outer-facet]
(remove-endpoint! outer-facet (hash-ref inbound-endpoints x)) (with-non-script-context
(hash-remove! inbound-endpoints x))) (remove-endpoint! outer-facet (hash-ref inbound-endpoints x))
(hash-remove! inbound-endpoints x))))
(on (asserted (outbound $x)) (on (asserted (outbound $x))
;; (log-info "~a (asserted (outbound ~v))" inner-actor x) ;; (log-info "~a (asserted (outbound ~v))" inner-actor x)
(with-current-facet [outer-actor outer-facet #f] (with-current-facet [outer-actor outer-facet]
(hash-set! outbound-endpoints (with-non-script-context
x (hash-set! outbound-endpoints
(add-endpoint! outer-facet x
"dataspace-relay (outbound ...)" (add-endpoint! outer-facet
#t "dataspace-relay (outbound ...)"
(lambda () (values x #f)))))) #t
(lambda () (values x #f)))))))
(on (retracted (outbound $x)) (on (retracted (outbound $x))
;; (log-info "~a (retracted (outbound ~v))" inner-actor x) ;; (log-info "~a (retracted (outbound ~v))" inner-actor x)
(with-current-facet [outer-actor outer-facet #f] (with-current-facet [outer-actor outer-facet]
(remove-endpoint! outer-facet (hash-ref outbound-endpoints x)) (with-non-script-context
(hash-remove! outbound-endpoints x))) (remove-endpoint! outer-facet (hash-ref outbound-endpoints x))
(hash-remove! outbound-endpoints x))))
(on (message (outbound $x)) (on (message (outbound $x))
;; (log-info "~a (message (outbound ~v))" inner-actor 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)))) (send! x))))