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

Avoid some stop-when/rising-edge/flag combinations, and some rising-edge uses generally

This commit is contained in:
Tony Garnock-Jones 2017-07-05 07:13:36 -04:00
parent 37cee0c937
commit 3073d8b614
10 changed files with 33 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
examples/netstack/incremental-highlevel/main.rkt
View File

@ -66,8 +66,6 @@
(during/spawn (inbound (advertise (tcp-channel ($ them (tcp-address _ _)) us _))) (during/spawn (inbound (advertise (tcp-channel ($ them (tcp-address _ _)) us _)))
#:name (list 'webserver-session them) #:name (list 'webserver-session them)
(log-info "Got connection from ~v" them) (log-info "Got connection from ~v" them)
(field [done? #f])
(stop-when (rising-edge (done?)))
(assert (outbound (advertise (tcp-channel us them _)))) (assert (outbound (advertise (tcp-channel us them _))))
(on (message (inbound (tcp-channel them us _)))) ;; ignore input (on (message (inbound (tcp-channel them us _)))) ;; ignore input
@ -84,4 +82,4 @@
"<p>There have been ~a requests prior to this one.</p>\n") "<p>There have been ~a requests prior to this one.</p>\n")
counter))) counter)))
(send! (outbound (tcp-channel us them response))) (send! (outbound (tcp-channel us them response)))
(done? #t)))))) (stop-facet (current-facet-id)))))))

24
examples/netstack/incremental-highlevel/tcp.rkt
View File

@ -304,6 +304,8 @@
(ip-address->hostname dst-ip) (ip-address->hostname dst-ip)
dst-port) dst-port)
(define root-facet (current-facet-id))
(define initial-outbound-seqn (define initial-outbound-seqn
;; Yuck ;; Yuck
(inexact->exact (truncate (* #x100000000 (random))))) (inexact->exact (truncate (* #x100000000 (random)))))
@ -317,7 +319,7 @@
;; ^ when the index of the first outbound unacknowledged byte changed ;; ^ when the index of the first outbound unacknowledged byte changed
[most-recent-time (current-inexact-milliseconds)] [most-recent-time (current-inexact-milliseconds)]
;; ^ updated by timer expiry; a field, to trigger quit checks ;; ^ updated by timer expiry; a field, to trigger quit checks
[quit-because-reset? #f]) )
(let () (let ()
(local-require (submod syndicate/actor priorities)) (local-require (submod syndicate/actor priorities))
@ -445,7 +447,7 @@
dst-port dst-port
(ip-address->hostname src-ip) (ip-address->hostname src-ip)
src-port) src-port)
(quit-because-reset? #t) (stop-facet root-facet)
(send! (tcp-packet #f dst-ip dst-port src-ip src-port (send! (tcp-packet #f dst-ip dst-port src-ip src-port
seqn seqn
ackn ackn
@ -463,25 +465,21 @@
(assert #:when (and (syn-acked?) (not (buffer-finished? (inbound)))) (assert #:when (and (syn-acked?) (not (buffer-finished? (inbound))))
(advertise (tcp-channel src dst _))) (advertise (tcp-channel src dst _)))
(stop-when (stop-when-true
(rising-edge (and (buffer-finished? (outbound))
(and (buffer-finished? (outbound)) (buffer-finished? (inbound))
(buffer-finished? (inbound)) (all-output-acknowledged?)
(all-output-acknowledged?) (not (heard-from-peer-within-msec? (* 2 1000 maximum-segment-lifetime-sec))))
(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 ;; Everything is cleanly shut down, and we just need to wait a while for unexpected
;; packets before we release the state vector. ;; packets before we release the state vector.
) )
(stop-when (stop-when-true (user-timeout-expired?)
(rising-edge (user-timeout-expired?))
;; We've been plaintively retransmitting for user-timeout-msec without hearing anything ;; 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 ;; back; this is a crude approximation of the real condition for TCP_USER_TIMEOUT, but
;; it will do for now? TODO ;; it will do for now? TODO
(log-info "TCP_USER_TIMEOUT fired.")) (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 (define/query-value local-peer-seen? #f (observe (tcp-channel src dst _)) #t
#:on-remove (begin #:on-remove (begin
(log-info "Closing outbound stream.") (log-info "Closing outbound stream.")
@ -500,7 +498,7 @@
(define is-syn? (set-member? flags 'syn)) (define is-syn? (set-member? flags 'syn))
(define is-fin? (set-member? flags 'fin)) (define is-fin? (set-member? flags 'fin))
(cond (cond
[(set-member? flags 'rst) (quit-because-reset? #t)] [(set-member? flags 'rst) (stop-facet root-facet)]
[(and (not expected) ;; no syn yet [(and (not expected) ;; no syn yet
(or (not is-syn?) ;; and this isn't it (or (not is-syn?) ;; and this isn't it
(and (not (listener-listening?)) ;; or it is, but no listener... (and (not (listener-listening?)) ;; or it is, but no listener...

8
examples/platformer/hll-main.rkt
View File

@ -550,7 +550,7 @@
(field [hit-points 1]) (field [hit-points 1])
(assert (health player-id (hit-points))) (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)) (on (message (damage player-id $amount))
(hit-points (- (hit-points) amount))) (hit-points (- (hit-points) amount)))
@ -624,9 +624,9 @@
[(> (+ left width) range-hi) 'left] [(> (+ left width) range-hi) 'left]
[else (facing)])))) [else (facing)]))))
(stop-when (rising-edge (and (current-level-size) (stop-when-true (and (current-level-size)
(> (vector-ref (pos) 1) (> (vector-ref (pos) 1)
(vector-ref (current-level-size) 1))))) (vector-ref (current-level-size) 1))))
(field [facing initial-facing]) (field [facing initial-facing])
(assert (outbound* game-level (assert (outbound* game-level

4
examples/webchat/server/duplicate.rkt
View File

@ -7,11 +7,9 @@
(define (stop-when-duplicate spec) (define (stop-when-duplicate spec)
(define id (random-hex-string 16)) (define id (random-hex-string 16))
(field [duplicate? #f])
(stop-when (rising-edge (duplicate?)))
(assert (instance id spec)) (assert (instance id spec))
(on (asserted (instance $id2 spec)) (on (asserted (instance $id2 spec))
(when (string<? id id2) (when (string<? id id2)
(log-info "Duplicate instance of ~v detected; terminating" spec) (log-info "Duplicate instance of ~v detected; terminating" spec)
(duplicate? #t))) (stop-current-facet)))
id) id)

6
racket/syndicate/actor.rkt
View File

@ -16,6 +16,7 @@
stop-facet stop-facet
stop-current-facet stop-current-facet
stop-when stop-when
stop-when-true
on-start on-start
on-stop on-stop
on-event on-event
@ -423,6 +424,11 @@
(syntax/loc stx (stop-facet (current-facet-id) script ...)) (syntax/loc stx (stop-facet (current-facet-id) script ...))
#'prio.level)])) #'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) (define-syntax (on-start stx)
(syntax-parse stx (syntax-parse stx
[(_ script ...) [(_ script ...)

4
racket/syndicate/examples/actor/box-and-client.rkt
View File

@ -6,8 +6,8 @@
(spawn (field [current-value 0]) (spawn (field [current-value 0])
(assert (box-state (current-value))) (assert (box-state (current-value)))
(stop-when (rising-edge (= (current-value) 10)) (stop-when-true (= (current-value) 10)
(log-info "box: terminating")) (log-info "box: terminating"))
(on (message (set-box $new-value)) (on (message (set-box $new-value))
(log-info "box: taking on new-value ~v" new-value) (log-info "box: taking on new-value ~v" new-value)
(current-value new-value))) (current-value new-value)))

3
racket/syndicate/examples/actor/example-bug-rising-edge-true.rkt
View File

@ -1,6 +1,9 @@
#lang syndicate/actor #lang syndicate/actor
;; Demonstrates a bug: rising-edge of a predicate that starts off true ;; Demonstrates a bug: rising-edge of a predicate that starts off true
;; yields a crash. ;; yields a crash.
;;
;; Fixed by commit 1fdd62d: Now both processes print their message and
;; terminate normally, as expected.
(spawn (field [f #t]) (spawn (field [f #t])
(stop-when (rising-edge (f)) (stop-when (rising-edge (f))

2
racket/syndicate/examples/actor/mutex.rkt
View File

@ -55,7 +55,7 @@
(spawn (field [status 'starting]) (spawn (field [status 'starting])
(assert (philosopher-status name (status))) (assert (philosopher-status name (status)))
(stop-when (rising-edge (eq? (status) 'inspired))) (stop-when-true (eq? (status) 'inspired))
(on-start (on-start
(let loop () (let loop ()

6
racket/syndicate/examples/actor/web-sanity-check.rkt
View File

@ -47,9 +47,7 @@
'inbound 'inbound
(web-request-header 'get (web-resource vh `("slow" ())) _ _) (web-request-header 'get (web-resource vh `("slow" ())) _ _)
_)) _))
(react (field [done? #f]) (react (assert (web-response-chunked id
(stop-when (rising-edge (done?)))
(assert (web-response-chunked id
(web-response-header #:message #"Slowly" (web-response-header #:message #"Slowly"
#:mime-type #"text/plain"))) #:mime-type #"text/plain")))
(on (asserted (observe (web-response-chunk id _))) (on (asserted (observe (web-response-chunk id _)))
@ -67,7 +65,7 @@
(sleep 2) (sleep 2)
(send! (web-response-chunk id #"third\n")) (send! (web-response-chunk id #"third\n"))
(sleep 2) (sleep 2)
(done? #t)))) (stop-current-facet))))
(on (message (web-request $id (on (message (web-request $id
'inbound 'inbound

5
racket/syndicate/supervise.rkt
View File

@ -54,8 +54,7 @@
(react (react
(linkage-thunk) ;; may contain e.g. linkage instructions from during/spawn (linkage-thunk) ;; may contain e.g. linkage instructions from during/spawn
(field [done? #f]) (define root-supervisor-facet (current-facet-id))
(stop-when (rising-edge (done?)))
(field [supervisee-name 'unknown]) (field [supervisee-name 'unknown])
@ -117,7 +116,7 @@
(perform-actions! acs) (perform-actions! acs)
;; N.B. TODO: what to do with the exception ;; N.B. TODO: what to do with the exception
;; carried in the quit struct? ;; carried in the quit struct?
(done? #t)] (stop-facet root-supervisor-facet)]
[(transition st acs) [(transition st acs)
(perform-actions! acs) (perform-actions! acs)
(proc (update-process-state (proc) st))])) (proc (update-process-state (proc) st))]))