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

Treat #:message separately from #:asserted. 

While in principle messages are "instantaneous" assertions, it invites
confusion to treat them as such in context of `(object)` because
assertions by default spawn nested facets, so it's too easy to
accidentally wrap a message handler in an unwanted facet. Being
explicit about messages means you never get an unwanted facet wrapper.
This commit is contained in:
Tony Garnock-Jones 2021-06-15 12:41:46 +02:00
parent d23e264756
commit 0b1e9874d1
3 changed files with 36 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
syndicate-examples/speed-tests/box-and-client/without-dataspace.rkt
View File

@ -19,7 +19,7 @@
'setter 'setter
(embedded (embedded
(object #:name 'update-handler (object #:name 'update-handler
[#:asserted new-value [#:message new-value
(reporter new-value) (reporter new-value)
(when (= new-value LIMIT) (stop-facet root-facet)) (when (= new-value LIMIT) (stop-facet root-facet))
(value new-value)])))))) (value new-value)]))))))
@ -49,7 +49,7 @@
(define root-facet this-facet) (define root-facet this-facet)
(define disarm (facet-prevent-inert-check! this-facet)) (define disarm (facet-prevent-inert-check! this-facet))
(box (object #:name 'box-boot-handler (box (object #:name 'box-boot-handler
[#:asserted refs [#:message refs
(log-info "refs ~v" refs) (log-info "refs ~v" refs)
(match-define (hash-table ('getter (embedded g)) (match-define (hash-table ('getter (embedded g))
('setter (embedded s))) refs) ('setter (embedded s))) refs)

18
syndicate/drivers/tcp.rkt
View File

@ -75,9 +75,9 @@
(at local-peer (at local-peer
(assert (ActiveSocket-controller (assert (ActiveSocket-controller
(object #:name (list name 'socket) (object #:name (list name 'socket)
[#:asserted (Socket-credit amount mode) (issue-credit amount mode)] [#:message (Socket-credit amount mode) (issue-credit amount mode)]
[#:asserted (Socket-data data mode) (relay data mode)] [#:message (Socket-data data mode) (relay data mode)]
[#:asserted (Socket-eof) (close-output-port o)])))))))) [#:message (Socket-eof) (close-output-port o)]))))))))
(define (spawn-inbound ds custodian i o spec) (define (spawn-inbound ds custodian i o spec)
(define name (call-with-values (lambda () (tcp-addresses i #t)) list)) (define name (call-with-values (lambda () (tcp-addresses i #t)) list))
@ -104,14 +104,14 @@
[#:asserted (ActiveSocket-close message) [#:asserted (ActiveSocket-close message)
(log-syndicate/drivers/tcp-debug "closing ~v:\n~a" this-actor message) (log-syndicate/drivers/tcp-debug "closing ~v:\n~a" this-actor message)
(stop-current-facet)] (stop-current-facet)]
[#:asserted (ActiveSocket-Socket (Socket-credit amount mode)) [#:message (ActiveSocket-Socket (Socket-credit amount mode))
(if issue-credit (if issue-credit
(issue-credit amount mode) (issue-credit amount mode)
(log-syndicate/drivers/tcp-warning (log-syndicate/drivers/tcp-warning
"Socket-credit ~v/~v ignored because no controller present" amount mode))] "Socket-credit ~v/~v ignored because no controller present" amount mode))]
[#:asserted (ActiveSocket-Socket (Socket-data data mode)) [#:message (ActiveSocket-Socket (Socket-data data mode))
(relay data mode)] (relay data mode)]
[#:asserted (ActiveSocket-Socket (Socket-eof)) [#:message (ActiveSocket-Socket (Socket-eof))
(close-output-port o)])) (close-output-port o)]))
(at ds (at ds
(assert (ConnectionPeer handle (TcpRemote (caddr name) (cadddr name)))) (assert (ConnectionPeer handle (TcpRemote (caddr name) (cadddr name))))
@ -246,9 +246,9 @@
#:retracted #:retracted
(on-disconnected)] (on-disconnected)]
[#:asserted (ActiveSocket-close message) (on-rejected message)] [#:asserted (ActiveSocket-close message) (on-rejected message)]
[#:asserted (ActiveSocket-Socket (Socket-credit amount mode)) (on-credit amount mode)] [#:message (ActiveSocket-Socket (Socket-credit amount mode)) (on-credit amount mode)]
[#:asserted (ActiveSocket-Socket (Socket-data data mode)) (on-data data mode)] [#:message (ActiveSocket-Socket (Socket-data data mode)) (on-data data mode)]
[#:asserted (ActiveSocket-Socket (Socket-eof)) (on-eof)])) [#:message (ActiveSocket-Socket (Socket-eof)) (on-eof)]))
(at ds (assert (Connection s spec)))) (at ds (assert (Connection s spec))))
(define (send-credit conn amount mode) (define (send-credit conn amount mode)

38
syndicate/syntax.rkt
View File

@ -92,15 +92,15 @@
[(_ name-stx:<name> handler ...) [(_ name-stx:<name> handler ...)
#`(let ((state (make-hash))) #`(let ((state (make-hash)))
(define name name-stx.N) (define name name-stx.N)
(define (handler-function assertion) (define (handler-function assertion is-message?)
(-object-clauses name assertion [] [handler ...])) (-object-clauses name assertion is-message? [] [handler ...]))
(ref (entity #:name name (ref (entity #:name name
#:assert (lambda (m h) (-object-assert state handler-function m h)) #:assert (lambda (m h) (-object-assert state handler-function m h))
#:retract (lambda (h) (-object-retract state h)) #:retract (lambda (h) (-object-retract state h))
#:message (lambda (m) (-object-message handler-function m)))))])) #:message (lambda (m) (-object-message handler-function m)))))]))
(define (-object-assert state handler-function assertion handle) (define (-object-assert state handler-function assertion handle)
(define k (handler-function assertion)) (define k (handler-function assertion #f))
(when k (hash-set! state handle k))) (when k (hash-set! state handle k)))
(define (-object-retract state handle) (define (-object-retract state handle)
@ -110,44 +110,56 @@
(k))) (k)))
(define (-object-message handler-function message) (define (-object-message handler-function message)
(define k (handler-function message)) (define k (handler-function message #t))
(when k (when k
(k))) (k)))
(define-syntax (-object-clauses stx) (define-syntax (-object-clauses stx)
(syntax-parse stx (syntax-parse stx
[(_ name input [completed ...] []) [(_ name input is-message? [completed ...]
[])
#'(match input #'(match input
completed ... completed ...
[_ [_
(log-syndicate/object-debug "Unhandled assertion ~v in ~v" input name) (log-syndicate/object-debug "Unhandled ~a ~v in ~v"
(if is-message? "message" "assertion")
input name)
#f])] #f])]
[(_ name input [completed ...] [ [#:spawn pat body ...] more ... ]) [(_ name input is-message? [completed ...]
[ [#:message pat body+ ...] more ... ])
#'(-object-clauses name #'(-object-clauses name
input input
[completed ...] is-message?
[ [#:during pat (spawn/link body ...)] more ... ])] [ completed ... [(-object-pattern pat) #:when is-message?
body+ ... #f] ]
[more ...])]
[(_ name input [completed ...] [ [#:asserted pat body+ ... #:retracted body- ...] more ... ]) [(_ name input is-message? [completed ...]
[ [#:asserted pat body+ ... #:retracted body- ...] more ... ])
#`(-object-clauses name #`(-object-clauses name
input input
[ completed ... [(-object-pattern pat) is-message?
[ completed ... [(-object-pattern pat) #:when (not is-message?)
body+ ... body+ ...
#,(if (null? (syntax->list #'(body- ...))) #,(if (null? (syntax->list #'(body- ...)))
#`#f #`#f
#`(lambda () body- ...))] ] #`(lambda () body- ...))] ]
[more ...])] [more ...])]
[(_ name input [completed ...] [ [#:asserted pat body+ ...] more ... ]) [(_ name input is-message? [completed ...]
[ [#:asserted pat body+ ...] more ... ])
#'(-object-clauses name #'(-object-clauses name
input input
is-message?
[completed ...] [completed ...]
[ [#:asserted pat body+ ... #:retracted] more ... ])] [ [#:asserted pat body+ ... #:retracted] more ... ])]
[(_ name input [completed ...] [ [pat body ...] more ... ]) [(_ name input is-message? [completed ...]
[ [pat body ...] more ... ])
#'(-object-clauses name #'(-object-clauses name
input input
is-message?
[completed ...] [completed ...]
[ [#:asserted pat [ [#:asserted pat
(define f (react (facet-prevent-inert-check! this-facet) body ...)) (define f (react (facet-prevent-inert-check! this-facet) body ...))