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

Remove current-dataspace parameter

This commit is contained in:
Tony Garnock-Jones 2018-04-27 18:03:31 +01:00
parent 0cbb5b061c
commit a4abea9d87
2 changed files with 79 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

146
syndicate/dataspace.rkt
View File

@ -13,6 +13,7 @@
actor? actor?
actor-id actor-id
actor-name actor-name
actor-dataspace ;; TODO: should this be provided?
facet? facet?
facet-actor facet-actor
@ -24,7 +25,6 @@
field-handle-owner field-handle-owner
field-handle-value field-handle-value
current-dataspace
current-actor current-actor
current-facet current-facet
in-script? ;; TODO: shouldn't be provided - inline syntax.rkt?? in-script? ;; TODO: shouldn't be provided - inline syntax.rkt??
@ -93,6 +93,7 @@
) #:transparent) ) #:transparent)
(struct actor (id ;; ActorID (struct actor (id ;; ActorID
dataspace ;; Dataspace
name ;; Any name ;; Any
[root-facet #:mutable] ;; (Option Facet) [root-facet #:mutable] ;; (Option Facet)
[runnable? #:mutable] ;; Boolean [runnable? #:mutable] ;; Boolean
@ -152,12 +153,14 @@
#:property prop:procedure #:property prop:procedure
(case-lambda (case-lambda
[(f) [(f)
(when (not (eq? (field-handle-owner f) (current-actor))) (field-scope-error 'field-ref f)) (define ac (current-actor))
(dataflow-record-observation! (dataspace-dataflow (current-dataspace)) f) (when (not (eq? (field-handle-owner f) ac)) (field-scope-error 'field-ref f))
(dataflow-record-observation! (dataspace-dataflow (actor-dataspace ac)) f)
(field-handle-value f)] (field-handle-value f)]
[(f v) [(f v)
(define ac (current-actor))
(when (not (eq? (field-handle-owner f) (current-actor))) (field-scope-error 'field-set! f)) (when (not (eq? (field-handle-owner f) (current-actor))) (field-scope-error 'field-set! f))
(dataflow-record-damage! (dataspace-dataflow (current-dataspace)) f) (dataflow-record-damage! (dataspace-dataflow (actor-dataspace ac)) f)
(set-field-handle-value! f v)])) (set-field-handle-value! f v)]))
(define (field-scope-error who f) (define (field-scope-error who f)
@ -166,9 +169,6 @@
(field-handle-owner f) (field-handle-owner f)
(current-actor))) (current-actor)))
;; Parameterof Dataspace
(define current-dataspace (make-parameter #f))
;; Parameterof Actor ;; Parameterof Actor
(define current-actor (make-parameter #f)) (define current-actor (make-parameter #f))
@ -230,6 +230,7 @@
(define the-actor-id (generate-id! ds)) (define the-actor-id (generate-id! ds))
(define filtered-initial-assertions (set-remove initial-assertions (void))) (define filtered-initial-assertions (set-remove initial-assertions (void)))
(define the-actor (actor the-actor-id (define the-actor (actor the-actor-id
ds
name name
#f #f
#f #f
@ -242,8 +243,7 @@
['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 (add-facet! #f
#f
the-actor the-actor
#f #f
(lambda () (lambda ()
@ -251,30 +251,27 @@
(for [(a filtered-initial-assertions)] (for [(a filtered-initial-assertions)]
(adhoc-retract! the-actor a))))) (adhoc-retract! the-actor a)))))
(define-syntax-rule (with-current-facet [ds0 a0 f0 script?] body ...) (define-syntax-rule (with-current-facet [a0 f0 script?] body ...)
(let ((ds ds0) (let ((a a0)
(a a0)
(f f0)) (f f0))
(parameterize ((current-dataspace ds) (parameterize ((current-actor a)
(current-actor a)
(current-facet f) (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) (lambda (e)
(log-error "Actor ~a died with exception:\n~a" a (exn->string e)) (log-error "Actor ~a died with exception:\n~a" a (exn->string e))
(abandon-queued-work! a) (abandon-queued-work! a)
(terminate-actor! ds a))]) ;; TODO: tracing (terminate-actor! a))]) ;; TODO: tracing
(call-with-syndicate-prompt (call-with-syndicate-prompt
(lambda () (lambda ()
body ...)) body ...))
(void))))) (void)))))
(define (capture-facet-context proc) (define (capture-facet-context proc)
(let ((ds (current-dataspace)) (let ((a (current-actor))
(a (current-actor))
(f (current-facet))) (f (current-facet)))
(lambda args (lambda args
(with-current-facet [ds a f #t] (with-current-facet [a f #t]
(apply proc args))))) (apply proc args)))))
(define (pop-next-script! ac) (define (pop-next-script! ac)
@ -302,7 +299,7 @@
(match-define (list f eid) subject-id) (match-define (list f eid) subject-id)
(when (facet-live? f) ;; TODO: necessary test, or tautological? (when (facet-live? f) ;; TODO: necessary test, or tautological?
(define ac (facet-actor f)) (define ac (facet-actor f))
(with-current-facet [ds ac f #f] (with-current-facet [ac f #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)))
@ -369,12 +366,12 @@
;; being held elsewhere! ;; being held elsewhere!
(not (null? (dataspace-runnable ds)))) (not (null? (dataspace-runnable ds))))
(define (add-facet! ds where actor parent boot-proc) (define (add-facet! 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 f (facet (generate-id! ds) (define f (facet (generate-id! (actor-dataspace actor))
#t #t
actor actor
parent parent
@ -390,37 +387,36 @@
;; root facet should be allowed? ;; root facet should be allowed?
(error 'add-facet! "INTERNAL ERROR: Attempt to add second root facet")) (error 'add-facet! "INTERNAL ERROR: Attempt to add second root facet"))
(set-actor-root-facet! actor f))) (set-actor-root-facet! actor f)))
(with-current-facet [ds actor f #f] (with-current-facet [actor f #f]
(boot-proc)) (boot-proc))
(push-script! ds actor (lambda () (push-script! actor (lambda ()
(when (or (and parent (not (facet-live? parent))) (when (or (and parent (not (facet-live? parent))) (facet-inert? f))
(facet-inert? ds f)) (terminate-facet! f)))))
(terminate-facet! ds f)))))
(define (facet-inert? ds f) (define (facet-inert? f)
(and (hash-empty? (facet-endpoints f)) (and (hash-empty? (facet-endpoints f))
(set-empty? (facet-children f)))) (set-empty? (facet-children f))))
(define (schedule-script! #:priority [priority *normal-priority*] ds ac thunk) (define (schedule-script! #:priority [priority *normal-priority*] ac thunk)
(push-script! #:priority priority ds ac (capture-facet-context thunk))) (push-script! #:priority priority ac (capture-facet-context thunk)))
(define (push-script! #:priority [priority *normal-priority*] ds ac thunk-with-context) (define (push-script! #:priority [priority *normal-priority*] ac thunk-with-context)
(when (not (actor-runnable? ac)) (when (not (actor-runnable? ac))
(set-actor-runnable?! ac #t) (set-actor-runnable?! ac #t)
(set-dataspace-runnable! ds (cons ac (dataspace-runnable ds)))) (let ((ds (actor-dataspace ac)))
(set-dataspace-runnable! ds (cons ac (dataspace-runnable ds)))))
(define v (actor-pending-scripts ac)) (define v (actor-pending-scripts ac))
(vector-set! v priority (enqueue (vector-ref v priority) thunk-with-context))) (vector-set! v priority (enqueue (vector-ref v priority) thunk-with-context)))
(define (retract-facet-assertions-and-subscriptions! ds f) (define (retract-facet-assertions-and-subscriptions! f)
(define ac (facet-actor f)) (define ac (facet-actor f))
(push-script! ds (define ds (actor-dataspace ac))
ac (push-script! ac (lambda ()
(lambda () (for [((eid ep) (in-hash (facet-endpoints f)))]
(for [((eid ep) (in-hash (facet-endpoints f)))] (dataflow-forget-subject! (dataspace-dataflow ds) (list f eid))
(dataflow-forget-subject! (dataspace-dataflow ds) (list f eid)) (retract! ac (endpoint-assertion ep))
(retract! ac (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))))))
(define (abandon-queued-work! ac) (define (abandon-queued-work! ac)
(set-actor-pending-actions! ac (make-queue)) (set-actor-pending-actions! ac (make-queue))
@ -429,20 +425,19 @@
(vector-set! scripts i (make-queue))))) (vector-set! scripts i (make-queue)))))
;; Abruptly terminates an entire actor, without running stop-scripts etc. ;; Abruptly terminates an entire actor, without running stop-scripts etc.
(define (terminate-actor! ds the-actor) (define (terminate-actor! the-actor)
(push-script! ds the-actor (push-script! the-actor (lambda () (for [(a (in-bag (actor-adhoc-assertions the-actor)))]
(lambda () (for [(a (in-bag (actor-adhoc-assertions the-actor)))] (retract! the-actor a))))
(retract! the-actor a))))
(let ((f (actor-root-facet the-actor))) (let ((f (actor-root-facet the-actor)))
(when f (when f
(let abort-facet! ((f f)) (let abort-facet! ((f f))
(set-facet-live?! f #f) (set-facet-live?! f #f)
(for [(child (in-set (facet-children f)))] (abort-facet! child)) (for [(child (in-set (facet-children f)))] (abort-facet! child))
(retract-facet-assertions-and-subscriptions! ds f)))) (retract-facet-assertions-and-subscriptions! f))))
(push-script! ds the-actor (lambda () (enqueue-action! the-actor (quit))))) (push-script! the-actor (lambda () (enqueue-action! the-actor (quit)))))
;; 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 f) (define (terminate-facet! f)
(when (facet-live? f) (when (facet-live? f)
(define ac (facet-actor f)) (define ac (facet-actor f))
(define parent (facet-parent f)) (define parent (facet-parent f))
@ -452,40 +447,39 @@
(set-facet-live?! f #f) (set-facet-live?! f #f)
(for [(child (in-set (facet-children f)))] (terminate-facet! ds child)) (for [(child (in-set (facet-children f)))] (terminate-facet! child))
;; 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.
(schedule-script! ds ac (lambda () (schedule-script! ac (lambda ()
(with-current-facet [ds ac f #t] (with-current-facet [ac f #t]
(for [(script (in-list (reverse (facet-stop-scripts f))))] (for [(script (in-list (reverse (facet-stop-scripts f))))]
(script))))) (script)))))
(retract-facet-assertions-and-subscriptions! ds f) (retract-facet-assertions-and-subscriptions! f)
(push-script! #:priority *gc-priority* ds ac (push-script! #:priority *gc-priority* ac
(lambda () (lambda ()
(if parent (if parent
(when (facet-inert? ds parent) (terminate-facet! ds parent)) (when (facet-inert? parent) (terminate-facet! parent))
(terminate-actor! ds ac)))))) (terminate-actor! ac))))))
(define (stop-facet! ds f stop-script) (define (stop-facet! f stop-script)
(define ac (facet-actor f)) (define ac (facet-actor f))
(with-current-facet [ds ac (facet-parent f) #t] ;; run in parent context wrt terminating facet (with-current-facet [ac (facet-parent f) #t] ;; run in parent context wrt terminating facet
(schedule-script! ds ac (lambda () (schedule-script! ac (lambda ()
(terminate-facet! ds f) (terminate-facet! f)
(schedule-script! ds ac stop-script))))) (schedule-script! ac stop-script)))))
(define (add-stop-script! ds script-proc) (define (add-stop-script! f script-proc)
(define f (current-facet))
(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! f 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 f (current-facet)) (define ds (actor-dataspace (facet-actor f)))
(define eid (generate-id! ds)) (define eid (generate-id! ds))
(define assertion (define assertion
(parameterize ((current-dataflow-subject-id (list f eid))) (parameterize ((current-dataflow-subject-id (list f eid)))
@ -576,8 +570,7 @@
(apply k results))))) (apply k results)))))
(define resume-parent (define resume-parent
(lambda results (lambda results
(push-script! (current-dataspace) (push-script! (current-actor)
(current-actor)
(lambda () (apply raw-resume-parent results))))) (lambda () (apply raw-resume-parent results)))))
(proc resume-parent)))) (proc resume-parent))))
prompt-tag)) prompt-tag))
@ -592,7 +585,6 @@
(make-dataspace (make-dataspace
(lambda () (lambda ()
(schedule-script! (schedule-script!
(current-dataspace)
(current-actor) (current-actor)
(lambda () (lambda ()
(spawn! (spawn!
@ -600,24 +592,23 @@
'box 'box
(lambda () (lambda ()
(define current-value (field-handle 'current-value (define current-value (field-handle 'current-value
(generate-id! (current-dataspace)) (generate-id! (actor-dataspace (current-actor)))
(current-actor) (current-actor)
0)) 0))
(add-endpoint! (current-dataspace) (add-endpoint! (current-facet)
'stop-when-ten 'stop-when-ten
(lambda () (lambda ()
(when (= (current-value) 10) (when (= (current-value) 10)
(stop-facet! (current-dataspace) (stop-facet! (current-facet)
(current-facet)
(lambda () (lambda ()
(log-info "box: terminating")))) (log-info "box: terminating"))))
(void)) (void))
#f) #f)
(add-endpoint! (current-dataspace) (add-endpoint! (current-facet)
'assert-box-state 'assert-box-state
(lambda () (box-state (current-value))) (lambda () (box-state (current-value)))
#f) #f)
(add-endpoint! (current-dataspace) (add-endpoint! (current-facet)
'on-message-set-box 'on-message-set-box
(lambda () (observe (set-box (capture (discard))))) (lambda () (observe (set-box (capture (discard)))))
(skeleton-interest (list struct:set-box #f) (skeleton-interest (list struct:set-box #f)
@ -628,7 +619,6 @@
(lambda (op new-value) (lambda (op new-value)
(when (eq? '! op) (when (eq? '! op)
(schedule-script! (schedule-script!
(current-dataspace)
(current-actor) (current-actor)
(lambda () (lambda ()
(log-info "box: taking on new-value ~v" new-value) (log-info "box: taking on new-value ~v" new-value)
@ -638,7 +628,7 @@
(current-actor) (current-actor)
'client 'client
(lambda () (lambda ()
(add-endpoint! (current-dataspace) (add-endpoint! (current-facet)
'stop-when-retracted-observe-set-box 'stop-when-retracted-observe-set-box
(lambda () (observe (observe (set-box (discard))))) (lambda () (observe (observe (set-box (discard)))))
(skeleton-interest (list struct:observe (list struct:set-box #f)) (skeleton-interest (list struct:observe (list struct:set-box #f))
@ -649,11 +639,10 @@
(lambda (op) (lambda (op)
(when (eq? '- op) (when (eq? '- op)
(stop-facet! (stop-facet!
(current-dataspace)
(current-facet) (current-facet)
(lambda () (lambda ()
(log-info "client: box has gone")))))))) (log-info "client: box has gone"))))))))
(add-endpoint! (current-dataspace) (add-endpoint! (current-facet)
'on-asserted-box-state 'on-asserted-box-state
(lambda () (observe (box-state (capture (discard))))) (lambda () (observe (box-state (capture (discard)))))
(skeleton-interest (list struct:box-state #f) (skeleton-interest (list struct:box-state #f)
@ -664,7 +653,6 @@
(lambda (op v) (lambda (op v)
(when (eq? '+ op) (when (eq? '+ op)
(schedule-script! (schedule-script!
(current-dataspace)
(current-actor) (current-actor)
(lambda () (lambda ()
(log-info "client: learned that box's value is now ~v" v) (log-info "client: learned that box's value is now ~v" v)

33
syndicate/syntax.rkt
View File

@ -132,9 +132,7 @@
[(_ expr0 expr ...) (syntax/loc stx (begin expr0 expr ...))])) [(_ expr0 expr ...) (syntax/loc stx (begin expr0 expr ...))]))
(define (react* where boot-proc) (define (react* where boot-proc)
(define ds (current-dataspace)) (add-facet! where
(add-facet! ds
where
(current-actor) (current-actor)
(current-facet) (current-facet)
boot-proc)) boot-proc))
@ -164,10 +162,8 @@
O ...))])) O ...))]))
(define (make-field name init) (define (make-field name init)
(field-handle name (let ((ac (current-actor)))
(generate-id! (current-dataspace)) (field-handle name (generate-id! (actor-dataspace ac)) ac init)))
(current-actor)
init))
(define-syntax (define-field stx) (define-syntax (define-field stx)
(syntax-parse stx (syntax-parse stx
@ -185,7 +181,7 @@
(syntax-parse stx (syntax-parse stx
[(_ w:when-pred P) [(_ w:when-pred P)
(quasisyntax/loc stx (quasisyntax/loc stx
(add-endpoint! (current-dataspace) (add-endpoint! (current-facet)
#,(source-location->string stx) #,(source-location->string stx)
(lambda () (when w.Pred P)) (lambda () (when w.Pred P))
#f))])) #f))]))
@ -197,7 +193,7 @@
(let ((f f-expr)) (let ((f f-expr))
(when (not (equal? (facet-actor f) (current-actor))) (when (not (equal? (facet-actor f) (current-actor)))
(error 'stop-facet "Attempt to stop unrelated facet ~a from actor ~a" f (current-actor))) (error 'stop-facet "Attempt to stop unrelated facet ~a from actor ~a" f (current-actor)))
(stop-facet! (current-dataspace) f (lambda () (begin/void-default script ...)))))])) (stop-facet! f (lambda () (begin/void-default script ...)))))]))
(define-syntax-rule (stop-current-facet script ...) (define-syntax-rule (stop-current-facet script ...)
(stop-facet (current-facet) script ...)) (stop-facet (current-facet) script ...))
@ -211,15 +207,14 @@
(syntax-parse stx (syntax-parse stx
[(_ script ...) [(_ script ...)
(quasisyntax/loc stx (quasisyntax/loc stx
(schedule-script! (current-dataspace) (schedule-script! (current-actor)
(current-actor)
(lambda () (begin/void-default script ...))))])) (lambda () (begin/void-default script ...))))]))
(define-syntax (on-stop stx) (define-syntax (on-stop stx)
(syntax-parse stx (syntax-parse stx
[(_ script ...) [(_ script ...)
(quasisyntax/loc stx (quasisyntax/loc stx
(add-stop-script! (current-dataspace) (add-stop-script! (current-facet)
(lambda () (begin/void-default script ...))))])) (lambda () (begin/void-default script ...))))]))
(define-syntax (stop-when stx) (define-syntax (stop-when stx)
@ -245,13 +240,12 @@
[(_ prio:priority expr ...) [(_ prio:priority expr ...)
(quasisyntax/loc stx (quasisyntax/loc stx
(let () (let ()
(add-endpoint! (current-dataspace) (add-endpoint! (current-facet)
#,(source-location->string stx) #,(source-location->string stx)
(lambda () (lambda ()
(define subject-id (current-dataflow-subject-id)) (define subject-id (current-dataflow-subject-id))
(schedule-script! (schedule-script!
#:priority prio.level #:priority prio.level
(current-dataspace)
(current-actor) (current-actor)
(lambda () (lambda ()
(parameterize ((current-dataflow-subject-id subject-id)) (parameterize ((current-dataflow-subject-id subject-id))
@ -313,7 +307,7 @@
[(message P) [(message P)
(define desc (analyse-pattern #'P)) (define desc (analyse-pattern #'P))
(quasisyntax/loc outer-expr-stx (quasisyntax/loc outer-expr-stx
(add-endpoint! (current-dataspace) (add-endpoint! (current-facet)
#,(source-location->string outer-expr-stx) #,(source-location->string outer-expr-stx)
(lambda () (when #,when-pred-stx (observe #,(desc->assertion-stx desc)))) (lambda () (when #,when-pred-stx (observe #,(desc->assertion-stx desc))))
(skeleton-interest #,(desc->skeleton-stx desc) (skeleton-interest #,(desc->skeleton-stx desc)
@ -325,7 +319,6 @@
(when (eq? op '!) (when (eq? op '!)
(schedule-script! (schedule-script!
#:priority #,priority-stx #:priority #,priority-stx
(current-dataspace)
(current-actor) (current-actor)
#,(quasisyntax/loc script-stx #,(quasisyntax/loc script-stx
(lambda () (lambda ()
@ -343,7 +336,7 @@
priority-stx) priority-stx)
(define desc (analyse-pattern P-stx)) (define desc (analyse-pattern P-stx))
(quasisyntax/loc outer-expr-stx (quasisyntax/loc outer-expr-stx
(add-endpoint! (current-dataspace) (add-endpoint! (current-facet)
#,(source-location->string outer-expr-stx) #,(source-location->string outer-expr-stx)
(lambda () (when #,when-pred-stx (observe #,(desc->assertion-stx desc)))) (lambda () (when #,when-pred-stx (observe #,(desc->assertion-stx desc))))
(skeleton-interest #,(desc->skeleton-stx desc) (skeleton-interest #,(desc->skeleton-stx desc)
@ -355,7 +348,6 @@
(when (eq? op #,(if asserted? #''+ #''-)) (when (eq? op #,(if asserted? #''+ #''-))
(schedule-script! (schedule-script!
#:priority #,priority-stx #:priority #,priority-stx
(current-dataspace)
(current-actor) (current-actor)
#,(quasisyntax/loc script-stx #,(quasisyntax/loc script-stx
(lambda () (lambda ()
@ -596,7 +588,6 @@
(make-dataspace (make-dataspace
(lambda () (lambda ()
(schedule-script! (schedule-script!
(current-dataspace)
(current-actor) (current-actor)
#;(lambda () #;(lambda ()
@ -611,7 +602,7 @@
(log-info "finally for x=~a v=~a" (x) v)))) (log-info "finally for x=~a v=~a" (x) v))))
) )
(lambda () #;(lambda ()
;; Goal: no matter the circumstances (e.g. exception in a ;; Goal: no matter the circumstances (e.g. exception in a
;; stop script), we will never retract an assertion more or ;; stop script), we will never retract an assertion more or
;; fewer than the correct number of times. ;; fewer than the correct number of times.
@ -825,7 +816,7 @@
(send! (stage 2)))) (send! (stage 2))))
) )
#;(lambda () (lambda ()
(spawn (field [current-value 0]) (spawn (field [current-value 0])
(assert (box-state (current-value))) (assert (box-state (current-value)))
(stop-when-true (= (current-value) 10) (stop-when-true (= (current-value) 10)