First running program; port some infrastructure from minimart
This commit is contained in:
parent
2fa40c3917
commit
e731282ddd
|
@ -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))))
|
||||
|
||||
|
|
|
@ -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))))
|
|
@ -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 ,?))))
|
|
@ -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)))
|
||||
|
|
|
@ -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)])]))])))))
|
|
@ -0,0 +1,7 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "core.rkt")
|
||||
(require "ground.rkt")
|
||||
|
||||
(provide (all-from-out "core.rkt")
|
||||
(all-from-out "ground.rkt"))
|
|
@ -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)))))
|
||||
)
|
||||
|
|
|
@ -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)]
|
||||
|
|
|
@ -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)))
|
Loading…
Reference in New Issue