diff --git a/syndicate/dataspace.rkt b/syndicate/dataspace.rkt index 9b65463..6c0f398 100644 --- a/syndicate/dataspace.rkt +++ b/syndicate/dataspace.rkt @@ -75,15 +75,9 @@ ;; Parameterof Dataspace (define current-dataspace (make-parameter #f)) -;; Parameterof FID -(define current-actor (make-parameter #f)) - ;; Parameterof FID (define current-facet-id (make-parameter #f)) -;; Parameterof Facet -(define current-facet (make-parameter #f)) - ;; Parameterof Boolean (define in-script? (make-parameter #t)) @@ -149,26 +143,22 @@ (define (add-actor! ds boot-proc) (define actor-fid (generate-fid! ds '())) (set-add! (dataspace-actors ds) actor-fid) - (add-facet! ds actor-fid actor-fid boot-proc)) + (add-facet! ds actor-fid boot-proc)) (define (lookup-facet ds fid) (hash-ref (dataspace-facets ds) fid #f)) -(define-syntax-rule (with-current-facet [ds actor-fid fid f script?] body ...) +(define-syntax-rule (with-current-facet [ds fid script?] body ...) (parameterize ((current-dataspace ds) - (current-actor actor-fid) (current-facet-id fid) - (current-facet f) (in-script? script?)) body ...)) (define (capture-facet-context proc) (let ((ds (current-dataspace)) - (actor-fid (current-actor)) - (fid (current-facet-id)) - (f (current-facet))) + (fid (current-facet-id))) (lambda args - (with-current-facet [ds actor-fid fid f #t] + (with-current-facet [ds fid #t] (apply proc args))))) (define (pop-next-script! ds) @@ -191,17 +181,18 @@ (match-define (list fid eid) subject-id) (define f (lookup-facet ds fid)) (when f - (define ep (hash-ref (facet-endpoints f) eid)) - (define old-assertion (endpoint-assertion ep)) - (define new-assertion ((endpoint-assertion-fn ep))) - (when (not (equal? old-assertion new-assertion)) - (set-endpoint-assertion! ep new-assertion) - (dataspace-retract! ds old-assertion) - (dataspace-assert! ds new-assertion) - (define h (endpoint-handler ep)) - (when h - (dataspace-unsubscribe! ds h) - (dataspace-subscribe! ds h)))))) + (with-current-facet [ds fid #f] + (define ep (hash-ref (facet-endpoints f) eid)) + (define old-assertion (endpoint-assertion ep)) + (define new-assertion ((endpoint-assertion-fn ep))) + (when (not (equal? old-assertion new-assertion)) + (set-endpoint-assertion! ep new-assertion) + (dataspace-retract! ds old-assertion) + (dataspace-assert! ds new-assertion) + (define h (endpoint-handler ep)) + (when h + (dataspace-unsubscribe! ds h) + (dataspace-subscribe! ds h))))))) (run-all-pending-scripts! ds)))) (define (perform-pending-actions! ds) @@ -230,7 +221,7 @@ ;; being held elsewhere! (or ran-a-script performed-an-action)) -(define (add-facet! ds actor-fid fid boot-proc) +(define (add-facet! ds fid boot-proc) (define parent-fid (fid-parent fid)) (define f (facet fid (make-hash) @@ -240,13 +231,13 @@ (when (pair? parent-fid) (define pf (lookup-facet ds parent-fid)) (when pf (set-facet-children! pf (set-add (facet-children pf) fid)))) - (with-current-facet [ds actor-fid fid f #f] + (with-current-facet [ds fid #f] (boot-proc)) (schedule-script! ds (lambda () (when (and (facet-live? ds fid) (or (and (pair? parent-fid) (not (facet-live? ds parent-fid))) (facet-live-but-inert? ds fid))) - (terminate-facet! ds actor-fid fid))))) + (terminate-facet! ds fid))))) (define (facet-live? ds fid) (hash-has-key? (dataspace-facets ds) fid)) @@ -259,9 +250,9 @@ (define (schedule-script! #:priority [priority *normal-priority*] ds thunk) (define v (dataspace-pending-scripts ds)) - (vector-set! v priority (enqueue (vector-ref v priority) thunk))) + (vector-set! v priority (enqueue (vector-ref v priority) (capture-facet-context thunk)))) -(define (terminate-facet! ds actor-fid fid) +(define (terminate-facet! ds fid) (define f (lookup-facet ds fid)) (when f (define parent-fid (fid-parent fid)) @@ -273,7 +264,7 @@ (hash-remove! (dataspace-facets ds) fid) (for [(child-fid (in-set (facet-children f)))] - (terminate-facet! ds actor-fid child-fid)) + (terminate-facet! ds child-fid)) ;; Run stop-scripts after terminating children. This means that ;; children's stop-scripts run before ours. @@ -295,21 +286,28 @@ (lambda () (when (and (pair? parent-fid) (facet-live-but-inert? ds parent-fid)) (log-info "terminating ~v because it's dead and child ~v terminated" parent-fid fid) - (terminate-facet! ds actor-fid parent-fid)))))) + (terminate-facet! ds parent-fid)))))) + +(define (stop-facet! ds fid stop-script) + (with-current-facet [ds (fid-parent fid) #t] ;; run in parent context wrt terminating facet + (schedule-script! ds (lambda () + (terminate-facet! ds fid) + (schedule-script! ds stop-script))))) (define (add-endpoint! ds where assertion-fn handler) (when (in-script?) (error 'add-endpoint! "~a: Cannot add endpoint in script; are you missing a (react ...)?" where)) + (define fid (current-facet-id)) (define eid (generate-id! ds)) (define assertion - (parameterize ((current-dataflow-subject-id (list (current-facet-id) eid))) + (parameterize ((current-dataflow-subject-id (list fid eid))) (assertion-fn))) (define ep (endpoint eid assertion assertion-fn handler)) (dataspace-assert! ds assertion) (when handler (dataspace-subscribe! ds handler)) - (hash-set! (facet-endpoints (current-facet)) eid ep)) + (hash-set! (facet-endpoints (lookup-facet ds fid)) eid ep)) (define (ensure-patch-action! ds) (define old-q (dataspace-pending-actions ds)) @@ -355,31 +353,21 @@ 0)) (add-endpoint! (current-dataspace) 'stop-when-ten - (capture-facet-context - (lambda () - (when (= (current-value) 10) - (schedule-script! (current-dataspace) - (capture-facet-context - (lambda () - (schedule-script! - (current-dataspace) - (capture-facet-context - (lambda () - (printf "box: terminating\n")))) - (terminate-facet! (current-dataspace) - (current-actor) - (current-facet-id)))))) - (void))) + (lambda () + (when (= (current-value) 10) + (stop-facet! (current-dataspace) + (current-facet-id) + (lambda () + (printf "box: terminating\n")))) + (void)) #f) (add-endpoint! (current-dataspace) 'assert-box-state - (capture-facet-context - (lambda () (box-state (current-value)))) + (lambda () (box-state (current-value))) #f) (add-endpoint! (current-dataspace) 'on-message-set-box - (capture-facet-context - (lambda () (observe (set-box (capture (discard)))))) + (lambda () (observe (set-box (capture (discard))))) (skeleton-interest (list struct:set-box #f) '() '() @@ -389,16 +377,14 @@ (when (eq? '! op) (schedule-script! (current-dataspace) - (capture-facet-context - (lambda () - (printf "new-value ~a ~v\n" op new-value) - (current-value new-value))))))))))) + (lambda () + (printf "new-value ~a ~v\n" op new-value) + (current-value new-value)))))))))) (add-actor! ds (lambda () (add-endpoint! (current-dataspace) 'stop-when-retracted-observe-set-box - (capture-facet-context - (lambda () (observe (observe (set-box (discard)))))) + (lambda () (observe (observe (set-box (discard))))) (skeleton-interest (list struct:observe (list struct:set-box #f)) '() '() @@ -406,22 +392,14 @@ (capture-facet-context (lambda (op) (when (eq? '- op) - (schedule-script! + (stop-facet! (current-dataspace) - (capture-facet-context - (lambda () - (schedule-script! - (current-dataspace) - (capture-facet-context - (lambda () - (printf "client: box has gone\n")))) - (terminate-facet! (current-dataspace) - (current-actor) - (current-facet-id)))))))))) + (current-facet-id) + (lambda () + (printf "client: box has gone\n")))))))) (add-endpoint! (current-dataspace) 'on-asserted-box-state - (capture-facet-context - (lambda () (observe (box-state (capture (discard)))))) + (lambda () (observe (box-state (capture (discard))))) (skeleton-interest (list struct:box-state #f) '() '() @@ -431,11 +409,10 @@ (when (eq? '+ op) (schedule-script! (current-dataspace) - (capture-facet-context - (lambda () - (printf "v ~a ~v\n" op v) - (dataspace-send! (current-dataspace) - (set-box (+ v 1))))))))))))) + (lambda () + (printf "v ~a ~v\n" op v) + (dataspace-send! (current-dataspace) + (set-box (+ v 1)))))))))))) (require racket/pretty) (pretty-print ds)