Steps toward API usable by syntax layer; beginning of syntax layer, adapted from previous implementation
This commit is contained in:
Tony Garnock-Jones
parent
7f65d9e452
commit
3c70496688
|
|
@ -1,5 +1,7 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide )
|
||||
|
||||
(require syndicate/functional-queue)
|
||||
(require syndicate/dataflow)
|
||||
(require racket/match)
|
||||
|
|
@ -23,15 +25,15 @@
|
|||
;; A `Dataspace` is a ... TODO
|
||||
|
||||
;; An `Action` is either `(patch (Deltaof Assertion))` or `(message
|
||||
;; Assertion)` or `(spawn BootProc)`.
|
||||
;; Assertion)` or `(spawn Any BootProc (Set Assertion))`.
|
||||
(struct patch (changes) #:prefab)
|
||||
(struct message (body) #:prefab)
|
||||
(struct spawn (boot-proc) #:prefab)
|
||||
(struct spawn (name boot-proc initial-assertions) #:prefab)
|
||||
|
||||
(struct dataspace ([next-id #:mutable] ;; Nat
|
||||
routing-table ;; Skeleton
|
||||
facets ;; (MutableHash FID Facet)
|
||||
actors ;; (MutableSetof FID)
|
||||
actors ;; (MutableHash FID Any) ;; maps FID to actor name
|
||||
assertions ;; (Bagof Assertion)
|
||||
dataflow ;; DataflowGraph
|
||||
pending-scripts ;; (MutableVectorof (Queueof (-> Any)))
|
||||
|
|
@ -116,15 +118,17 @@
|
|||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define (make-dataspace)
|
||||
(dataspace 0
|
||||
(make-empty-skeleton)
|
||||
(make-hash)
|
||||
(mutable-set)
|
||||
(make-bag)
|
||||
(make-dataflow-graph)
|
||||
(make-vector priority-count (make-queue))
|
||||
(make-queue)))
|
||||
(define (make-dataspace name boot-proc)
|
||||
(define ds (dataspace 0
|
||||
(make-empty-skeleton)
|
||||
(make-hash)
|
||||
(make-hash)
|
||||
(make-bag)
|
||||
(make-dataflow-graph)
|
||||
(make-vector priority-count (make-queue))
|
||||
(make-queue)))
|
||||
(dataspace-spawn! ds name boot-proc (set))
|
||||
ds)
|
||||
|
||||
(define (generate-id! ds)
|
||||
(let ((id (dataspace-next-id ds)))
|
||||
|
|
@ -140,19 +144,41 @@
|
|||
(define (actor-fid? fid)
|
||||
(null? (fid-parent fid)))
|
||||
|
||||
(define (add-actor! ds boot-proc)
|
||||
(define (fid->actor-fid fid)
|
||||
(if (actor-fid? fid)
|
||||
fid
|
||||
(fid->actor-fid (fid-parent fid))))
|
||||
|
||||
(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))))
|
||||
|
||||
(define (add-actor! ds name boot-proc initial-assertions)
|
||||
(define actor-fid (generate-fid! ds '()))
|
||||
(set-add! (dataspace-actors ds) actor-fid)
|
||||
(add-facet! ds actor-fid boot-proc))
|
||||
(hash-set! (dataspace-actors ds) actor-fid 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)))))
|
||||
|
||||
(define (lookup-facet ds fid)
|
||||
(hash-ref (dataspace-facets ds) fid #f))
|
||||
|
||||
(define-syntax-rule (with-current-facet [ds fid script?] body ...)
|
||||
(parameterize ((current-dataspace ds)
|
||||
(current-facet-id fid)
|
||||
(in-script? script?))
|
||||
body ...))
|
||||
(define-syntax-rule (with-current-facet [ds0 fid0 script?] body ...)
|
||||
(let ((ds ds0)
|
||||
(fid fid0))
|
||||
(parameterize ((current-dataspace ds)
|
||||
(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
|
||||
body ...
|
||||
(void)))))
|
||||
|
||||
(define (capture-facet-context proc)
|
||||
(let ((ds (current-dataspace))
|
||||
|
|
@ -209,8 +235,8 @@
|
|||
['present->present (void)]))] ;; i.e. no visible change
|
||||
[(message body)
|
||||
(send-assertion! (dataspace-routing-table ds) body)]
|
||||
[(spawn boot-proc)
|
||||
(add-actor! ds boot-proc)]))
|
||||
[(spawn name boot-proc initial-assertions)
|
||||
(add-actor! ds name boot-proc initial-assertions)]))
|
||||
(not (null? actions)))
|
||||
|
||||
(define (run-scripts! ds)
|
||||
|
|
@ -221,7 +247,11 @@
|
|||
;; being held elsewhere!
|
||||
(or ran-a-script performed-an-action))
|
||||
|
||||
(define (add-facet! ds fid boot-proc)
|
||||
(define (add-facet! ds where fid boot-proc)
|
||||
(when (and (not (in-script?)) where)
|
||||
(error 'add-facet!
|
||||
"~a: Cannot add facet outside script; are you missing an (on ...)?"
|
||||
where))
|
||||
(define parent-fid (fid-parent fid))
|
||||
(define f (facet fid
|
||||
(make-hash)
|
||||
|
|
@ -233,11 +263,11 @@
|
|||
(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)))
|
||||
(facet-live-but-inert? ds fid)))
|
||||
(terminate-facet! ds fid)))))
|
||||
(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 fid)))))
|
||||
|
||||
(define (facet-live? ds fid)
|
||||
(hash-has-key? (dataspace-facets ds) fid))
|
||||
|
|
@ -249,9 +279,34 @@
|
|||
(set-empty? (facet-children f))))
|
||||
|
||||
(define (schedule-script! #:priority [priority *normal-priority*] ds thunk)
|
||||
(define v (dataspace-pending-scripts ds))
|
||||
(vector-set! v priority (enqueue (vector-ref v priority) (capture-facet-context thunk))))
|
||||
(schedule-script!* #:priority priority ds (capture-facet-context thunk)))
|
||||
|
||||
(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)))
|
||||
|
||||
;; Precondition: `f` is the `facet` struct that is/was associated with `fid` in `ds`
|
||||
(define (retract-facet-assertions-and-subscriptions! ds fid f)
|
||||
(schedule-script!* ds (lambda ()
|
||||
(for [((eid ep) (in-hash (facet-endpoints f)))]
|
||||
(dataflow-forget-subject! (dataspace-dataflow ds) (list fid eid))
|
||||
(dataspace-retract! ds (endpoint-assertion ep))
|
||||
(define h (endpoint-handler ep))
|
||||
(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 f (lookup-facet ds fid))
|
||||
(when f
|
||||
(hash-remove! (dataspace-facets ds) fid)
|
||||
(for [(child-fid (in-set (facet-children f)))] (abort-facet! child-fid))
|
||||
(retract-facet-assertions-and-subscriptions! ds fid f))))
|
||||
|
||||
;; Cleanly terminates a facet and its children, running stop-scripts etc.
|
||||
(define (terminate-facet! ds fid)
|
||||
(define f (lookup-facet ds fid))
|
||||
(when f
|
||||
|
|
@ -269,24 +324,20 @@
|
|||
;; Run stop-scripts after terminating children. This means that
|
||||
;; children's stop-scripts run before ours.
|
||||
(for [(script (reverse (facet-stop-scripts f)))]
|
||||
(schedule-script! ds script))
|
||||
(schedule-script! ds
|
||||
(lambda ()
|
||||
(with-current-facet [ds fid #t]
|
||||
(script)))))
|
||||
|
||||
(schedule-script!
|
||||
ds
|
||||
(lambda ()
|
||||
(for [((eid ep) (in-hash (facet-endpoints f)))]
|
||||
(dataflow-forget-subject! (dataspace-dataflow ds) (list fid eid))
|
||||
(dataspace-retract! ds (endpoint-assertion ep))
|
||||
(define h (endpoint-handler ep))
|
||||
(when h (dataspace-unsubscribe! ds h)))))
|
||||
(retract-facet-assertions-and-subscriptions! ds fid f)
|
||||
|
||||
(schedule-script!
|
||||
(schedule-script!*
|
||||
#:priority *gc-priority*
|
||||
ds
|
||||
(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 parent-fid))))))
|
||||
(if (pair? parent-fid)
|
||||
(when (facet-live-but-inert? ds parent-fid) (terminate-facet! ds parent-fid))
|
||||
(terminate-actor! ds fid))))))
|
||||
|
||||
(define (stop-facet! ds fid stop-script)
|
||||
(with-current-facet [ds (fid-parent fid) #t] ;; run in parent context wrt terminating facet
|
||||
|
|
@ -294,6 +345,10 @@
|
|||
(terminate-facet! ds fid)
|
||||
(schedule-script! ds stop-script)))))
|
||||
|
||||
(define (add-stop-script! ds script-proc)
|
||||
(define f (lookup-facet ds (current-facet-id)))
|
||||
(when f (set-facet-stop-scripts! f (cons script-proc (facet-stop-scripts f)))))
|
||||
|
||||
(define (add-endpoint! ds where assertion-fn handler)
|
||||
(when (in-script?)
|
||||
(error 'add-endpoint!
|
||||
|
|
@ -309,10 +364,13 @@
|
|||
(when handler (dataspace-subscribe! ds handler))
|
||||
(hash-set! (facet-endpoints (lookup-facet ds fid)) eid ep))
|
||||
|
||||
(define (enqueue-action! ds action)
|
||||
(set-dataspace-pending-actions! ds (enqueue (dataspace-pending-actions ds) action)))
|
||||
|
||||
(define (ensure-patch-action! ds)
|
||||
(define old-q (dataspace-pending-actions ds))
|
||||
(when (or (queue-empty? old-q) (not (patch? (queue-last old-q))))
|
||||
(set-dataspace-pending-actions! ds (enqueue old-q (patch (make-bag)))))
|
||||
(let ((q (dataspace-pending-actions ds)))
|
||||
(when (or (queue-empty? q) (not (patch? (queue-last q))))
|
||||
(enqueue-action! ds (patch (make-bag)))))
|
||||
(patch-changes (queue-last (dataspace-pending-actions ds))))
|
||||
|
||||
(define (dataspace-retract! ds assertion)
|
||||
|
|
@ -330,7 +388,10 @@
|
|||
(add-interest! (dataspace-routing-table ds) h))
|
||||
|
||||
(define (dataspace-send! ds body)
|
||||
(set-dataspace-pending-actions! ds (enqueue (dataspace-pending-actions ds) (message body))))
|
||||
(enqueue-action! ds (message body)))
|
||||
|
||||
(define (dataspace-spawn! ds name boot-proc initial-assertions)
|
||||
(enqueue-action! ds (spawn name boot-proc initial-assertions)))
|
||||
|
||||
(module+ test
|
||||
;; TODO: move somewhere sensible
|
||||
|
|
@ -344,82 +405,92 @@
|
|||
;; TODO: move somewhere sensible
|
||||
(assertion-struct observe (specification))
|
||||
|
||||
(define ds (make-dataspace))
|
||||
(add-actor! ds
|
||||
(lambda ()
|
||||
(define current-value (field-handle 'current-value
|
||||
(generate-id! (current-dataspace))
|
||||
(current-facet-id)
|
||||
0))
|
||||
(add-endpoint! (current-dataspace)
|
||||
'stop-when-ten
|
||||
(lambda ()
|
||||
(when (= (current-value) 10)
|
||||
(stop-facet! (current-dataspace)
|
||||
(current-facet-id)
|
||||
(lambda ()
|
||||
(log-info "box: terminating"))))
|
||||
(void))
|
||||
#f)
|
||||
(add-endpoint! (current-dataspace)
|
||||
'assert-box-state
|
||||
(lambda () (box-state (current-value)))
|
||||
#f)
|
||||
(add-endpoint! (current-dataspace)
|
||||
'on-message-set-box
|
||||
(lambda () (observe (set-box (capture (discard)))))
|
||||
(skeleton-interest (list struct:set-box #f)
|
||||
'()
|
||||
'()
|
||||
'((0 0))
|
||||
(capture-facet-context
|
||||
(lambda (op new-value)
|
||||
(when (eq? '! op)
|
||||
(schedule-script!
|
||||
(current-dataspace)
|
||||
(lambda ()
|
||||
(log-info "box: taking on new-value ~v" new-value)
|
||||
(current-value new-value))))))))))
|
||||
(add-actor! ds
|
||||
(lambda ()
|
||||
(add-endpoint! (current-dataspace)
|
||||
'stop-when-retracted-observe-set-box
|
||||
(lambda () (observe (observe (set-box (discard)))))
|
||||
(skeleton-interest (list struct:observe (list struct:set-box #f))
|
||||
'()
|
||||
'()
|
||||
'()
|
||||
(capture-facet-context
|
||||
(lambda (op)
|
||||
(when (eq? '- op)
|
||||
(stop-facet!
|
||||
(current-dataspace)
|
||||
(current-facet-id)
|
||||
(lambda ()
|
||||
(log-info "client: box has gone"))))))))
|
||||
(add-endpoint! (current-dataspace)
|
||||
'on-asserted-box-state
|
||||
(lambda () (observe (box-state (capture (discard)))))
|
||||
(skeleton-interest (list struct:box-state #f)
|
||||
'()
|
||||
'()
|
||||
'((0 0))
|
||||
(capture-facet-context
|
||||
(lambda (op v)
|
||||
(when (eq? '+ op)
|
||||
(schedule-script!
|
||||
(current-dataspace)
|
||||
(lambda ()
|
||||
(log-info "client: learned that box's value is now ~v" v)
|
||||
(dataspace-send! (current-dataspace)
|
||||
(set-box (+ v 1))))))))))))
|
||||
(define ds
|
||||
(make-dataspace
|
||||
'ground
|
||||
(lambda ()
|
||||
(dataspace-spawn!
|
||||
ds
|
||||
'box
|
||||
(lambda ()
|
||||
(define current-value (field-handle 'current-value
|
||||
(generate-id! (current-dataspace))
|
||||
(fid->actor-fid (current-facet-id))
|
||||
0))
|
||||
(add-endpoint! (current-dataspace)
|
||||
'stop-when-ten
|
||||
(lambda ()
|
||||
(when (= (current-value) 10)
|
||||
(stop-facet! (current-dataspace)
|
||||
(current-facet-id)
|
||||
(lambda ()
|
||||
(log-info "box: terminating"))))
|
||||
(void))
|
||||
#f)
|
||||
(add-endpoint! (current-dataspace)
|
||||
'assert-box-state
|
||||
(lambda () (box-state (current-value)))
|
||||
#f)
|
||||
(add-endpoint! (current-dataspace)
|
||||
'on-message-set-box
|
||||
(lambda () (observe (set-box (capture (discard)))))
|
||||
(skeleton-interest (list struct:set-box #f)
|
||||
'()
|
||||
'()
|
||||
'((0 0))
|
||||
(capture-facet-context
|
||||
(lambda (op new-value)
|
||||
(when (eq? '! op)
|
||||
(schedule-script!
|
||||
(current-dataspace)
|
||||
(lambda ()
|
||||
(log-info "box: taking on new-value ~v" new-value)
|
||||
(current-value new-value)))))))))
|
||||
(set))
|
||||
(dataspace-spawn!
|
||||
ds
|
||||
'client
|
||||
(lambda ()
|
||||
(add-endpoint! (current-dataspace)
|
||||
'stop-when-retracted-observe-set-box
|
||||
(lambda () (observe (observe (set-box (discard)))))
|
||||
(skeleton-interest (list struct:observe (list struct:set-box #f))
|
||||
'()
|
||||
'()
|
||||
'()
|
||||
(capture-facet-context
|
||||
(lambda (op)
|
||||
(when (eq? '- op)
|
||||
(stop-facet!
|
||||
(current-dataspace)
|
||||
(current-facet-id)
|
||||
(lambda ()
|
||||
(log-info "client: box has gone"))))))))
|
||||
(add-endpoint! (current-dataspace)
|
||||
'on-asserted-box-state
|
||||
(lambda () (observe (box-state (capture (discard)))))
|
||||
(skeleton-interest (list struct:box-state #f)
|
||||
'()
|
||||
'()
|
||||
'((0 0))
|
||||
(capture-facet-context
|
||||
(lambda (op v)
|
||||
(when (eq? '+ op)
|
||||
(schedule-script!
|
||||
(current-dataspace)
|
||||
(lambda ()
|
||||
(log-info "client: learned that box's value is now ~v" v)
|
||||
(dataspace-send! (current-dataspace)
|
||||
(set-box (+ v 1)))))))))))
|
||||
(set)))))
|
||||
|
||||
(require racket/pretty)
|
||||
;; (pretty-print ds)
|
||||
(let loop ((i 0))
|
||||
;; (printf "--- i = ~v\n" i)
|
||||
(when (run-scripts! ds)
|
||||
;; (pretty-print ds)
|
||||
(loop (+ i 1))))
|
||||
(#;time values
|
||||
(let loop ((i 0))
|
||||
;; (printf "--- i = ~v\n" i)
|
||||
(when (run-scripts! ds)
|
||||
;; (pretty-print ds)
|
||||
(loop (+ i 1)))))
|
||||
;; (pretty-print ds)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -0,0 +1,20 @@
|
|||
#lang racket/base
|
||||
;; Common syntax classes.
|
||||
|
||||
(provide (for-syntax assertions
|
||||
name))
|
||||
|
||||
(require racket/set)
|
||||
|
||||
(require (for-syntax racket/base))
|
||||
(require (for-syntax syntax/parse))
|
||||
(require (for-syntax syntax/srcloc))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-splicing-syntax-class assertions
|
||||
(pattern (~seq #:assertions [exprs ...]))
|
||||
(pattern (~seq) #:attr (exprs 1) #'()))
|
||||
|
||||
(define-splicing-syntax-class name
|
||||
(pattern (~seq #:name N))
|
||||
(pattern (~seq) #:attr N #'#f)))
|
||||
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue