Eliminate (interesting uses of) facet IDs by storing references directly

This commit is contained in:
Tony Garnock-Jones 2018-04-08 08:52:37 +01:00
parent fe6b895d8a
commit e84f2e2e39
2 changed files with 104 additions and 121 deletions

View File

@ -14,17 +14,7 @@
(require "bag.rkt") (require "bag.rkt")
;; An `ActorID` uniquely identifies an actor in a `Dataspace`. ;; An `ActorID` uniquely identifies an actor in a `Dataspace`.
;; ;; A `FID` is a Facet ID, uniquely identifying a facet in a `Dataspace`.
;; A `FID` is a Facet ID, uniquely identifying both a facet and its
;; ancestry in a `Dataspace`.
;;
;; FID = (facet-id ActorID (Listof 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 ;; A `Dataspace` is a ... TODO
@ -36,34 +26,50 @@
(struct dataspace ([next-id #:mutable] ;; Nat (struct dataspace ([next-id #:mutable] ;; Nat
routing-table ;; Skeleton routing-table ;; Skeleton
facets ;; (MutableHash FID Facet) actors ;; (MutableHash ActorID Actor)
actors ;; (MutableHash ActorID Any) ;; maps ActorID to actor name
assertions ;; (Bagof Assertion) assertions ;; (Bagof Assertion)
dataflow ;; DataflowGraph dataflow ;; DataflowGraph
pending-scripts ;; (MutableVectorof (Queueof (-> Any))) pending-scripts ;; (MutableVectorof (Queueof (-> Any)))
[pending-actions #:mutable] ;; (Queueof Action) [pending-actions #:mutable] ;; (Queueof Action)
) ))
#:transparent)
(struct facet (fid ;; FID (struct actor (id ;; ActorID
name ;; Any
[root-facet #:mutable] ;; (Option Facet)
)
#:methods gen:custom-write
[(define (write-proc a p mode)
(fprintf p "#<actor ~a ~v>" (actor-id a) (actor-name a)))])
(struct facet (id ;; FID
[live? #:mutable] ;; Boolean
actor ;; Actor
parent ;; (Option Facet)
endpoints ;; (MutableHash EID Endpoint) endpoints ;; (MutableHash EID Endpoint)
[stop-scripts #:mutable] ;; (Listof Script) -- IN REVERSE ORDER [stop-scripts #:mutable] ;; (Listof Script) -- IN REVERSE ORDER
[children #:mutable] ;; (Setof FID) [children #:mutable] ;; (Seteqof Facet)
) )
#:transparent) #:methods gen:custom-write
[(define (write-proc f p mode)
(fprintf p "#<facet ~a ~v ~a>"
(actor-id (facet-actor f))
(actor-name (facet-actor f))
(facet-id f)))])
(struct endpoint (id ;; EID (struct endpoint (id ;; EID
[assertion #:mutable] ;; Assertion [assertion #:mutable] ;; Assertion
assertion-fn ;; (-> Assertion) assertion-fn ;; (-> Assertion)
handler ;; (Option SkInterest) handler ;; (Option SkInterest)
) )
#:transparent) #:methods gen:custom-write
[(define (write-proc e p mode)
(fprintf p "#<endpoint ~a>" (endpoint-id e)))])
;; TODO: field ownership: record actor (root facet) ID in field, check ;; TODO: field ownership: record actor (root facet) ID in field, check
;; it on access. ;; it on access.
(struct field-handle (name ;; Symbol (struct field-handle (name ;; Symbol
id ;; Nat id ;; Nat
owner ;; ActorID owner ;; Actor
[value #:mutable] ;; Any [value #:mutable] ;; Any
) )
#:methods gen:custom-write #:methods gen:custom-write
@ -81,8 +87,11 @@
;; Parameterof Dataspace ;; Parameterof Dataspace
(define current-dataspace (make-parameter #f)) (define current-dataspace (make-parameter #f))
;; Parameterof FID ;; Parameterof Actor
(define current-facet-id (make-parameter #f)) (define current-actor (make-parameter #f))
;; Parameterof Facet
(define current-facet (make-parameter #f))
;; Parameterof Boolean ;; Parameterof Boolean
(define in-script? (make-parameter #t)) (define in-script? (make-parameter #t))
@ -126,7 +135,6 @@
(define ds (dataspace 0 (define ds (dataspace 0
(make-empty-skeleton) (make-empty-skeleton)
(make-hash) (make-hash)
(make-hash)
(make-bag) (make-bag)
(make-dataflow-graph) (make-dataflow-graph)
(make-vector priority-count (make-queue)) (make-vector priority-count (make-queue))
@ -139,58 +147,42 @@
(set-dataspace-next-id! ds (+ id 1)) (set-dataspace-next-id! ds (+ id 1))
id)) id))
;; TODO: remove??
(define (fid-parent fid)
(match-define (facet-id actor (cons _ path)) fid)
(facet-id actor path))
(define (generate-fid! ds 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 (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 (add-actor! ds name boot-proc initial-assertions)
(define actor-id (generate-id! ds)) (define the-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 (define the-actor (actor the-actor-id name #f))
(hash-set! (dataspace-actors ds) actor-id name) (hash-set! (dataspace-actors ds) the-actor-id the-actor)
(for [(a initial-assertions)] (for [(a initial-assertions)]
(match (bag-change! (dataspace-assertions ds) a 1) (match (bag-change! (dataspace-assertions ds) a 1)
['absent->present (add-assertion! (dataspace-routing-table ds) a)] ['absent->present (add-assertion! (dataspace-routing-table ds) a)]
;; 'absent->absent and 'present->absent absurd ;; 'absent->absent and 'present->absent absurd
['present->present (void)])) ;; i.e. no visible change ['present->present (void)])) ;; i.e. no visible change
(add-facet! ds #f root-fid (lambda () (add-facet! ds
(boot-proc) #f
(for [(a initial-assertions)] (dataspace-retract! ds a))))) the-actor
#f
(lambda ()
(boot-proc)
(for [(a initial-assertions)] (dataspace-retract! ds a)))))
(define (lookup-facet ds fid) (define-syntax-rule (with-current-facet [ds0 a0 f0 script?] body ...)
(hash-ref (dataspace-facets ds) fid #f))
(define-syntax-rule (with-current-facet [ds0 fid0 script?] body ...)
(let ((ds ds0) (let ((ds ds0)
(fid fid0)) (a a0)
(f f0))
(parameterize ((current-dataspace ds) (parameterize ((current-dataspace ds)
(current-facet-id fid) (current-actor a)
(current-facet f)
(in-script? script?)) (in-script? script?))
(with-handlers ([(lambda (e) (not (exn:break? e))) (with-handlers ([(lambda (e) (not (exn:break? e)))
(lambda (e) (terminate-actor! ds (facet-id-actor fid)))]) ;; TODO: tracing (lambda (e) (terminate-actor! ds a))]) ;; TODO: tracing
body ... body ...
(void))))) (void)))))
(define (capture-facet-context proc) (define (capture-facet-context proc)
(let ((ds (current-dataspace)) (let ((ds (current-dataspace))
(fid (current-facet-id))) (a (current-actor))
(f (current-facet)))
(lambda args (lambda args
(with-current-facet [ds fid #t] (with-current-facet [ds a f #t]
(apply proc args))))) (apply proc args)))))
(define (pop-next-script! ds) (define (pop-next-script! ds)
@ -210,10 +202,9 @@
(begin (script) (begin (script)
(dataflow-repair-damage! (dataspace-dataflow ds) (dataflow-repair-damage! (dataspace-dataflow ds)
(lambda (subject-id) (lambda (subject-id)
(match-define (list fid eid) subject-id) (match-define (list f eid) subject-id)
(define f (lookup-facet ds fid)) (when (facet-live? f) ;; TODO: necessary test, or tautological?
(when f (with-current-facet [ds (facet-actor f) f #f]
(with-current-facet [ds fid #f]
(define ep (hash-ref (facet-endpoints f) eid)) (define ep (hash-ref (facet-endpoints f) eid))
(define old-assertion (endpoint-assertion ep)) (define old-assertion (endpoint-assertion ep))
(define new-assertion ((endpoint-assertion-fn ep))) (define new-assertion ((endpoint-assertion-fn ep)))
@ -253,36 +244,31 @@
;; being held elsewhere! ;; being held elsewhere!
(or ran-a-script performed-an-action)) (or ran-a-script performed-an-action))
(define (add-facet! ds where fid boot-proc) (define (add-facet! ds where actor parent boot-proc)
(when (and (not (in-script?)) where) (when (and (not (in-script?)) where)
(error 'add-facet! (error 'add-facet!
"~a: Cannot add facet outside script; are you missing an (on ...)?" "~a: Cannot add facet outside script; are you missing an (on ...)?"
where)) where))
(define parent-fid (fid-parent fid)) (define f (facet (generate-id! ds)
(define f (facet fid #t
actor
parent
(make-hash) (make-hash)
'() '()
(set))) (seteq)))
(hash-set! (dataspace-facets ds) fid f) (if parent
(when (has-parent? fid) (set-facet-children! parent (set-add (facet-children parent) f))
(define pf (lookup-facet ds parent-fid)) (set-actor-root-facet! actor f))
(when pf (set-facet-children! pf (set-add (facet-children pf) fid)))) (with-current-facet [ds actor f #f]
(with-current-facet [ds fid #f]
(boot-proc)) (boot-proc))
(schedule-script!* ds (lambda () (schedule-script!* ds (lambda ()
(when (and (facet-live? ds fid) (when (and (facet-live? f)
(or (and (has-parent? fid) (or (and parent (not (facet-live? parent)))
(not (facet-live? ds parent-fid))) (facet-inert? ds f)))
(facet-live-but-inert? ds fid))) (terminate-facet! ds f)))))
(terminate-facet! ds fid)))))
(define (facet-live? ds fid) (define (facet-inert? ds f)
(hash-has-key? (dataspace-facets ds) fid)) (and (hash-empty? (facet-endpoints f))
(define (facet-live-but-inert? ds fid)
(define f (lookup-facet ds fid))
(and f
(hash-empty? (facet-endpoints f))
(set-empty? (facet-children f)))) (set-empty? (facet-children f))))
(define (schedule-script! #:priority [priority *normal-priority*] ds thunk) (define (schedule-script! #:priority [priority *normal-priority*] ds thunk)
@ -292,82 +278,78 @@
(define v (dataspace-pending-scripts ds)) (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) thunk)))
;; Precondition: `f` is the `facet` struct that is/was associated with `fid` in `ds` (define (retract-facet-assertions-and-subscriptions! ds f)
(define (retract-facet-assertions-and-subscriptions! ds fid f)
(schedule-script!* ds (lambda () (schedule-script!* ds (lambda ()
(for [((eid ep) (in-hash (facet-endpoints f)))] (for [((eid ep) (in-hash (facet-endpoints f)))]
(dataflow-forget-subject! (dataspace-dataflow ds) (list fid eid)) (dataflow-forget-subject! (dataspace-dataflow ds) (list f eid))
(dataspace-retract! ds (endpoint-assertion ep)) (dataspace-retract! ds (endpoint-assertion ep))
(define h (endpoint-handler ep)) (define h (endpoint-handler ep))
(when h (dataspace-unsubscribe! ds h)))))) (when h (dataspace-unsubscribe! ds h))))))
;; Abruptly terminates an entire actor, without running stop-scripts etc. ;; Abruptly terminates an entire actor, without running stop-scripts etc.
(define (terminate-actor! ds actor-id) (define (terminate-actor! ds the-actor)
(hash-remove! (dataspace-actors ds) actor-id) (hash-remove! (dataspace-actors ds) (actor-id the-actor))
(let abort-facet! ((fid (facet-id actor-id (list actor-id)))) ;; TODO: ugh (let ((f (actor-root-facet the-actor)))
(define f (lookup-facet ds fid))
(when f (when f
(hash-remove! (dataspace-facets ds) fid) (let abort-facet! ((f f))
(for [(child-fid (in-set (facet-children f)))] (abort-facet! child-fid)) (set-facet-live?! f #f)
(retract-facet-assertions-and-subscriptions! ds fid f)))) (for [(child (in-set (facet-children f)))] (abort-facet! child))
(retract-facet-assertions-and-subscriptions! ds f)))))
;; Cleanly terminates a facet and its children, running stop-scripts etc. ;; Cleanly terminates a facet and its children, running stop-scripts etc.
(define (terminate-facet! ds fid) (define (terminate-facet! ds f)
(define f (lookup-facet ds fid)) (when (facet-live? f)
(when f (define parent (facet-parent f))
(define parent-fid (fid-parent fid)) (if parent
(set-facet-children! parent (set-remove (facet-children parent) f))
(set-actor-root-facet! (facet-actor f) #f))
(when (has-parent? fid) (set-facet-live?! f #f)
(define pf (lookup-facet ds parent-fid))
(when pf (set-facet-children! pf (set-remove (facet-children pf) fid))))
(hash-remove! (dataspace-facets ds) fid) (for [(child (in-set (facet-children f)))] (terminate-facet! ds child))
(for [(child-fid (in-set (facet-children f)))]
(terminate-facet! ds child-fid))
;; 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.
(for [(script (reverse (facet-stop-scripts f)))] (for [(script (reverse (facet-stop-scripts f)))]
(schedule-script! ds (schedule-script! ds
(lambda () (lambda ()
(with-current-facet [ds fid #t] (with-current-facet [ds (facet-actor f) f #t]
(script))))) (script)))))
(retract-facet-assertions-and-subscriptions! ds fid f) (retract-facet-assertions-and-subscriptions! ds f)
(schedule-script!* (schedule-script!*
#:priority *gc-priority* #:priority *gc-priority*
ds ds
(lambda () (lambda ()
(if (has-parent? fid) (if parent
(when (facet-live-but-inert? ds parent-fid) (terminate-facet! ds parent-fid)) (when (facet-inert? ds parent) (terminate-facet! ds parent))
(terminate-actor! ds fid)))))) (terminate-actor! ds (facet-actor f)))))))
(define (stop-facet! ds fid stop-script) (define (stop-facet! ds f stop-script)
(with-current-facet [ds (fid-parent fid) #t] ;; run in parent context wrt terminating facet (with-current-facet [ds (facet-actor f) f #t] ;; run in parent context wrt terminating facet
(schedule-script! ds (lambda () (schedule-script! ds (lambda ()
(terminate-facet! ds fid) (terminate-facet! ds f)
(schedule-script! ds stop-script))))) (schedule-script! ds stop-script)))))
(define (add-stop-script! ds script-proc) (define (add-stop-script! ds script-proc)
(define f (lookup-facet ds (current-facet-id))) (define f (current-facet))
(when f (set-facet-stop-scripts! f (cons script-proc (facet-stop-scripts f))))) (set-facet-stop-scripts! f (cons script-proc (facet-stop-scripts f))))
(define (add-endpoint! ds where assertion-fn handler) (define (add-endpoint! ds where assertion-fn handler)
(when (in-script?) (when (in-script?)
(error 'add-endpoint! (error 'add-endpoint!
"~a: Cannot add endpoint in script; are you missing a (react ...)?" "~a: Cannot add endpoint in script; are you missing a (react ...)?"
where)) where))
(define fid (current-facet-id)) (define f (current-facet))
(define eid (generate-id! ds)) (define eid (generate-id! ds))
(define assertion (define assertion
(parameterize ((current-dataflow-subject-id (list fid eid))) (parameterize ((current-dataflow-subject-id (list f eid)))
(assertion-fn))) (assertion-fn)))
(define ep (endpoint eid assertion assertion-fn handler)) (define ep (endpoint eid assertion assertion-fn handler))
(dataspace-assert! ds assertion) (dataspace-assert! ds assertion)
(when handler (dataspace-subscribe! ds handler)) (when handler (dataspace-subscribe! ds handler))
(hash-set! (facet-endpoints (lookup-facet ds fid)) eid ep)) (hash-set! (facet-endpoints f) eid ep))
(define (enqueue-action! ds action) (define (enqueue-action! ds action)
(set-dataspace-pending-actions! ds (enqueue (dataspace-pending-actions ds) action))) (set-dataspace-pending-actions! ds (enqueue (dataspace-pending-actions ds) action)))
@ -420,14 +402,14 @@
(lambda () (lambda ()
(define current-value (field-handle 'current-value (define current-value (field-handle 'current-value
(generate-id! (current-dataspace)) (generate-id! (current-dataspace))
(facet-id-actor (current-facet-id)) (facet-actor (current-facet))
0)) 0))
(add-endpoint! (current-dataspace) (add-endpoint! (current-dataspace)
'stop-when-ten 'stop-when-ten
(lambda () (lambda ()
(when (= (current-value) 10) (when (= (current-value) 10)
(stop-facet! (current-dataspace) (stop-facet! (current-dataspace)
(current-facet-id) (current-facet)
(lambda () (lambda ()
(log-info "box: terminating")))) (log-info "box: terminating"))))
(void)) (void))
@ -468,7 +450,7 @@
(when (eq? '- op) (when (eq? '- op)
(stop-facet! (stop-facet!
(current-dataspace) (current-dataspace)
(current-facet-id) (current-facet)
(lambda () (lambda ()
(log-info "client: box has gone")))))))) (log-info "client: box has gone"))))))))
(add-endpoint! (current-dataspace) (add-endpoint! (current-dataspace)

View File

@ -134,7 +134,8 @@
(define ds (current-dataspace)) (define ds (current-dataspace))
(add-facet! ds (add-facet! ds
where where
(generate-fid! ds (current-facet-id)) (current-actor)
(current-facet)
boot-proc)) boot-proc))
(define-syntax (react stx) (define-syntax (react stx)