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

Eliminate another parameter: now only `current-facet` remains

This commit is contained in:
Tony Garnock-Jones 2018-04-30 11:18:49 +01:00
parent 14ee4f70ef
commit 0e37037b6e
2 changed files with 19 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
syndicate/dataspace.rkt
View File

@ -191,8 +191,7 @@
(lambda (a e) (lambda (a e)
(log-error "Actor ~a died with exception:\n~a" a (exn->string e))))) (log-error "Actor ~a died with exception:\n~a" a (exn->string e)))))
;; Parameterof Actor (define (current-actor) (facet-actor (current-facet)))
(define current-actor (make-parameter #f))
;; Parameterof Facet ;; Parameterof Facet
(define current-facet (make-parameter #f)) (define current-facet (make-parameter #f))
@ -273,13 +272,12 @@
(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] body ...) (define-syntax-rule (with-current-facet [f0] body ...)
(let ((a a0) (let ((f f0))
(f f0)) (parameterize ((current-facet f))
(parameterize ((current-actor a)
(current-facet f))
(with-handlers ([(lambda (e) (not (exn:break? e))) (with-handlers ([(lambda (e) (not (exn:break? e)))
(lambda (e) (lambda (e)
(define a (current-actor))
((current-actor-crash-logger) a e) ((current-actor-crash-logger) a e)
(abandon-queued-work! a) (abandon-queued-work! a)
(terminate-actor! a))]) ;; TODO: tracing (terminate-actor! a))]) ;; TODO: tracing
@ -293,10 +291,9 @@
body ...)) body ...))
(define (capture-facet-context proc) (define (capture-facet-context proc)
(let ((a (current-actor)) (let ((f (current-facet)))
(f (current-facet)))
(lambda args (lambda args
(with-current-facet [a f] (with-current-facet [f]
(apply proc args))))) (apply proc args)))))
(define (pop-next-script! ac) (define (pop-next-script! ac)
@ -325,7 +322,7 @@
(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] (with-current-facet [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))
@ -414,7 +411,7 @@
;; 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] (with-current-facet [f]
(with-non-script-context (with-non-script-context
(boot-proc))) (boot-proc)))
(push-script! actor (lambda () (push-script! actor (lambda ()
@ -477,7 +474,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] (with-current-facet [f]
(for [(script (in-list (reverse (facet-stop-scripts f))))] (for [(script (in-list (reverse (facet-stop-scripts f))))]
(script))))) (script)))))
@ -491,7 +488,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)] ;; run in parent context wrt terminating facet (with-current-facet [(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)))))

18
syndicate/relay.rkt
View File

@ -30,13 +30,12 @@
(syntax/loc stx (syntax/loc stx
(let ((ds-name name.N)) (let ((ds-name name.N))
(spawn #:name ds-name (spawn #:name ds-name
(define outer-actor (current-actor))
(define outer-facet (current-facet)) (define outer-facet (current-facet))
(define (schedule-inner!) (define (schedule-inner!)
(push-script! (push-script!
outer-actor (facet-actor outer-facet)
(lambda () (lambda ()
(with-current-facet [outer-actor outer-facet] (with-current-facet [outer-facet]
(defer-turn! (lambda () (defer-turn! (lambda ()
(when (run-scripts! inner-ds) (when (run-scripts! inner-ds)
(schedule-inner!)))))))) (schedule-inner!))))))))
@ -47,12 +46,11 @@
(lambda () (lambda ()
(spawn #:name (list 'ds-link ds-name) (spawn #:name (list 'ds-link ds-name)
(boot-relay schedule-inner! (boot-relay schedule-inner!
outer-actor
outer-facet)) outer-facet))
(spawn* form ...)))))) (spawn* form ...))))))
(on-start (schedule-inner!)))))])) (on-start (schedule-inner!)))))]))
(define (boot-relay schedule-inner! outer-actor outer-facet) (define (boot-relay schedule-inner! outer-facet)
(define inbound-endpoints (make-hash)) (define inbound-endpoints (make-hash))
(define outbound-endpoints (make-hash)) (define outbound-endpoints (make-hash))
@ -61,7 +59,7 @@
(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] (with-current-facet [outer-facet]
(with-non-script-context (with-non-script-context
(define i (skeleton-interest (define i (skeleton-interest
(term->skeleton x) (term->skeleton x)
@ -96,14 +94,14 @@
(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] (with-current-facet [outer-facet]
(with-non-script-context (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] (with-current-facet [outer-facet]
(with-non-script-context (with-non-script-context
(hash-set! outbound-endpoints (hash-set! outbound-endpoints
x x
@ -114,12 +112,12 @@
(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] (with-current-facet [outer-facet]
(with-non-script-context (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] (with-current-facet [outer-facet]
(send! x)))) (send! x))))