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

26
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,12 +319,13 @@
(loop)))))) (loop))))))
(define (refresh-facet-assertions! ds) (define (refresh-facet-assertions! ds)
(with-non-script-context
(dataflow-repair-damage! (dataspace-dataflow ds) (dataflow-repair-damage! (dataspace-dataflow ds)
(lambda (subject-id) (lambda (subject-id)
(match-define (list f eid) subject-id) (match-define (list f eid) subject-id)
(when (facet-live? f) ;; TODO: necessary test, or tautological? (when (facet-live? f) ;; TODO: necessary test, or tautological?
(define ac (facet-actor f)) (define ac (facet-actor f))
(with-current-facet [ac f #f] (with-current-facet [ac f]
(define ep (hash-ref (facet-endpoints f) eid)) (define ep (hash-ref (facet-endpoints f) eid))
(match-define (endpoint _ old-assertion old-handler update-fn) ep) (match-define (endpoint _ old-assertion old-handler update-fn) ep)
(define-values (new-assertion new-handler) (update-fn)) (define-values (new-assertion new-handler) (update-fn))
@ -330,7 +335,7 @@
(set-endpoint-assertion! ep new-assertion) (set-endpoint-assertion! ep new-assertion)
(set-endpoint-handler! ep new-handler) (set-endpoint-handler! ep new-handler)
(assert! ac new-assertion) (assert! ac new-assertion)
(when new-handler (dataspace-subscribe! ds new-handler)))))))) (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)))))

24
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,7 +61,8 @@
(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]
(with-non-script-context
(define i (skeleton-interest (define i (skeleton-interest
(term->skeleton x) (term->skeleton x)
(term->skeleton-proj x) (term->skeleton-proj x)
@ -91,31 +92,34 @@
(add-endpoint! outer-facet (add-endpoint! outer-facet
"dataspace-relay (observe (inbound ...))" "dataspace-relay (observe (inbound ...))"
#t #t
(lambda () (values (observe x) i)))))) (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]
(with-non-script-context
(remove-endpoint! outer-facet (hash-ref inbound-endpoints x)) (remove-endpoint! outer-facet (hash-ref inbound-endpoints x))
(hash-remove! 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]
(with-non-script-context
(hash-set! outbound-endpoints (hash-set! outbound-endpoints
x x
(add-endpoint! outer-facet (add-endpoint! outer-facet
"dataspace-relay (outbound ...)" "dataspace-relay (outbound ...)"
#t #t
(lambda () (values x #f)))))) (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]
(with-non-script-context
(remove-endpoint! outer-facet (hash-ref outbound-endpoints x)) (remove-endpoint! outer-facet (hash-ref outbound-endpoints x))
(hash-remove! 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))))