Replace {extend,prefix}-transition{,*} with sequence-actions.
This commit is contained in:
parent
e67bffdcc3
commit
09a957a54e
|
@ -1,7 +1,6 @@
|
|||
;; Emacs indent settings
|
||||
(progn
|
||||
(mapcar #'(lambda (x) (put x 'scheme-indent-function 1))
|
||||
'(transition extend-transition prefix-transition
|
||||
extend-transition* prefix-transition*))
|
||||
'(transition sequence-actions))
|
||||
(mapcar #'(lambda (x) (put x 'scheme-indent-function 2))
|
||||
'(role role/fresh yield)))
|
||||
|
|
|
@ -12,7 +12,9 @@
|
|||
(role 'sleeper (topic-subscriber (timer-expired id (wild)))
|
||||
#:state state
|
||||
[(timer-expired (== id) now)
|
||||
(extend-transition (k state) (delete-role id))])))
|
||||
(sequence-actions state
|
||||
k
|
||||
(delete-role id))])))
|
||||
|
||||
(define (example-process delay)
|
||||
(write `(sleeping for ,delay milliseconds))
|
||||
|
|
|
@ -193,7 +193,7 @@
|
|||
[(cons _ (? eof-object?))
|
||||
(close-transition state #t)]
|
||||
[(cons _ (? bytes? bs))
|
||||
(extend-transition (adjust-credit state -1)
|
||||
(sequence-actions (adjust-credit state -1)
|
||||
(send-message (tcp-channel remote-addr local-addr bs)))])]
|
||||
[(bytes)
|
||||
(role 'inbound-relay
|
||||
|
@ -203,7 +203,7 @@
|
|||
(close-transition state #t)]
|
||||
[(cons _ (? bytes? bs))
|
||||
(define len (bytes-length bs))
|
||||
(extend-transition (adjust-credit state (- len))
|
||||
(sequence-actions (adjust-credit state (- len))
|
||||
(send-message (tcp-channel remote-addr local-addr bs)))])])))))
|
||||
(transition (tcp-connection-state 'bytes 0)
|
||||
(role 'explicit-eof-listener (topic-subscriber (cons (eof-evt cin) (wild)))
|
||||
|
|
|
@ -110,7 +110,9 @@
|
|||
[(cons (? evt?) now)
|
||||
(define to-send (fire-timers! (driver-state-heap state) now))
|
||||
;; Note: compute to-send before recursing, because of side-effects on heap
|
||||
(extend-transition (update-time-listener! state) to-send)]))))
|
||||
(sequence-actions state
|
||||
update-time-listener!
|
||||
to-send)]))))
|
||||
|
||||
;; Symbol -> BootK
|
||||
;; Process for mapping this-level timer requests to meta-level timer
|
||||
|
|
112
os2.rkt
112
os2.rkt
|
@ -23,10 +23,15 @@
|
|||
|
||||
(except-out (struct-out transition) transition)
|
||||
(rename-out [make-transition transition])
|
||||
extend-transition
|
||||
extend-transition*
|
||||
prefix-transition
|
||||
prefix-transition*
|
||||
transition/c
|
||||
state/c
|
||||
action/c
|
||||
action-tree/c
|
||||
|
||||
(contract-out (sequence-actions (->* (transition/c)
|
||||
#:rest (listof (or/c action-tree/c
|
||||
(state/c . -> . transition/c)))
|
||||
transition/c)))
|
||||
|
||||
role
|
||||
role/fresh
|
||||
|
@ -154,6 +159,11 @@
|
|||
;; QuasiQueue.
|
||||
(struct transition (state actions) #:transparent)
|
||||
|
||||
;; Transition -> (transition ConsTreeOf<Action>)
|
||||
(define (maybe-transition->transition t)
|
||||
(cond [(transition? t) t]
|
||||
[else (transition t '())]))
|
||||
|
||||
;; Preactions.
|
||||
;; Ks are various TrapKs or #f, signifying lack of interest.
|
||||
;;
|
||||
|
@ -172,11 +182,27 @@
|
|||
;; (kill Maybe<PID> Any)
|
||||
(struct kill (pid reason) #:prefab)
|
||||
|
||||
(define (preaction? a)
|
||||
(or (add-role? a)
|
||||
(delete-role? a)
|
||||
(send-message? a)
|
||||
(spawn? a)
|
||||
(kill? a)))
|
||||
|
||||
;; An Action is either a Preaction or a (yield InterruptK) or an
|
||||
;; (at-meta-level Preaction).
|
||||
;; (at-meta-level Preaction) or an ignored placeholder (namely #f or
|
||||
;; (void)).
|
||||
(struct yield (k) #:prefab)
|
||||
(struct at-meta-level (preaction) #:prefab)
|
||||
|
||||
(define (action? a)
|
||||
(or (preaction? a)
|
||||
(yield? a)
|
||||
(eq? a #f)
|
||||
(void? a)
|
||||
(and (at-meta-level? a)
|
||||
(preaction? (at-meta-level-preaction a)))))
|
||||
|
||||
;; A Monitor instance describes the presence of a whole process, as a
|
||||
;; convention.
|
||||
;;
|
||||
|
@ -233,6 +259,15 @@
|
|||
;; Smarter constructors for transitions and preactions.
|
||||
|
||||
(define (make-transition state . actions) (transition state actions))
|
||||
|
||||
(define transition/c (or/c transition? any/c))
|
||||
(define state/c (not/c transition?))
|
||||
(define action/c action?)
|
||||
(define action-tree/c (flat-rec-contract action-tree/c
|
||||
(or action/c
|
||||
null?
|
||||
(cons/c action-tree/c action-tree/c))))
|
||||
|
||||
(define make-add-role add-role) ;; no special treatment required at present
|
||||
(define (make-delete-role pre-eid [reason #f]) (delete-role pre-eid reason))
|
||||
(define (make-send-message body [role 'publisher]) (send-message body role))
|
||||
|
@ -250,7 +285,7 @@
|
|||
(let ((unmonitored-main (if (procedure? raw-main) raw-main (lambda (self-pid) raw-main))))
|
||||
(lambda (self-pid)
|
||||
(define m (monitor self-pid debug-name))
|
||||
(prefix-transition (unmonitored-main self-pid)
|
||||
(sequence-actions (unmonitored-main self-pid)
|
||||
(role (list 'canary m) (topic-publisher m) #:state state))))
|
||||
raw-main))
|
||||
(define final-contract
|
||||
|
@ -264,30 +299,6 @@
|
|||
(boot-specification maybe-monitored-main final-contract)))
|
||||
(spawn spec k debug-name))
|
||||
|
||||
(define (extend-transition t . more-actions)
|
||||
(match t
|
||||
[(transition state actions) (transition state (list actions more-actions))]
|
||||
[state (transition state more-actions)]))
|
||||
|
||||
(define (extend-transition* t fn)
|
||||
(match t
|
||||
[(transition state actions)
|
||||
(prefix-transition (fn state) actions)]
|
||||
[state
|
||||
(fn state)]))
|
||||
|
||||
(define (prefix-transition t . more-actions)
|
||||
(match t
|
||||
[(transition state actions) (transition state (list more-actions actions))]
|
||||
[state (transition state more-actions)]))
|
||||
|
||||
(define (prefix-transition* t fn)
|
||||
(match t
|
||||
[(transition state actions)
|
||||
(extend-transition (fn state) actions)]
|
||||
[state
|
||||
(fn state)]))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;; Topics and roles
|
||||
|
||||
|
@ -333,6 +344,28 @@
|
|||
(or (topic-virtual? local-topic)
|
||||
(not (topic-virtual? remote-topic))))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;; Composing state transitions and action emissions.
|
||||
|
||||
(define (sequence-actions t . more-actions-and-transformers)
|
||||
(match-define (transition initial-state initial-actions) (maybe-transition->transition t))
|
||||
(let loop ((state initial-state)
|
||||
(actions initial-actions)
|
||||
(items more-actions-and-transformers))
|
||||
(match items
|
||||
['()
|
||||
(transition state actions)]
|
||||
[(cons (? procedure? transformer) remaining-items)
|
||||
(match-define (transition new-state more-actions)
|
||||
(maybe-transition->transition (transformer state)))
|
||||
(loop new-state
|
||||
(cons actions more-actions)
|
||||
remaining-items)]
|
||||
[(cons additional-action-or-actions remaining-items)
|
||||
(loop state
|
||||
(cons actions additional-action-or-actions)
|
||||
remaining-items)])))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;; Core virtualizable virtual machine.
|
||||
|
||||
|
@ -532,10 +565,6 @@
|
|||
(match-define (endpoint (eid pid _) _ (handlers _ _ message-handler)) e)
|
||||
(run-trapk state pid eid message-handler message-topic body)))
|
||||
|
||||
(define (maybe-transition->transition t)
|
||||
(cond [(transition? t) t]
|
||||
[else (transition t '())]))
|
||||
|
||||
(define (do-spawn spawning-pid spec k debug-name state)
|
||||
(define new-pid (vm-next-process-id state))
|
||||
(define new-name (or debug-name new-pid))
|
||||
|
@ -620,24 +649,11 @@
|
|||
[state new-state]
|
||||
[responsible-party new-party]))))
|
||||
|
||||
(define (preaction? a)
|
||||
(or (add-role? a)
|
||||
(delete-role? a)
|
||||
(send-message? a)
|
||||
(spawn? a)
|
||||
(kill? a)))
|
||||
|
||||
(define (action? a)
|
||||
(or (preaction? a)
|
||||
(yield? a)
|
||||
(and (at-meta-level? a)
|
||||
(preaction? (at-meta-level-preaction a)))))
|
||||
|
||||
(define (valid-action? pid a)
|
||||
(cond
|
||||
[(action? a)]
|
||||
[(eq? a #f) #f] ;; skip falses in action ConsTrees
|
||||
[(void? a) #f] ;; skip voids in action ConsTrees
|
||||
[(action? a)]
|
||||
[else (log-warning (format "Illegal action ~v from pid ~v" a pid))
|
||||
#f]))
|
||||
|
||||
|
|
Loading…
Reference in New Issue