diff --git a/syndicate/dataspace.rkt b/syndicate/dataspace.rkt index 9bf2ba9..3332ec2 100644 --- a/syndicate/dataspace.rkt +++ b/syndicate/dataspace.rkt @@ -13,14 +13,18 @@ (require "pattern.rkt") (require "bag.rkt") +;; An `ActorID` uniquely identifies an actor in a `Dataspace`. +;; ;; A `FID` is a Facet ID, uniquely identifying both a facet and its ;; ancestry in a `Dataspace`. ;; -;; FID = (Listof Nat) +;; FID = (facet-id ActorID (Listof Nat)) ;; -;; The first `Nat` in the list is the unique identifier for this -;; facet; the `cdr` of the list is the FID of its parent facet. No two -;; `FID`s in a `Dataspace` have the same first `Nat`. +(struct facet-id (actor path) #:prefab) +;; +;; The first `Nat` in `path` is the unique identifier for this facet; +;; the `cdr` of the list is the `path` its parent facet. No two `FID`s +;; in a `Dataspace` have the same first `Nat` in their `path`. ;; A `Dataspace` is a ... TODO @@ -33,7 +37,7 @@ (struct dataspace ([next-id #:mutable] ;; Nat routing-table ;; Skeleton facets ;; (MutableHash FID Facet) - actors ;; (MutableHash FID Any) ;; maps FID to actor name + actors ;; (MutableHash ActorID Any) ;; maps ActorID to actor name assertions ;; (Bagof Assertion) dataflow ;; DataflowGraph pending-scripts ;; (MutableVectorof (Queueof (-> Any))) @@ -41,7 +45,7 @@ ) #:transparent) -(struct facet (id ;; FID +(struct facet (fid ;; FID endpoints ;; (MutableHash EID Endpoint) [stop-scripts #:mutable] ;; (Listof Script) -- IN REVERSE ORDER [children #:mutable] ;; (Setof FID) @@ -59,7 +63,7 @@ ;; it on access. (struct field-handle (name ;; Symbol id ;; Nat - owner ;; FID + owner ;; ActorID [value #:mutable] ;; Any ) #:methods gen:custom-write @@ -135,36 +139,38 @@ (set-dataspace-next-id! ds (+ id 1)) id)) +;; TODO: remove?? (define (fid-parent fid) - (cdr fid)) + (match-define (facet-id actor (cons _ path)) fid) + (facet-id actor path)) (define (generate-fid! ds parent-fid) - (cons (generate-id! ds) parent-fid)) - -(define (actor-fid? fid) - (null? (fid-parent fid))) - -(define (fid->actor-fid fid) - (if (actor-fid? fid) - fid - (fid->actor-fid (fid-parent fid)))) + (match-define (facet-id actor path) parent-fid) + (facet-id actor (cons (generate-id! ds) path))) (define (fid-ancestor? fid maybe-ancestor) - (and (pair? fid) ;; empty fid lists obviously no ancestors at all! - (or (equal? fid maybe-ancestor) - (fid-ancestor? (cdr fid) maybe-ancestor)))) + (and (equal? (facet-id-actor fid) (facet-id-actor maybe-ancestor)) + (let ((b-path (facet-id-path maybe-ancestor))) + (let walk ((a-path (facet-id-path fid))) + (and (pair? a-path) ;; empty fid lists obviously no ancestors at all! + (or (equal? a-path b-path) + (walk (cdr a-path)))))))) + +(define (has-parent? fid) + (pair? (cdr (facet-id-path fid)))) (define (add-actor! ds name boot-proc initial-assertions) - (define actor-fid (generate-fid! ds '())) - (hash-set! (dataspace-actors ds) actor-fid name) + (define actor-id (generate-id! ds)) + (define root-fid (facet-id actor-id (list actor-id))) ;; TODO: bad convention. Use a fresh Nat, don't reuse actor-id in the path + (hash-set! (dataspace-actors ds) actor-id name) (for [(a initial-assertions)] (match (bag-change! (dataspace-assertions ds) a 1) ['absent->present (add-assertion! (dataspace-routing-table ds) a)] ;; 'absent->absent and 'present->absent absurd ['present->present (void)])) ;; i.e. no visible change - (add-facet! ds #f actor-fid (lambda () - (boot-proc) - (for [(a initial-assertions)] (dataspace-retract! ds a))))) + (add-facet! ds #f root-fid (lambda () + (boot-proc) + (for [(a initial-assertions)] (dataspace-retract! ds a))))) (define (lookup-facet ds fid) (hash-ref (dataspace-facets ds) fid #f)) @@ -176,7 +182,7 @@ (current-facet-id fid) (in-script? script?)) (with-handlers ([(lambda (e) (not (exn:break? e))) - (lambda (e) (terminate-actor! ds (fid->actor-fid fid)))]) ;; TODO: tracing + (lambda (e) (terminate-actor! ds (facet-id-actor fid)))]) ;; TODO: tracing body ... (void))))) @@ -258,14 +264,15 @@ '() (set))) (hash-set! (dataspace-facets ds) fid f) - (when (pair? parent-fid) + (when (has-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 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))) + (or (and (has-parent? fid) + (not (facet-live? ds parent-fid))) (facet-live-but-inert? ds fid))) (terminate-facet! ds fid))))) @@ -295,11 +302,9 @@ (when h (dataspace-unsubscribe! ds h)))))) ;; Abruptly terminates an entire actor, without running stop-scripts etc. -(define (terminate-actor! ds actor-fid) - (when (not (actor-fid? actor-fid)) - (error 'terminate-actor! "Attempt to terminate non-actor FID ~a" actor-fid)) - (hash-remove! (dataspace-actors ds) actor-fid) - (let abort-facet! ((fid actor-fid)) +(define (terminate-actor! ds actor-id) + (hash-remove! (dataspace-actors ds) actor-id) + (let abort-facet! ((fid (facet-id actor-id (list actor-id)))) ;; TODO: ugh (define f (lookup-facet ds fid)) (when f (hash-remove! (dataspace-facets ds) fid) @@ -312,7 +317,7 @@ (when f (define parent-fid (fid-parent fid)) - (when (pair? parent-fid) + (when (has-parent? fid) (define pf (lookup-facet ds parent-fid)) (when pf (set-facet-children! pf (set-remove (facet-children pf) fid)))) @@ -335,7 +340,7 @@ #:priority *gc-priority* ds (lambda () - (if (pair? parent-fid) + (if (has-parent? fid) (when (facet-live-but-inert? ds parent-fid) (terminate-facet! ds parent-fid)) (terminate-actor! ds fid)))))) @@ -415,7 +420,7 @@ (lambda () (define current-value (field-handle 'current-value (generate-id! (current-dataspace)) - (fid->actor-fid (current-facet-id)) + (facet-id-actor (current-facet-id)) 0)) (add-endpoint! (current-dataspace) 'stop-when-ten