diff --git a/examples/netstack/incremental-highlevel/main.rkt b/examples/netstack/incremental-highlevel/main.rkt index 6f91f86..be29268 100644 --- a/examples/netstack/incremental-highlevel/main.rkt +++ b/examples/netstack/incremental-highlevel/main.rkt @@ -66,8 +66,6 @@ (during/spawn (inbound (advertise (tcp-channel ($ them (tcp-address _ _)) us _))) #:name (list 'webserver-session them) (log-info "Got connection from ~v" them) - (field [done? #f]) - (stop-when (rising-edge (done?))) (assert (outbound (advertise (tcp-channel us them _)))) (on (message (inbound (tcp-channel them us _)))) ;; ignore input @@ -84,4 +82,4 @@ "
There have been ~a requests prior to this one.
\n") counter))) (send! (outbound (tcp-channel us them response))) - (done? #t)))))) + (stop-facet (current-facet-id))))))) diff --git a/examples/netstack/incremental-highlevel/tcp.rkt b/examples/netstack/incremental-highlevel/tcp.rkt index e064647..6f08723 100644 --- a/examples/netstack/incremental-highlevel/tcp.rkt +++ b/examples/netstack/incremental-highlevel/tcp.rkt @@ -304,6 +304,8 @@ (ip-address->hostname dst-ip) dst-port) + (define root-facet (current-facet-id)) + (define initial-outbound-seqn ;; Yuck (inexact->exact (truncate (* #x100000000 (random))))) @@ -317,7 +319,7 @@ ;; ^ when the index of the first outbound unacknowledged byte changed [most-recent-time (current-inexact-milliseconds)] ;; ^ updated by timer expiry; a field, to trigger quit checks - [quit-because-reset? #f]) + ) (let () (local-require (submod syndicate/actor priorities)) @@ -445,7 +447,7 @@ dst-port (ip-address->hostname src-ip) src-port) - (quit-because-reset? #t) + (stop-facet root-facet) (send! (tcp-packet #f dst-ip dst-port src-ip src-port seqn ackn @@ -463,25 +465,21 @@ (assert #:when (and (syn-acked?) (not (buffer-finished? (inbound)))) (advertise (tcp-channel src dst _))) - (stop-when - (rising-edge - (and (buffer-finished? (outbound)) - (buffer-finished? (inbound)) - (all-output-acknowledged?) - (not (heard-from-peer-within-msec? (* 2 1000 maximum-segment-lifetime-sec))))) + (stop-when-true + (and (buffer-finished? (outbound)) + (buffer-finished? (inbound)) + (all-output-acknowledged?) + (not (heard-from-peer-within-msec? (* 2 1000 maximum-segment-lifetime-sec)))) ;; Everything is cleanly shut down, and we just need to wait a while for unexpected ;; packets before we release the state vector. ) - (stop-when - (rising-edge (user-timeout-expired?)) + (stop-when-true (user-timeout-expired?) ;; We've been plaintively retransmitting for user-timeout-msec without hearing anything ;; back; this is a crude approximation of the real condition for TCP_USER_TIMEOUT, but ;; it will do for now? TODO (log-info "TCP_USER_TIMEOUT fired.")) - (stop-when (rising-edge (quit-because-reset?))) - (define/query-value local-peer-seen? #f (observe (tcp-channel src dst _)) #t #:on-remove (begin (log-info "Closing outbound stream.") @@ -500,7 +498,7 @@ (define is-syn? (set-member? flags 'syn)) (define is-fin? (set-member? flags 'fin)) (cond - [(set-member? flags 'rst) (quit-because-reset? #t)] + [(set-member? flags 'rst) (stop-facet root-facet)] [(and (not expected) ;; no syn yet (or (not is-syn?) ;; and this isn't it (and (not (listener-listening?)) ;; or it is, but no listener... diff --git a/examples/platformer/hll-main.rkt b/examples/platformer/hll-main.rkt index d00dea1..5f1bfe4 100644 --- a/examples/platformer/hll-main.rkt +++ b/examples/platformer/hll-main.rkt @@ -550,7 +550,7 @@ (field [hit-points 1]) (assert (health player-id (hit-points))) - (stop-when (rising-edge (<= (hit-points) 0))) + (stop-when-true (<= (hit-points) 0)) (on (message (damage player-id $amount)) (hit-points (- (hit-points) amount))) @@ -624,9 +624,9 @@ [(> (+ left width) range-hi) 'left] [else (facing)])))) - (stop-when (rising-edge (and (current-level-size) - (> (vector-ref (pos) 1) - (vector-ref (current-level-size) 1))))) + (stop-when-true (and (current-level-size) + (> (vector-ref (pos) 1) + (vector-ref (current-level-size) 1)))) (field [facing initial-facing]) (assert (outbound* game-level diff --git a/examples/webchat/server/duplicate.rkt b/examples/webchat/server/duplicate.rkt index 28b6a4c..36eaec3 100644 --- a/examples/webchat/server/duplicate.rkt +++ b/examples/webchat/server/duplicate.rkt @@ -7,11 +7,9 @@ (define (stop-when-duplicate spec) (define id (random-hex-string 16)) - (field [duplicate? #f]) - (stop-when (rising-edge (duplicate?))) (assert (instance id spec)) (on (asserted (instance $id2 spec)) (when (string id id2) (log-info "Duplicate instance of ~v detected; terminating" spec) - (duplicate? #t))) + (stop-current-facet))) id) diff --git a/racket/syndicate/actor.rkt b/racket/syndicate/actor.rkt index 3033f5a..cf40082 100644 --- a/racket/syndicate/actor.rkt +++ b/racket/syndicate/actor.rkt @@ -16,6 +16,7 @@ stop-facet stop-current-facet stop-when + stop-when-true on-start on-stop on-event @@ -423,6 +424,11 @@ (syntax/loc stx (stop-facet (current-facet-id) script ...)) #'prio.level)])) +(define-syntax-rule (stop-when-true condition script ...) + (begin/dataflow + (when condition + (stop-facet (current-facet-id) script ...)))) + (define-syntax (on-start stx) (syntax-parse stx [(_ script ...) diff --git a/racket/syndicate/examples/actor/box-and-client.rkt b/racket/syndicate/examples/actor/box-and-client.rkt index 81a1338..f4f773c 100644 --- a/racket/syndicate/examples/actor/box-and-client.rkt +++ b/racket/syndicate/examples/actor/box-and-client.rkt @@ -6,8 +6,8 @@ (spawn (field [current-value 0]) (assert (box-state (current-value))) - (stop-when (rising-edge (= (current-value) 10)) - (log-info "box: terminating")) + (stop-when-true (= (current-value) 10) + (log-info "box: terminating")) (on (message (set-box $new-value)) (log-info "box: taking on new-value ~v" new-value) (current-value new-value))) diff --git a/racket/syndicate/examples/actor/example-bug-rising-edge-true.rkt b/racket/syndicate/examples/actor/example-bug-rising-edge-true.rkt index 0333c3c..fcd8ca3 100644 --- a/racket/syndicate/examples/actor/example-bug-rising-edge-true.rkt +++ b/racket/syndicate/examples/actor/example-bug-rising-edge-true.rkt @@ -1,6 +1,9 @@ #lang syndicate/actor ;; Demonstrates a bug: rising-edge of a predicate that starts off true ;; yields a crash. +;; +;; Fixed by commit 1fdd62d: Now both processes print their message and +;; terminate normally, as expected. (spawn (field [f #t]) (stop-when (rising-edge (f)) diff --git a/racket/syndicate/examples/actor/mutex.rkt b/racket/syndicate/examples/actor/mutex.rkt index 7545e4b..93350d0 100644 --- a/racket/syndicate/examples/actor/mutex.rkt +++ b/racket/syndicate/examples/actor/mutex.rkt @@ -55,7 +55,7 @@ (spawn (field [status 'starting]) (assert (philosopher-status name (status))) - (stop-when (rising-edge (eq? (status) 'inspired))) + (stop-when-true (eq? (status) 'inspired)) (on-start (let loop () diff --git a/racket/syndicate/examples/actor/web-sanity-check.rkt b/racket/syndicate/examples/actor/web-sanity-check.rkt index c5cf6fd..6441f32 100644 --- a/racket/syndicate/examples/actor/web-sanity-check.rkt +++ b/racket/syndicate/examples/actor/web-sanity-check.rkt @@ -47,9 +47,7 @@ 'inbound (web-request-header 'get (web-resource vh `("slow" ())) _ _) _)) - (react (field [done? #f]) - (stop-when (rising-edge (done?))) - (assert (web-response-chunked id + (react (assert (web-response-chunked id (web-response-header #:message #"Slowly" #:mime-type #"text/plain"))) (on (asserted (observe (web-response-chunk id _))) @@ -67,7 +65,7 @@ (sleep 2) (send! (web-response-chunk id #"third\n")) (sleep 2) - (done? #t)))) + (stop-current-facet)))) (on (message (web-request $id 'inbound diff --git a/racket/syndicate/supervise.rkt b/racket/syndicate/supervise.rkt index 191cd2e..e67547c 100644 --- a/racket/syndicate/supervise.rkt +++ b/racket/syndicate/supervise.rkt @@ -54,8 +54,7 @@ (react (linkage-thunk) ;; may contain e.g. linkage instructions from during/spawn - (field [done? #f]) - (stop-when (rising-edge (done?))) + (define root-supervisor-facet (current-facet-id)) (field [supervisee-name 'unknown]) @@ -117,7 +116,7 @@ (perform-actions! acs) ;; N.B. TODO: what to do with the exception ;; carried in the quit struct? - (done? #t)] + (stop-facet root-supervisor-facet)] [(transition st acs) (perform-actions! acs) (proc (update-process-state (proc) st))]))