First running program; port some infrastructure from minimart

This commit is contained in:
Tony Garnock-Jones 2015-03-05 14:54:12 +00:00
parent 2fa40c3917
commit e731282ddd
9 changed files with 668 additions and 61 deletions

View File

@ -1,7 +1,48 @@
#lang racket/base
;; Core implementation of Incremental Network Calculus.
(provide )
(provide (struct-out message)
(struct-out quit)
(except-out (struct-out spawn) spawn)
(rename-out [spawn <spawn>])
(struct-out process)
(struct-out transition)
(struct-out world)
(all-from-out "patch.rkt")
;; imported from route.rkt:
?
wildcard?
?!
(struct-out capture)
pretty-print-matcher
matcher->pretty-string
matcher-empty?
matcher-empty
projection->pattern
compile-projection
event?
action?
meta-label?
assert
retract
sub
unsub
pub
unpub
make-world
spawn-world
(rename-out [spawn-process spawn])
make-spawn-world
world-handle-event
clean-transition
)
(require racket/set)
(require racket/match)
@ -17,9 +58,9 @@
;; Actions ⊃ Events
(struct quit () #:prefab)
(struct spawn (behavior boot) #:prefab)
(struct spawn (boot) #:prefab)
;; Processes (machine states)
;; Processes (machine states): (process Matcher (Option Behavior) Any)
(struct process (interests behavior state) #:transparent)
;; A Behavior is a ((Option Event) Any -> Transition): a function
@ -53,6 +94,31 @@
(define (meta-label? x) (eq? x 'meta))
(define (prepend-at-meta pattern level)
(if (zero? level)
pattern
(at-meta (prepend-at-meta pattern (- level 1)))))
(define (observe-at-meta pattern level)
(if (zero? level)
(pattern->matcher #t (observe pattern))
(matcher-union
(pattern->matcher #t (observe (prepend-at-meta pattern level)))
(pattern->matcher #t (at-meta (embedded-matcher (observe-at-meta pattern (- level 1))))))))
(define (assert pattern #:meta-level [level 0])
(patch (pattern->matcher #t (prepend-at-meta pattern level)) (matcher-empty)))
(define (retract pattern #:meta-level [level 0])
(patch (matcher-empty) (pattern->matcher #t (prepend-at-meta pattern level))))
(define (sub pattern #:meta-level [level 0])
(patch (observe-at-meta pattern level) (matcher-empty)))
(define (unsub pattern #:meta-level [level 0])
(patch (matcher-empty) (observe-at-meta pattern level)))
(define (pub pattern #:meta-level [level 0]) (assert (advertise pattern) #:meta-level level))
(define (unpub pattern #:meta-level [level 0]) (retract (advertise pattern) #:meta-level level))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (ensure-transition v)
@ -65,14 +131,15 @@
(and t (transition (transition-state t) (clean-actions (transition-actions t)))))
(define (clean-actions actions)
(filter action? (flatten actions)))
(filter (lambda (x) (and (action? x) (not (patch-empty? x)))) (flatten actions)))
(define (send-event e pid w)
(match (hash-ref (world-process-table w) pid #f)
[#f w]
[(process _ #f _) w] ;; disabled due to earlier error
[(and p (process _ behavior old-state))
(invoke-process pid
(lambda () (behavior e old-state))
(lambda () (clean-transition (ensure-transition (behavior e old-state))))
(match-lambda
[#f w]
[(and t (transition new-state new-actions))
@ -83,7 +150,20 @@
w)])
(lambda (exn)
(trace-process-step e pid p exn #f)
(enqueue-actions w pid (list (quit)))))]))
(enqueue-actions (disable-process pid exn w) pid (list (quit)))))]))
(define (send-event/guard delta pid w)
(if (patch-empty? delta)
w
(send-event delta pid w)))
(define (disable-process pid exn w)
(log-error "Process ~a died with exception:\n~a" (cons pid (trace-pid-stack)) (exn->string exn))
(match (hash-ref (world-process-table w) pid #f)
[#f w]
[old-p
(define new-p (struct-copy process old-p [behavior #f]))
(struct-copy world w [process-table (hash-set (world-process-table w) pid new-p)])]))
(define (update-process pid p actions w)
(let* ((w (struct-copy world w [process-table (hash-set (world-process-table w) pid p)]))
@ -96,9 +176,7 @@
pid
(lambda ()
(with-handlers ([(lambda (exn) #t) (lambda (exn) (values #f exn))])
(values #t (clean-transition
(ensure-transition
(with-continuation-mark 'minimart-process pid (thunk)))))))))
(values #t (with-continuation-mark 'minimart-process pid (thunk)))))))
(if ok?
(k-ok result)
(k-exn result)))
@ -112,6 +190,13 @@
(queue-append-list (world-pending-action-queue w)
(for/list [(a actions)] (cons label a)))]))
(define-syntax-rule (spawn-process behavior-exp initial-state-exp initial-patch-exp ...)
(spawn (lambda (pid)
(process (apply-patch (matcher-empty)
(label-patch (patch-seq initial-patch-exp ...) (set pid)))
behavior-exp
initial-state-exp))))
(define-syntax-rule (spawn-world boot-action ...)
(make-spawn-world (lambda () (list boot-action ...))))
@ -124,8 +209,10 @@
(matcher-empty)))
(define (make-spawn-world boot-actions-thunk)
(spawn world-handle-event
(lambda () (transition (make-world (boot-actions-thunk)) '()))))
(spawn (lambda (pid)
(process (matcher-empty)
world-handle-event
(make-world (boot-actions-thunk))))))
(define (transition-bind k t0)
(match-define (transition state0 actions0) t0)
@ -144,19 +231,16 @@
(if (or e (not (inert? w)))
(sequence-transitions (transition w '())
(inject-event e)
perform-actions ;; to process queued actions and the new "e"
perform-actions ;; to process responses to "e"
;; ^ Double perform-actions makes it possible for children's
;; responses to the incoming "e" be acted upon in the same
;; event-handling cycle of the world.
step-children)
perform-actions
(lambda (w) (or (step-children w) (transition w '()))))
(step-children w)))
(define ((inject-event e) w)
(match e
[#f w]
[(? patch? delta) (enqueue-actions w 'meta (list (lift-patch delta)))]
[(message body) (enqueue-actions w 'meta (list (message (at-meta body))))]))
(transition (match e
[#f w]
[(? patch? delta) (enqueue-actions w 'meta (list (lift-patch delta)))]
[(message body) (enqueue-actions w 'meta (list (message (at-meta body))))])
'()))
(define (perform-actions w)
(for/fold ([wt (transition (struct-copy world w [pending-action-queue (make-queue)]) '())])
@ -168,40 +252,52 @@
(define ((perform-action label a) w)
(match a
[(spawn behavior boot)
(transition
(invoke-process 'booting
boot
(match-lambda
[(transition initial-state initial-actions)
(define new-p (process (matcher-empty) behavior initial-state))
(define new-pid (world-next-pid w))
[(spawn boot)
(define new-pid (world-next-pid w))
(invoke-process 'booting
(lambda ()
(match (boot new-pid)
[(? process? p) p]
[other (error 'spawn
"Spawn boot procedure must yield process; received ~v"
other)]))
(lambda (new-p)
(define new-interests (process-interests new-p))
(define new-w
(update-process new-pid
new-p
initial-actions
(struct-copy world w [next-pid (+ new-pid 1)]))])
(lambda (exn)
(log-error "Spawned process in world ~a died with exception:\n~a"
(trace-pid-stack)
(exn->string exn))
w))
'())]
'()
(struct-copy world w [next-pid (+ new-pid 1)])))
(apply-patch-in-world new-pid (patch new-interests (matcher-empty)) new-w))
(lambda (exn)
(log-error "Spawned process in world ~a died with exception:\n~a"
(trace-pid-stack)
(exn->string exn))
(transition w '())))]
[(quit)
(define pt (world-process-table w))
(match (hash-ref pt label)
(match (hash-ref pt label #f)
[#f (transition w '())]
[(process interests _ _)
(define delta (patch (matcher-empty) interests))
(define new-w (struct-copy world w [process-table (hash-remove pt label)]))
(define-values (discarded-actions retained-actions)
(queue-partition (lambda (e) (equal? (car e) label)) (world-pending-action-queue w)))
(when (not (queue-empty? discarded-actions))
(log-error "Process ~a had ~a queued actions at exit"
label
(queue-length discarded-actions)))
(define new-w (struct-copy world w
[process-table (hash-remove pt label)]
[pending-action-queue retained-actions]))
(apply-patch-in-world label delta new-w)])]
[(? patch? delta-orig)
(define p (hash-ref (world-process-table w) label))
(define p (hash-ref (world-process-table w) label #f))
(cond
[(or p (meta-label? label))
(define old-interests (if (meta-label? label)
(world-environment-interests w)
(process-interests p)))
(define delta (limit-patch (label-patch delta-orig label) old-interests))
(define delta (limit-patch (label-patch delta-orig (set label)) old-interests))
(define new-interests (apply-patch old-interests delta))
(define new-w
(if (meta-label? label)
@ -209,8 +305,10 @@
(let* ((p (struct-copy process p [interests new-interests])))
(struct-copy world w [process-table (hash-set (world-process-table w) label p)]))))
(apply-patch-in-world label delta new-w)]
[else ;; ignore actions for nonexistent processes
(transition w '())])]
[else ;; we can still apply actions for nonexistent processes,
;; but we can't limit the patches, making their zombie
;; patch actions potentially less efficient.
(apply-patch-in-world label delta-orig w)])]
[(and m (message body))
(when (observe? body)
(log-warning "Process ~a sent message containing query ~v"
@ -220,11 +318,14 @@
[(matcher-match-value (world-routing-table w) body #f) ;; some other process has declared m
(transition w '())]
[else
(define affected-pids (matcher-match-value (world-routing-table w) (observe body)))
(define local-to-meta? (and (not (meta-label? label)) ;; it's from a local process, not envt
(at-meta? body))) ;; it relates to envt, not local
(define affected-pids (if local-to-meta?
(set)
(matcher-match-value (world-routing-table w) (observe body))))
(transition (for/fold [(w w)] [(pid (in-set affected-pids))]
(send-event m pid w))
(and (not (meta-label? label))
(at-meta? body)
(and local-to-meta?
(message (at-meta-claim body))))])]))
(define (apply-patch-in-world label delta w)
@ -239,11 +340,11 @@
(define feedback
(patch (biased-intersection new-routing-table (patch-added delta))
(biased-intersection old-routing-table (patch-removed delta))))
(send-event feedback label w)]
(send-event/guard feedback label w)]
[else
(define p (hash-ref (world-process-table w) pid))
(define event (view-patch delta-aggregate (process-interests p)))
(send-event event pid w)]))
(send-event/guard event pid w)]))
(and (not (meta-label? label))
(drop-patch delta-aggregate))))

View File

@ -0,0 +1,87 @@
#lang racket/base
;; Timer driver.
;; Uses mutable state internally, but because the scope of the
;; mutation is limited to each timer process alone, it's easy to show
;; correct linear use of the various pointers.
(require racket/set)
(require racket/match)
(require data/heap)
(require "../main.rkt")
(struct pending-timer (deadline label) #:transparent)
(provide (struct-out set-timer)
(struct-out timer-expired)
spawn-timer-driver)
(struct set-timer (label msecs kind) #:prefab)
(struct timer-expired (label msecs) #:prefab)
(define (spawn-timer-driver)
(define control-ch (make-channel))
(thread (lambda () (timer-driver-thread-main control-ch)))
(define (timer-driver e count)
(match e
[(message (at-meta (and expiry (timer-expired _ _))))
(transition (- count 1)
(list (message expiry)
(when (= count 1) (unsub (timer-expired ? ?) #:meta-level 1))))]
[(message (and instruction (set-timer _ _ _)))
(channel-put control-ch instruction)
(transition (+ count 1)
(when (= count 0) (sub (timer-expired ? ?) #:meta-level 1)))]
[_ #f]))
(spawn timer-driver
0 ;; initial count
(sub (set-timer ? ? ?))
(pub (timer-expired ? ?))))
(define (timer-driver-thread-main control-ch)
(define heap (make-timer-heap))
(let loop ()
(sync (match (next-timer heap)
[#f never-evt]
[t (handle-evt (timer-evt (pending-timer-deadline t))
(lambda (now)
(for-each send-ground-message (fire-timers! heap now))
(loop)))])
(handle-evt control-ch
(match-lambda
[(set-timer label msecs 'relative)
(install-timer! heap label (+ (current-inexact-milliseconds) msecs))
(loop)]
[(set-timer label msecs 'absolute)
(install-timer! heap label msecs)
(loop)]
['quit (void)])))))
(define (make-timer-heap)
(make-heap (lambda (t1 t2) (<= (pending-timer-deadline t1) (pending-timer-deadline t2)))))
(define (next-timer heap)
(and (positive? (heap-count heap))
(heap-min heap)))
(define (fire-timers! heap now)
(if (zero? (heap-count heap))
'()
(let ((m (heap-min heap)))
(if (<= (pending-timer-deadline m) now)
(begin (heap-remove-min! heap)
(cons (timer-expired (pending-timer-label m) now)
(fire-timers! heap now)))
'()))))
(define (install-timer! heap label deadline)
(define now (current-inexact-milliseconds))
(heap-add! heap (pending-timer deadline label)))
;; Racket's alarm-evt is almost the right design for timeouts: its
;; synchronisation value should be the (or some) value of the clock
;; after the asked-for time. That way it serves as timeout and
;; clock-reader in one.
(define (timer-evt msecs)
(handle-evt (alarm-evt msecs)
(lambda (_) (current-inexact-milliseconds))))

View File

@ -0,0 +1,70 @@
#lang racket/base
(require racket/match)
(require (only-in racket/port read-line-evt))
(require "../main.rkt")
(require "../drivers/timer.rkt")
(define (quasi-spy e s)
(printf "----------------------------------------\n")
(printf "QUASI-SPY:\n")
(match e
[(? patch? p) (pretty-print-patch p)]
[other
(write other)
(newline)])
(printf "========================================\n")
#f)
(define (r e s)
(match e
[(message body) (transition s (message (at-meta `(print (got ,body)))))]
[_ #f]))
(define (b e n)
(match e
[#f (if (< n 10)
(transition (+ n 1) (message `(hello ,n)))
#f)]
[_ #f]))
(define (echoer e s)
(match e
[(message (at-meta (external-event _ (list (? eof-object?)))))
(transition s (quit))]
[(message (at-meta (external-event _ (list line))))
(transition s (message `(print (got-line ,line))))]
[_ #f]))
(define (ticker e s)
(match e
[(? patch? p)
(printf "TICKER PATCH RECEIVED:\n")
(pretty-print-patch p)
#f]
[(message (timer-expired 'tick now))
(printf "TICK ~v\n" now)
(transition (+ s 1) (if (< s 3)
(message (set-timer 'tick 1000 'relative))
(quit)))]
[_ #f]))
(define (printer e s)
(match e
[(message (list 'print v))
(log-info "PRINTER: ~a" v)
#f]
[_ #f]))
(run-ground (spawn quasi-spy (void) (sub ?))
(spawn-timer-driver)
(message (set-timer 'tick 1000 'relative))
(spawn ticker 1
(sub (observe (set-timer ? ? ?)))
(sub (timer-expired 'tick ?)))
(spawn-world (spawn r (void) (sub ?))
(spawn b 0))
(spawn echoer (void)
(sub (external-event (read-line-evt (current-input-port) 'any) ?)
#:meta-level 1))
(spawn printer (void) (sub `(print ,?))))

View File

@ -13,7 +13,10 @@
queue-append
queue-append-list
queue-extract
queue-filter)
queue-filter
queue-partition)
(require (only-in racket/list partition))
(struct queue (head tail) #:transparent)
@ -84,3 +87,9 @@
(define (queue-filter pred q)
(queue (filter pred (queue-head q))
(filter pred (queue-tail q))))
(define (queue-partition pred q)
(define-values (head-t head-f) (partition pred (queue-head q)))
(define-values (tail-t tail-f) (partition pred (queue-tail q)))
(values (queue head-t tail-t)
(queue head-f tail-f)))

94
prospect/ground.rkt Normal file
View File

@ -0,0 +1,94 @@
#lang racket/base
;; Breaking the infinite tower of nested Worlds, connecting to the "real" world at the fracture line.
(require racket/async-channel)
(require racket/set)
(require racket/match)
(require racket/list)
(require "core.rkt")
(require "route.rkt")
(require "trace/stderr.rkt")
(provide (struct-out external-event)
send-ground-message
run-ground)
;;---------------------------------------------------------------------------
;; Communication via regular subscription and messages from other threads
;; (Parameterof (Option AsyncChannel))
;; Communication channel from auxiliary (usually driver) threads to
;; the currently-active ground VM.
(define current-ground-event-async-channel (make-parameter (make-async-channel)))
;; Any -> Void
;; Sends a message at the ground-VM metalevel.
(define (send-ground-message body)
(async-channel-put (current-ground-event-async-channel) (message body)))
;;---------------------------------------------------------------------------
;; Communication via RacketEvents
;; A GroundEvent is a pair of a Racket (evt?) event and its yielded
;; results.
;; - (external-event RacketEvent (Listof Any))
(struct external-event (descriptor values) #:prefab)
;; RacketEvent -> RacketEvent
;; Wraps a CML-style Racket event with a handler that sends the event
;; results via the ground VM.
(define (event-handler descriptor)
(handle-evt descriptor (lambda vs (message (external-event descriptor vs)))))
;; Projection
;; Used to extract event descriptors and results from subscriptions
;; from the ground VM's contained World.
(define event-projection (compile-projection (observe (external-event (?!) ?))))
;; Interests -> (Listof RacketEvent)
;; Projects out the active event subscriptions from the given interests.
(define (extract-active-events interests)
(define es (matcher-key-set/single (matcher-project interests event-projection)))
;; TODO: how should the following error be handled, ideally?
;; In principle, security restrictions should make it impossible.
;; But absent those, what should be done? Should an offending
;; process be identified and terminated?
(unless es (error 'extract-active-events "User program subscribed to wildcard event"))
(for/list [(e (in-set es))] (event-handler e)))
;;---------------------------------------------------------------------------
;; RacketEvent
;; Used only when the system is not provably inert, in order to let it
;; take further internal reductions.
(define idle-handler
(handle-evt (system-idle-evt) (lambda _ #f)))
;; Action* -> Void
;; Runs a ground VM, booting the outermost World with the given Actions.
(define (run-ground . boot-actions)
(let await-interrupt ((inert? #f)
(w (make-world boot-actions))
(interests (matcher-empty)))
;; (log-info "GROUND INTERESTS:\n~a" (matcher->pretty-string interests))
(if (and inert? (matcher-empty? interests))
(begin (log-info "run-ground: Terminating because inert")
(void))
(let ((e (apply sync
(current-ground-event-async-channel)
(if inert? never-evt idle-handler)
(extract-active-events interests))))
(match (clean-transition (world-handle-event e w))
[#f ;; inert
(await-interrupt #t w interests)]
[(transition w actions)
(let process-actions ((actions actions) (interests interests))
(match actions
['() (await-interrupt #f w interests)]
[(cons a actions)
(match a
[(? patch? p)
(process-actions actions (apply-patch interests (label-patch p (set 'root))))]
[_
(log-warning "run-ground: ignoring useless meta-action ~v" a)
(process-actions actions interests)])]))])))))

7
prospect/main.rkt Normal file
View File

@ -0,0 +1,7 @@
#lang racket/base
(require "core.rkt")
(require "ground.rkt")
(provide (all-from-out "core.rkt")
(all-from-out "ground.rkt"))

View File

@ -4,14 +4,22 @@
(provide (struct-out patch)
(struct-out observe)
(struct-out at-meta)
(struct-out advertise)
empty-patch
patch-empty?
lift-patch
drop-patch
strip-interests
label-interests
strip-patch
label-patch
limit-patch
compute-aggregate-patch
apply-patch
unapply-patch
compose-patch
patch-seq
patch-seq*
compute-patch
biased-intersection
view-patch
@ -28,15 +36,23 @@
;; Patches
(struct patch (added removed) #:prefab)
;; Claims, Interests, and Locations
(struct observe (pattern) #:prefab)
;; Claims, Interests, Locations, and Advertisements
(struct observe (claim) #:prefab)
(struct at-meta (claim) #:prefab)
(struct advertise (claim) #:prefab)
(define empty-patch (patch (matcher-empty) (matcher-empty)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define at-meta-proj (compile-projection (at-meta (?!))))
(define observe-proj (compile-projection (observe (?!))))
(define (patch-empty? p)
(and (patch? p)
(matcher-empty? (patch-added p))
(matcher-empty? (patch-removed p))))
(define (lift-patch p)
(match-define (patch in out) p)
(patch (pattern->matcher #t (at-meta (embedded-matcher in)))
@ -58,6 +74,10 @@
(define (label-interests g label)
(matcher-relabel g (lambda (v) label)))
(define (strip-patch p)
(patch (strip-interests (patch-added p))
(strip-interests (patch-removed p))))
(define (label-patch p label)
(patch (label-interests (patch-added p) label)
(label-interests (patch-removed p) label)))
@ -81,16 +101,28 @@
(matcher-union (matcher-subtract base in) out))
(define (compose-patch p2 p1) ;; p2 after p1
;; Can be defined as (patch (apply-patch in1 p2) (unapply-patch out1 p2)),
;; except for problems arising from use of set-subtract by default in {un,}apply-patch
(match-define (patch in1 out1) p1)
(patch (apply-patch in1 p2)
(unapply-patch out1 p2)))
(match-define (patch in2 out2) p2)
(patch (matcher-union (matcher-subtract in1 out2 #:combiner (lambda (v1 v2) #f)) in2
#:combiner (lambda (v1 v2) #t))
(matcher-union (matcher-subtract out1 in2 #:combiner (lambda (v1 v2) #f)) out2
#:combiner (lambda (v1 v2) #t))))
(define (patch-seq . patches) (patch-seq* patches))
(define (patch-seq* patches)
(match patches
['() empty-patch]
[(cons p rest) (compose-patch (patch-seq* rest) p)]))
(define (compute-patch old-base new-base)
(patch (matcher-subtract new-base old-base)
(matcher-subtract old-base new-base)))
(define (biased-intersection object subject)
(matcher-project (matcher-intersect (observe (embedded-matcher object))
(matcher-project (matcher-intersect (pattern->matcher #t (observe (embedded-matcher object)))
subject
#:combiner (lambda (v1 v2) #t))
observe-proj
@ -101,13 +133,13 @@
(patch (biased-intersection (patch-added p) interests)
(biased-intersection (patch-removed p) interests)))
(define (pretty-print-patch p)
(define (pretty-print-patch p [port (current-output-port)])
(match-define (patch in out) p)
(printf "<<<<<<<< Removed:\n")
(pretty-print-matcher out)
(printf "======== Added:\n")
(pretty-print-matcher in)
(printf ">>>>>>>>\n"))
(fprintf port "<<<<<<<< Removed:\n")
(pretty-print-matcher out port)
(fprintf port "======== Added:\n")
(pretty-print-matcher in port)
(fprintf port ">>>>>>>>\n"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -175,6 +207,18 @@
(printf "\ndrop after lift mc/mab:\n")
(void (pretty-print-patch (drop-patch (lift-patch (patch mc mab)))))
(printf "\ncompose mbc/m0 after mc/mab:\n")
(void (pretty-print-patch (compose-patch (patch mbc m0) (patch mc mab))))
(printf "\ncompose mc/mab after mbc/m0:\n")
(void (pretty-print-patch (compose-patch (patch mc mab) (patch mbc m0))))
(printf "\ncompose mc/m* (not disjoint) after mbc/m0:\n")
(void (pretty-print-patch (compose-patch (patch mc m*) (patch mbc m0))))
(printf "\ncompose mbc/m0 after mc/m* (not disjoint):\n")
(void (pretty-print-patch (compose-patch (patch mbc m0) (patch mc m*))))
(printf "\ncompose mbc/m0 after lift mc/mab:\n")
(void (pretty-print-patch (compose-patch (patch mbc m0)
(lift-patch (patch mc mab)))))
@ -182,4 +226,8 @@
(printf "\ndrop (compose mbc/m0 after lift mc/mab):\n")
(void (pretty-print-patch (drop-patch (compose-patch (patch mbc m0)
(lift-patch (patch mc mab))))))
(printf "\nstripped compose mc/m* (not disjoint) after mbc/m0:\n")
(void (pretty-print-patch (compose-patch (strip-patch (patch mc m*))
(strip-patch (patch mbc m0)))))
)

View File

@ -770,7 +770,7 @@
(define (walk i m)
(match m
[#f
(d "::: no further matches possible")]
(d "::: nothing")]
[(wildcard-sequence k)
(d " ...>")
(walk (+ i 5) k)]

191
prospect/trace/stderr.rkt Normal file
View File

@ -0,0 +1,191 @@
#lang racket/base
(provide set-stderr-trace-flags!)
(require racket/set)
(require racket/match)
(require racket/pretty)
(require (only-in racket/string string-join))
(require (only-in web-server/private/util exn->string))
(require "../core.rkt")
(require "../trace.rkt")
(define (env-aref varname default alist)
(define key (or (getenv varname) default))
(cond [(assoc key alist) => cadr]
[else (error 'env-aref
"Expected environment variable ~a to contain one of ~v; got ~v"
(map car alist)
key)]))
(define colored-output? (env-aref "MINIMART_COLOR" "true" '(("true" #t) ("false" #f))))
(define flags (set))
(define show-exceptions? #f)
(define show-patch-events? #f)
(define show-message-events? #f)
(define show-events? #f)
(define show-process-states-pre? #f)
(define show-process-states-post? #f)
(define show-process-lifecycle? #f)
(define show-patch-actions? #f)
(define show-message-actions? #f)
(define show-actions? #f)
(define show-routing-table? #f)
(define (set-stderr-trace-flags! flags-string)
(set! flags (for/set [(c flags-string)] (string->symbol (string c))))
(set! show-exceptions? (set-member? flags 'x))
(set! show-patch-events? (set-member? flags 'r))
(set! show-message-events? (set-member? flags 'm))
(set! show-events? (set-member? flags 'e))
(set! show-process-states-pre? (set-member? flags 's))
(set! show-process-states-post? (set-member? flags 't))
(set! show-process-lifecycle? (set-member? flags 'p))
(set! show-patch-actions? (set-member? flags 'R))
(set! show-message-actions? (set-member? flags 'M))
(set! show-actions? (set-member? flags 'a))
(set! show-routing-table? (set-member? flags 'g)))
(set-stderr-trace-flags! (or (getenv "MINIMART_TRACE") ""))
(define YELLOW-ON-RED ";1;33;41")
(define WHITE-ON-RED ";1;37;41")
(define WHITE-ON-GREEN ";1;37;42")
(define GREY-ON-RED ";37;41")
(define GREY-ON-GREEN ";37;42")
(define RED ";31")
(define BRIGHT-RED ";1;31")
(define GREEN ";32")
(define BRIGHT-GREEN ";1;32")
(define YELLOW ";33")
(define BLUE ";34")
(define BRIGHT-BLUE ";1;34")
(define NORMAL "")
(define (format-pids pids)
(match pids
['() "ground"]
[(cons 'meta rest) (format "boot action of ~a" (format-pids rest))]
[_ (string-join (map number->string (reverse pids)) ":")]))
(define (output fmt . args)
(apply fprintf (current-error-port) fmt args))
(define (output-state state)
(cond
[(world? state) (output "#<world>\n")]
[else (pretty-write state (current-error-port))]))
(define (boring-state? state)
(or (world? state)
(void? state)))
(define (set-color! c) (when colored-output? (output "\e[0~am" c)))
(define (reset-color!) (when colored-output? (output "\e[0m")))
(define-syntax-rule (with-color c expr ...)
(begin (set-color! c)
(begin0 (begin expr ...)
(reset-color!))))
(define (display-trace)
(define receiver (make-log-receiver trace-logger 'info))
(parameterize ((pretty-print-columns 100))
(let loop ()
(match-define (vector level message-string data event-name) (sync receiver))
(match* (event-name data)
[('process-step (list pids e p exn t))
(define pidstr (format-pids pids))
(define relevant-exn? (and show-exceptions? exn))
(match e
[#f
(when (or relevant-exn? show-events?)
(with-color YELLOW (output "~a was polled for changes.\n" pidstr)))]
[(? patch? p)
(when (or relevant-exn? show-events? show-patch-events?)
(with-color YELLOW
(output "~a received a patch:\n" pidstr)
(pretty-print-patch p (current-error-port))))]
[(message body)
(when (or relevant-exn? show-events? show-message-events?)
(with-color YELLOW
(output "~a received a message:\n" pidstr)
(pretty-write body (current-error-port))))])
(when (or relevant-exn? show-process-states-pre?)
(when (or relevant-exn? (not (boring-state? (process-state p))))
(with-color YELLOW
(output "~a's state just before the event:\n" pidstr)
(output-state (process-state p)))))
(when relevant-exn?
(with-color WHITE-ON-RED
(output "Process ~a died with exception:\n~a\n"
pidstr
(exn->string exn))))
(when (or relevant-exn? show-process-states-post?)
(when t
(unless (boring-state? (transition-state t))
(when (not (equal? (process-state p) (transition-state t)))
(with-color YELLOW
(output "~a's state just after the event:\n" pidstr)
(output-state (transition-state t)))))))]
[('internal-step (list pids a old-w t))
(when t ;; inert worlds don't change interestingly
(define pidstr (format-pids pids))
(define new-w (transition-state t))
(define old-processes (world-process-table old-w))
(define new-processes (world-process-table new-w))
(define newcount (hash-count new-processes))
(match a
[(? spawn?)
(when (or show-process-lifecycle? show-actions?)
(define newpid (set-first (set-subtract (hash-keys new-processes)
(hash-keys old-processes))))
(define newpidstr (format-pids (cons newpid (cdr pids)))) ;; replace parent pid
(match-define (process interests behavior state) (hash-ref new-processes newpid))
(with-color BRIGHT-GREEN
(output "~a ~v spawned from ~a (~a total processes now)\n"
newpidstr
behavior
pidstr
newcount))
(unless (boring-state? state)
(output "~a's initial state:\n" newpidstr)
(output-state state))
(unless (matcher-empty? interests)
(output "~a's initial interests:\n" newpidstr)
(pretty-print-matcher interests (current-error-port))))]
[(quit)
(when (or show-process-lifecycle? show-actions?)
(match (hash-ref old-processes (car pids) (lambda () #f))
[#f (void)]
[(process interests behavior state)
(with-color BRIGHT-RED
(output "~a ~v exited (~a total processes now)\n"
pidstr
behavior
newcount))
(unless (boring-state? state)
(output "~a's final state:\n" pidstr)
(output-state state))
(unless (matcher-empty? interests)
(output "~a's final interests:\n" pidstr)
(pretty-print-matcher interests (current-error-port)))]))]
[(? patch? p)
(when (or show-actions? show-patch-actions?)
(output "~a performed a patch:\n" pidstr)
(pretty-print-patch p (current-error-port)))]
[(message body)
(when (or show-actions? show-message-actions?)
(output "~a sent a message:\n" pidstr)
(pretty-write body (current-error-port)))])
(when show-routing-table?
(when (not (equal? (world-routing-table old-w) (world-routing-table new-w)))
(with-color BRIGHT-BLUE
(output "~a's routing table:\n" (format-pids (cdr pids)))
(pretty-print-matcher (world-routing-table new-w)
(current-error-port))))))])
(loop))))
(void (when (not (set-empty? flags))
(thread display-trace)))