diff --git a/indenting2.el b/indenting2.el index 3f06b30..cebfd39 100644 --- a/indenting2.el +++ b/indenting2.el @@ -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))) diff --git a/os2-example.rkt b/os2-example.rkt index 77f59cd..1ceafb7 100644 --- a/os2-example.rkt +++ b/os2-example.rkt @@ -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)) diff --git a/os2-tcp.rkt b/os2-tcp.rkt index ad193b1..28179e8 100644 --- a/os2-tcp.rkt +++ b/os2-tcp.rkt @@ -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))) diff --git a/os2-timer.rkt b/os2-timer.rkt index d0b69a1..5691e12 100644 --- a/os2-timer.rkt +++ b/os2-timer.rkt @@ -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 diff --git a/os2.rkt b/os2.rkt index b500cdf..bb5370a 100644 --- a/os2.rkt +++ b/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) +(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 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]))