syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Introduce action-groups

This commit is contained in:
Tony Garnock-Jones 2018-04-22 21:02:40 +01:00
parent 634b114afc
commit 4be935a160
1 changed files with 26 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
syndicate/dataspace.rkt
View File

@ -85,7 +85,7 @@
assertions ;; (Bagof Assertion) assertions ;; (Bagof Assertion)
dataflow ;; DataflowGraph dataflow ;; DataflowGraph
[runnable #:mutable] ;; (Listof Actor) [runnable #:mutable] ;; (Listof Actor)
[pending-actions #:mutable] ;; (Queueof Action) [pending-actions #:mutable] ;; (Queueof ActionGroup)
) #:transparent) ) #:transparent)
(struct actor (id ;; ActorID (struct actor (id ;; ActorID
@ -101,6 +101,11 @@
[(define (write-proc a p mode) [(define (write-proc a p mode)
(fprintf p "#<actor ~a ~v>" (actor-id a) (actor-name a)))]) (fprintf p "#<actor ~a ~v>" (actor-id a) (actor-name a)))])
(struct action-group (actor ;; (U Actor 'meta)
actions ;; (Listof Action)
)
#:transparent)
(struct facet (id ;; FID (struct facet (id ;; FID
[live? #:mutable] ;; Boolean [live? #:mutable] ;; Boolean
actor ;; Actor actor ;; Actor
@ -210,7 +215,7 @@
(make-bag) (make-bag)
(make-dataflow-graph) (make-dataflow-graph)
'() '()
(enqueue (make-queue) (spawn name boot-proc (set))))) (enqueue (make-queue) (action-group 'meta (list (spawn name boot-proc (set)))))))
(define (generate-id! ds) (define (generate-id! ds)
(let ((id (dataspace-next-id ds))) (let ((id (dataspace-next-id ds)))
@ -306,7 +311,8 @@
(define (commit-actions! ds ac) (define (commit-actions! ds ac)
(define pending (actor-pending-actions ac)) (define pending (actor-pending-actions ac))
;; (log-info "commit-actions!: ~a actions ~a" ac (queue->list pending)) ;; (log-info "commit-actions!: ~a actions ~a" ac (queue->list pending))
(set-dataspace-pending-actions! ds (queue-append (dataspace-pending-actions ds) pending)) (set-dataspace-pending-actions! ds (enqueue (dataspace-pending-actions ds)
(action-group ac (queue->list pending))))
(set-actor-pending-actions! ac (make-queue))) (set-actor-pending-actions! ac (make-queue)))
(define (run-all-pending-scripts! ds) (define (run-all-pending-scripts! ds)
@ -318,22 +324,24 @@
(commit-actions! ds ac))) (commit-actions! ds ac)))
(define (perform-pending-actions! ds) (define (perform-pending-actions! ds)
(define actions (queue->list (dataspace-pending-actions ds))) (define groups (queue->list (dataspace-pending-actions ds)))
(set-dataspace-pending-actions! ds (make-queue)) (set-dataspace-pending-actions! ds (make-queue))
(for [(action actions)] (for [(group (in-list groups))]
;; (log-info "performing ~a" action) (match-define (action-group ac actions) group)
(match action (for [(action (in-list actions))]
[(patch delta) ;; (log-info "~a performing ~a" ac action)
(for [((a count) (in-bag/count delta))] (match action
(match (bag-change! (dataspace-assertions ds) a count) [(patch delta)
['present->absent (remove-assertion! (dataspace-routing-table ds) a)] (for [((a count) (in-bag/count delta))]
['absent->present (add-assertion! (dataspace-routing-table ds) a)] (match (bag-change! (dataspace-assertions ds) a count)
;; 'absent->absent absurd ['present->absent (remove-assertion! (dataspace-routing-table ds) a)]
['present->present (void)]))] ;; i.e. no visible change ['absent->present (add-assertion! (dataspace-routing-table ds) a)]
[(message body) ;; 'absent->absent absurd
(send-assertion! (dataspace-routing-table ds) body)] ['present->present (void)]))] ;; i.e. no visible change
[(spawn name boot-proc initial-assertions) [(message body)
(add-actor! ds name boot-proc initial-assertions)]))) (send-assertion! (dataspace-routing-table ds) body)]
[(spawn name boot-proc initial-assertions)
(add-actor! ds name boot-proc initial-assertions)]))))
(define (run-scripts! ds) (define (run-scripts! ds)
(run-all-pending-scripts! ds) (run-all-pending-scripts! ds)