Eliminate another parameter: now only `current-facet` remains
This commit is contained in:
parent
14ee4f70ef
commit
0e37037b6e
|
@ -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)))))
|
||||||
|
|
|
@ -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))))
|
||||||
|
|
Loading…
Reference in New Issue