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 _)))
#: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 @@
"<p>There have been ~a requests prior to this one.</p>\n")
counter)))
(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)
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...

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

@ -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

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

@ -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)

6
racket/syndicate/actor.rkt
View File

@ -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 ...)

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

@ -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)))

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

@ -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))

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

@ -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 ()

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

@ -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

5
racket/syndicate/supervise.rkt
View File

@ -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))]))