diff --git a/racket/syndicate/dataspace.rkt b/racket/syndicate/dataspace.rkt index a349c3c..987265c 100644 --- a/racket/syndicate/dataspace.rkt +++ b/racket/syndicate/dataspace.rkt @@ -109,6 +109,7 @@ (struct-copy dataspace w [runnable-pids (set-add (dataspace-runnable-pids w) pid)])) (define (enqueue-actions w label actions) + (trace-actions-produced label actions) (struct-copy dataspace w [pending-action-queue (queue-append-list (dataspace-pending-action-queue w) @@ -153,7 +154,7 @@ ((entry (in-list (queue->list (dataspace-pending-action-queue w))))) #:break (quit? wt) ;; TODO: should a quit action be delayed until the end of the turn? (match-define [cons label a] entry) - (when (or (event? a) (eq? a 'quit)) (trace-action-produced label a)) + (when (or (event? a) (eq? a 'quit)) (trace-action-interpreted label a)) (define wt1 (transition-bind (perform-action label a) wt)) wt1)) @@ -202,17 +203,21 @@ (transition (send-event/guard label (target-event remaining-path e) pid w) '())])) (define (create-process parent-label w behavior initial-transition initial-assertions name) + (define initial-assertions? (not (trie-empty? initial-assertions))) + (define initial-patch (patch initial-assertions trie-empty)) (define-values (postprocess initial-state initial-actions) (match (clean-transition initial-transition) [#f (values (lambda (w pid) (trace-actor-spawn parent-label pid (process name behavior (void))) + (when initial-assertions? (trace-actions-produced pid (list initial-patch))) w) #f '())] [(and q ( exn initial-actions0)) (values (lambda (w pid) (trace-actor-spawn parent-label pid (process name behavior (void))) + (when initial-assertions? (trace-actions-produced pid (list initial-patch))) (trace-actor-exit pid exn) (disable-process pid exn w)) #f @@ -220,10 +225,10 @@ [(and t (transition initial-state initial-actions0)) (values (lambda (w pid) (trace-actor-spawn parent-label pid (process name behavior initial-state)) + (when initial-assertions? (trace-actions-produced pid (list initial-patch))) (mark-pid-runnable w pid)) initial-state initial-actions0)])) - (define initial-patch (patch initial-assertions trie-empty)) (define-values (new-mux new-pid delta delta-aggregate) (mux-add-stream (dataspace-mux w) initial-patch)) (let* ((w (struct-copy dataspace w @@ -233,7 +238,7 @@ behavior initial-state))])) (w (enqueue-actions (postprocess w new-pid) new-pid initial-actions))) - (trace-action-produced new-pid initial-patch) + (when initial-assertions? (trace-action-interpreted new-pid initial-patch)) (deliver-patches w new-mux new-pid delta delta-aggregate))) (define (deliver-patches w new-mux acting-label delta delta-aggregate) diff --git a/racket/syndicate/trace.rkt b/racket/syndicate/trace.rkt index 091875c..ad829ed 100644 --- a/racket/syndicate/trace.rkt +++ b/racket/syndicate/trace.rkt @@ -5,7 +5,8 @@ trace-turn-end trace-actor-spawn trace-actor-exit - trace-action-produced + trace-action-interpreted + trace-actions-produced trace-event-consumed trace-causal-influence @@ -20,7 +21,8 @@ ;; -- 'turn-end ;; -- 'spawn ;; -- 'exit -;; -- 'action +;; -- 'action-interpreted +;; -- 'actions-produced ;; -- 'event ;; -- 'influence ;; @@ -29,7 +31,8 @@ ;; -- 'turn-begin and 'turn-end --> Process ;; -- 'spawn --> (list PID Process), the parent's PID and the process' initial state ;; -- 'exit --> Option Exception -;; -- 'action --> (U Event 'quit) (notably, spawns are handled otherwise) +;; -- 'action-interpreted --> (U Event 'quit) (notably, spawns are handled otherwise) +;; -- 'actions-produced --> (Listof (U Action 'quit)) (spawns included!) ;; -- 'event --> Event ;; -- 'influence --> Event ;; @@ -39,7 +42,8 @@ ;; -- 'turn-end --> source is dataspace; sink the process whose turn it was ;; -- 'spawn --> source is dataspace; sink the new process ;; -- 'exit --> source is dataspace; sink the exiting process -;; -- 'action --> source is acting process; sink is dataspace (NB: Flipped!) +;; -- 'action-interpreted --> source is acting process; sink is dataspace (NB: Flipped!) +;; -- 'actions-produced --> source is acting process; sink is dataspace (NB: Flipped!) ;; -- 'event --> source is dataspace; sink is receiving process ;; -- 'influence --> source is acting process; sink is receiving process ;; @@ -82,8 +86,12 @@ (notify! (current-actor-path-rev) (cons-pid pid) 'exit maybe-exn)) ;; PID Event -(define (trace-action-produced pid e) - (notify! (cons-pid pid) (current-actor-path-rev) 'action e)) +(define (trace-action-interpreted pid e) + (notify! (cons-pid pid) (current-actor-path-rev) 'action-interpreted e)) + +;; PID (Listof Event) +(define (trace-actions-produced pid es) + (notify! (cons-pid pid) (current-actor-path-rev) 'actions-produced es)) ;; PID Event (define (trace-event-consumed pid e) diff --git a/racket/syndicate/trace/stderr.rkt b/racket/syndicate/trace/stderr.rkt index 03ab2ff..419f01d 100644 --- a/racket/syndicate/trace/stderr.rkt +++ b/racket/syndicate/trace/stderr.rkt @@ -152,17 +152,30 @@ (output "~a raises an exception:\n~a\n" (format-pids process-names sink) (exn->string exn))))] - [('action (? patch? p)) + [('actions-produced actions) + ;; (when show-actions? + ;; (for [(a actions)] + ;; (match a + ;; [(? patch? p) + ;; (output "~a enqueues a patch\n" (format-pids process-names source))] + ;; [(message body) + ;; (output "~a enqueues a message\n" (format-pids process-names source))] + ;; ['quit + ;; (output "~a schedules a cleanup\n")] + ;; [(? actor? _) + ;; (output "~a enqueues a spawn\n" (format-pids process-names source))]))) + (void)] + [('action-interpreted (? patch? p)) (when show-actions? (output "~a performs a patch:\n~a\n" (format-pids process-names source) (patch->pretty-string (label-patch p #t))))] - [('action (message body)) + [('action-interpreted (message body)) (when show-actions? (output "~a broadcasts a message:\n~a\n" (format-pids process-names source) (pretty-format body)))] - [('action 'quit) + [('action-interpreted 'quit) (when show-lifecycle? (with-color BRIGHT-RED (output "~a exits\n" (format-pids process-names source))))