syndicate-2017/racket/syndicate/actor.rkt

905 lines
36 KiB
Racket

#lang racket/base
(provide actor
network
;; background
state
until
forever
assert!
retract!
send!
return!
return/no-link-result!
perform-core-action!
;; forall
actor-body->spawn-action
;;----------------------------------------
(struct-out actor-state)
pretty-print-actor-state
(for-syntax analyze-pattern)
syndicate-actor-prompt-tag-installed?
)
(require (for-syntax racket/base))
(require (for-syntax racket/sequence))
(require "support/dsl.rkt")
(require "pretty.rkt")
(define&provide-dsl-helper-syntaxes "state/until/forever form"
[on
during
assert
track
asserted
retracted
message
rising-edge
exists
])
(require (for-syntax racket/match))
(require (for-syntax racket/list))
(require (for-syntax syntax/parse))
(require (for-syntax syntax/stx))
(require racket/set)
(require racket/match)
(require (except-in "core.rkt" assert network)
(rename-in "core.rkt" [assert core:assert] [network core:network]))
(require "trie.rkt")
(require "mux.rkt")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Actor State
;; A Variables is a (Vectorof Any), storing the explicit state
;; variables of an actor.
;; An Aggregates is a (Hashtable Nat Any), storing implicit state of
;; an actor, including tracked and implicit aggregates.
;; A Script is a (-> Variables). It is to be executed inside
;; the special syndicate-hll prompt, and so may have Instruction
;; side-effects.
;; An Instruction is one of
;; - (patch-instruction Patch (Void -> Instruction))
;; - (action-instruction Action (Void -> Instruction))
;; - (return-instruction (Option (Listof Any)))
;; - (spawn-instruction LinkageKind (Symbol Symbol -> Spawn) (Void -> Instruction))
;; - (script-complete-instruction Variables)
;; and represents a side-effect for an actor to take in its
;; interactions with the outside world.
;;
;; A LinkageKind is one of
;; - 'call, a blocking, exception-linked connection
;; - 'actor, a non-blocking, non-exception-linked connection
;; - 'network, a non-blocking, nested, non-exception-linked connection
;;
;; Patch Instructions are issued when the actor uses `assert!` and
;; `retract!`. Action instructions are issued when the actor uses
;; `perform-core-action!`, and return instructions when `return!` is
;; called. Script-complete instructions are automatically issued when
;; a Script terminates successfully.
;;
;; Spawn instructions are issued when `actor`, `network`, and `state`
;; are used, directly or indirectly. (TODO: `background`?) The
;; spawn-action-producing function is given the IDs of the spawned and
;; spawning actors, and is to return an action which spawns the new
;; actor, which in turn engages in the appropriate linkage protocol
;; with the spawning actor. The (Void -> Instruction) continuation is
;; released when the spawned actor terminates (for blocking variants)
;; or immediately following the spawn (for non-blocking variants).
;;
;; (Background is done differently, with a new continuation for the
;; background script, and a self-send to activate it. (TODO))
;;
(struct patch-instruction (patch k) #:transparent)
(struct action-instruction (action k) #:transparent)
(struct return-instruction (result-values) #:transparent)
(struct spawn-instruction (linkage-kind action-fn k) #:transparent)
(struct script-complete-instruction (variables) #:transparent)
;; An ActorState is an (actor-state ... as below), describing the
;; state of an HLL actor.
;;
(struct actor-state (continuation-table ;; (Hashtable Symbol (Variables Any ... -> Instruction))
caller-id ;; Symbol
self-id ;; Symbol
variables ;; Variables
aggregates ;; Aggregates
pending-patch ;; (Option Patch) - aggregate patch being accumulated
mux ;; Mux
)
#:transparent
#:methods gen:syndicate-pretty-printable
[(define (syndicate-pretty-print s [p (current-output-port)])
(pretty-print-actor-state s p))])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Linkage protocol
;;
;; Linkages are used to both propagate values from callee to caller
;; and to monitor callee presence for exception-propagation.
;; - assertion: LinkActive
;; - message: LinkResult
;; - role: Caller
;; Monitors LinkActive to detect termination of the Callee,
;; normal or abnormal. If LinkResult is received before
;; LinkActive vanishes, termination was normal; otherwise, it
;; was abnormal.
;; - role: Callee
;; Asserts LinkActive while it runs. Should send LinkResult
;; before termination to indicate success and communicate values
;; to Caller.
;;
;; A LinkActive is a (link-active Symbol Symbol), describing an
;; ongoing relationship between the indicated caller and callee.
(struct link-active (caller-id callee-id) #:transparent)
;;
;; A LinkResult is a (link-result Symbol Symbol (Listof Any)),
;; describing the final values yielded by a callee to its caller.
(struct link-result (caller-id callee-id values) #:transparent) ;; message
;; Projection for observing LinkActive.
(define link-active-projection (link-active ? (?!)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Producing Instruction side-effects
(define prompt (make-continuation-prompt-tag 'syndicate-hll))
(define (syndicate-actor-prompt-tag-installed?)
(continuation-prompt-available? prompt))
;; (Any ... -> Nothing) -> (Any ... -> Instruction)
(define (reply-to k)
(lambda reply-values
(call-with-continuation-prompt (lambda ()
(apply k reply-values)
(error 'reply-to "Script returned directly"))
prompt)))
;; (-> Instruction) -> Nothing
(define (call-in-raw-context/abort proc)
(abort-current-continuation prompt proc))
;; ((Any ... -> Instruction) -> Instruction)
(define (call-in-raw-context proc)
(when (not (syndicate-actor-prompt-tag-installed?))
(error 'call-in-raw-context
"Attempt to invoke imperative Syndicate actor action outside actor context."))
(call-with-composable-continuation
(lambda (k) (abort-current-continuation prompt (lambda () (proc (reply-to k)))))
prompt))
;; Returns void
(define (assert! P #:meta-level [meta-level 0])
(call-in-raw-context
(lambda (k) (patch-instruction (core:assert P #:meta-level meta-level) k))))
;; Returns void
(define (retract! P #:meta-level [meta-level 0])
(call-in-raw-context
(lambda (k) (patch-instruction (retract P #:meta-level meta-level) k))))
;; Returns void
(define (send! M #:meta-level [meta-level 0])
(perform-core-action! (message (prepend-at-meta M meta-level))))
;; Returns void
(define (perform-core-action! A)
(call-in-raw-context
(lambda (k) (action-instruction A k))))
;; Does not return to caller; instead, terminates the current actor
;; after sending a link-result to the calling actor.
(define (return! . result-values)
(call-in-raw-context/abort
(lambda () (return-instruction result-values))))
;; Does not return to caller; instead, terminates the current actor
;; without sending a link-result to the calling actor.
(define (return/no-link-result!)
(call-in-raw-context/abort
(lambda () (return-instruction #f))))
;; Returns new variables, plus values from spawned actor if any.
(define (spawn! linkage-kind action-fn)
(call-in-raw-context
(lambda (k) (spawn-instruction linkage-kind action-fn k))))
(begin-for-syntax
(define-splicing-syntax-class init
(pattern (~seq #:init [I ...]))
(pattern (~seq) #:attr [I 1] '()))
(define-splicing-syntax-class done
(pattern (~seq #:done [I ...]))
(pattern (~seq) #:attr [I 1] '()))
(define-splicing-syntax-class bindings
(pattern (~seq #:collect [(id init) ...]))
(pattern (~seq) #:attr [id 1] '() #:attr [init 1] '())))
;; Syntax for spawning a 'call-linked actor.
(define-syntax (state stx)
(syntax-parse stx
[(_ init:init [bs:bindings O ...] [E Oe ...] ...)
(expand-state 'call #'(init.I ...) #'(bs.id ...) #'(bs.init ...) #'(O ...) #'([E Oe ...] ...))]))
;; Sugar
(define-syntax (until stx)
(syntax-parse stx
[(_ E init:init done:done bs:bindings O ...)
#'(state #:init [init.I ...] [#:collect [(bs.id bs.init) ...] O ...] [E done.I ... (values)])]))
;; Sugar
(define-syntax (forever stx)
(syntax-parse stx
[(_ init:init bs:bindings O ...)
#'(state #:init [init.I ...] [#:collect [(bs.id bs.init) ...] O ...])]))
;; Spawn actors with 'actor linkage
(define-syntax (actor stx)
(syntax-parse stx
[(_ I ...)
(expand-state 'actor #'(I ... (return/no-link-result!)) #'() #'() #'() #'())]))
;; Spawn whole networks
(define-syntax (network stx)
(syntax-parse stx
[(_ I ...)
(expand-state 'network
#'(I
...
(perform-core-action! (quit-network))
(return/no-link-result!))
#'()
#'()
#'()
#'())]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Main behavior of HLL actors
;; Special mux label used to track ad-hoc assertions
;; TODO: Revisit this, it is a bit ugly
(define *adhoc-label* -1)
;; Special mux label used to track linkage between actors.
;; TODO: Revisit this, it is a bit ugly
(define *linkage-label* -2)
;; Behavior
(define (generic-actor-behavior e s)
(match e
[(? patch/removed? p)
(define continuation-table (actor-state-continuation-table s))
(define quit?
(for/or [(callee-id (trie-project/set/single (patch-removed p) link-active-projection))]
(hash-has-key? continuation-table callee-id)))
(if quit? ;; TODO: raise exception instead? Signal the cause of the quit somehow?
(quit)
#f)]
[(message (link-result (== (actor-state-self-id s)) callee-id reply-values))
;; ^ NB. We, in principle, shouldn't need to check the
;; link-result's caller against our own self-id here, because
;; events should be routed to us only when generally falling
;; within our interests. First, the current implementation
;; overapproximates (though it could use a mux to be precise);
;; second, *in principle*, overapproximation should perhaps be
;; seen as OK, since routing may be able to be done much more
;; efficiently by overapproximating interest slightly. Imagine
;; using a bloom filter, for instance.
(invoke-stored-continuation s callee-id reply-values)]
[_ #f]))
;; ActorState Symbol (Variables Any ... -> Instruction) -> ActorState
(define (store-continuation s callee-id get-next-instr)
(struct-copy actor-state s
[continuation-table
(hash-set (actor-state-continuation-table s)
callee-id
get-next-instr)]))
;; ActorState Symbol (Listof Any) -> Transition
(define (invoke-stored-continuation s callee-id reply-values)
(define continuation-table (actor-state-continuation-table s))
(define continuation (hash-ref continuation-table callee-id #f))
(define new-table (hash-remove continuation-table callee-id))
;; (log-info "invoke-stored-continuation self=~a callee=~a values=~v k=~v"
;; (actor-state-self-id s)
;; callee-id
;; reply-values
;; continuation)
(handle-actor-syscall (transition (struct-copy actor-state s [continuation-table new-table])
'())
(apply continuation
(append reply-values (vector->list (actor-state-variables s))))))
;; ActorState -> Transition
(define (perform-pending-patch s)
(transition (struct-copy actor-state s [pending-patch #f]) (actor-state-pending-patch s)))
;; Label Patch -> ActorState -> Transition
(define ((extend-pending-patch label p) s)
(define-values (new-mux _label _p p-aggregate)
(mux-update-stream (actor-state-mux s) label p))
(define p0 (actor-state-pending-patch s))
(define new-pending-patch (if p0 (patch-seq p0 p-aggregate) p-aggregate))
(transition (struct-copy actor-state s
[pending-patch new-pending-patch]
[mux new-mux])
'()))
;; ActorState Script -> Transition
(define (run-script s script)
(handle-actor-syscall (transition s '())
((reply-to (lambda (dummy)
(define new-variables (script))
(call-in-raw-context/abort
(lambda ()
(script-complete-instruction new-variables)))))
(void))))
(define (actor-body->spawn-action thunk)
(match ((reply-to (lambda (dummy)
(actor (thunk))
(error '%%boot "Reached end of boot thunk")))
(void))
[(spawn-instruction 'actor action-fn _get-next-instr)
(action-fn (gensym 'root-actor) (gensym 'boot-actor))]))
;; Transition Instruction -> Transition
(define (handle-actor-syscall t instr)
(match instr
[(patch-instruction p get-next-instr)
(handle-actor-syscall (sequence-transitions t
(extend-pending-patch *adhoc-label* p))
(get-next-instr (void)))]
[(action-instruction a get-next-instr)
(handle-actor-syscall (sequence-transitions t
perform-pending-patch
(lambda (s) (transition s a)))
(get-next-instr (void)))]
[(return-instruction result-values)
(sequence-transitions t
perform-pending-patch
(lambda (s)
(if result-values
(quit (message (link-result (actor-state-caller-id s)
(actor-state-self-id s)
result-values)))
(quit))))]
[(spawn-instruction linkage-kind action-fn get-next-instr)
(define blocking? (eq? linkage-kind 'call))
(define next-t
(sequence-transitions t
perform-pending-patch
(lambda (s)
(define callee-id (gensym linkage-kind))
(define spawn-action (action-fn callee-id (actor-state-self-id s)))
(transition (if blocking?
(store-continuation s callee-id get-next-instr)
s)
(if (eq? linkage-kind 'network)
(spawn-network spawn-action)
spawn-action)))))
(if blocking?
next-t
(handle-actor-syscall next-t (get-next-instr (void))))]
[(script-complete-instruction new-variables)
(sequence-transitions t
;; NB: Does not perform-pending-patch here.
;; Instead, the script runner will now
;; update ongoing subscriptions and
;; incorporate the pending patch into that
;; process.
(lambda (s)
(transition (struct-copy actor-state s [variables new-variables])
'())))]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Compilation of HLL actors
;; TODO: track
;; TODO: default to hll
;; TODO: some better means of keeping track of nested network levels
(begin-for-syntax
(define-splicing-syntax-class when-pred
(pattern (~seq #:when Pred))
(pattern (~seq) #:attr Pred #'#t))
(define-splicing-syntax-class meta-level
(pattern (~seq #:meta-level level:integer))
(pattern (~seq) #:attr level #'0))
(define (expand-state linkage-kind init-actions binding-names binding-inits ongoings edges)
;; ----------------------------------------
(define binding-count (length (syntax->list binding-names)))
;; ----------------------------------------
;; A StageProducer is a ((Syntax <Expr:Event>) -> (Syntax <Expr:(ActorState -> Transition)>)).
;; It computes a behavior stage suitable for composition using sequence-transitions.
;; It is given syntax for an expression yielding the actor's current event.
;; Records syntaxes for aggregate initializers.
;; (Boxof (Listof (Syntax <Expr:Any>)))
(define aggregate-init-stxs (box '()))
;; Records aggregate updaters.
;; (Boxof (Listof StageProducer))
(define track-updaters (box '()))
;; Records both actual event handlers and termination check handlers.
;; (Boxof (Listof StageProducer))
(define event-handlers (box '()))
;; (Boxof (Listof StageProducer))
(define assertion-maintainers (box '()))
(define (box-adjoin! v val) (set-box! v (append (unbox v) (list val))))
;; ----------------------------------------
(define (allocate-aggregate! init-stx)
(box-adjoin! aggregate-init-stxs init-stx)
(- (length (unbox aggregate-init-stxs)) 1))
;; StageProducer -> Void
(define (add-track-updater! stage-producer) (box-adjoin! track-updaters stage-producer))
(define (add-event-handler! stage-producer) (box-adjoin! event-handlers stage-producer))
(define (mapply v fs) (map (lambda (f) (f v)) fs))
(define (make-run-script-call outer-expr-stx state-stx I-stxs)
(cond
[(zero? binding-count)
#`(run-script #,state-stx (lambda ()
#,@I-stxs
(vector)))]
[(stx-null? I-stxs)
(raise-syntax-error #f "Empty expression sequence not permitted" outer-expr-stx I-stxs)]
[else
#`(run-script #,state-stx (lambda ()
(call-with-values (lambda () #,@I-stxs)
vector)))]))
(define (add-assertion-maintainer! endpoint-index
assert-stx
pat-stx
maybe-Pred-stx
L-stx)
(box-adjoin! assertion-maintainers
(lambda (evt-stx)
#`(lambda (s)
(match-define (vector #,@binding-names)
(actor-state-variables s))
(define old-assertions
(strip-interests
(mux-interests-of (actor-state-mux s) #,endpoint-index)))
(define (compute-new-assertions)
(patch-added (#,assert-stx #,pat-stx #:meta-level #,L-stx)))
(define new-assertions
#,(if maybe-Pred-stx
#`(if #,maybe-Pred-stx
(compute-new-assertions)
trie-empty)
#`(compute-new-assertions)))
(and (not (eq? old-assertions new-assertions))
((extend-pending-patch
#,endpoint-index
(patch-seq (patch trie-empty old-assertions)
(patch new-assertions trie-empty)))
s))))))
(define (analyze-asserted-or-retracted! endpoint-index asserted? outer-expr-stx P-stx I-stxs L-stx)
(define-values (proj-stx pat match-pat bindings _instantiated)
(analyze-pattern outer-expr-stx P-stx))
(add-assertion-maintainer! endpoint-index #'sub pat #f L-stx)
(add-event-handler!
(lambda (evt-stx)
#`(let* ((proj (prepend-at-meta #,proj-stx #,L-stx))
(proj-arity (projection-arity proj)))
(lambda (s)
(match #,evt-stx
[(? #,(if asserted? #'patch/added? #'patch/removed?) p)
(sequence-transitions0*
s
(for/list [(entry (in-set (trie-project/set
#:take proj-arity
#,(if asserted?
#'(patch-added p)
#'(patch-removed p))
proj)))]
(lambda (s)
(match (actor-state-variables s)
[(vector #,@binding-names)
(match-define (list #,@bindings) entry)
#,(make-run-script-call outer-expr-stx #'s I-stxs)]))))]
[_ #f]))))))
(define (prepend-at-meta-stx context-stx stx level)
(if (zero? level)
stx
#`(at-meta #,(prepend-at-meta-stx context-stx stx (- level 1)))))
(define (analyze-message-subscription! endpoint-index outer-expr-stx P-stx I-stxs L-stx)
(define-values (proj pat match-pat bindings _instantiated)
(analyze-pattern outer-expr-stx P-stx))
(add-assertion-maintainer! endpoint-index #'sub pat #f L-stx)
(add-event-handler!
(lambda (evt-stx)
#`(lambda (s)
(match (actor-state-variables s)
[(vector #,@binding-names)
(match #,evt-stx
[(message #,(prepend-at-meta-stx outer-expr-stx match-pat (syntax-e L-stx)))
#,(make-run-script-call outer-expr-stx #'s I-stxs)]
[_ #f])])))))
(define (analyze-event! index E-stx I-stxs)
(syntax-parse E-stx
#:literals [asserted retracted message rising-edge]
[(asserted P L:meta-level)
(analyze-asserted-or-retracted! index #t E-stx #'P I-stxs #'L.level)]
[(retracted P L:meta-level)
(analyze-asserted-or-retracted! index #f E-stx #'P I-stxs #'L.level)]
[(message P L:meta-level)
(analyze-message-subscription! index E-stx #'P I-stxs #'L.level)]
[(rising-edge Pred)
;; TODO: more kinds of Pred than just expr
(define aggregate-index (allocate-aggregate! #'#f))
(add-event-handler!
(lambda (evt-stx)
#`(lambda (s)
(match-define (vector #,@binding-names) (actor-state-variables s))
(define old-val (hash-ref (actor-state-aggregates s) #,aggregate-index))
(define new-val Pred)
(if (eq? old-val new-val)
#f
(let ((s (struct-copy actor-state s
[aggregates (hash-set (actor-state-aggregates s)
#,aggregate-index
new-val)])))
(if new-val
#,(make-run-script-call E-stx #'s I-stxs)
(transition s '())))))))]))
(define (analyze-during! index P-stx O-stxs)
(define E-stx #`(asserted #,P-stx))
(define-values (_proj _pat _match-pat _bindings instantiated) (analyze-pattern E-stx P-stx))
(define I-stx #`(until (retracted #,instantiated) #,@O-stxs))
(analyze-event! index E-stx #`(#,I-stx)))
(define (analyze-assertion! index Pred-stx outer-expr-stx P-stx L-stx)
(define-values (proj pat match-pat bindings _instantiated)
(analyze-pattern outer-expr-stx P-stx))
(add-assertion-maintainer! index #'core:assert pat Pred-stx L-stx))
(define (analyze-tracks! index track-spec-stxs I-stxs)
(error 'analyze-tracks! "unimplemented"))
;; Track analysis happens first, because we need the tracked
;; bindings to be in scope everywhere else.
(for [(ongoing (in-list (syntax->list ongoings)))
(ongoing-index (in-naturals))]
(syntax-parse ongoing
#:literals [track]
[(track [track-spec ...] I ...)
(analyze-tracks! ongoing-index #'(track-spec ...) #'(I ...))]
[_ (void)]))
;; Now make another pass over the ongoings, ignoring tracks this
;; time.
(for [(ongoing (in-list (syntax->list ongoings)))
(ongoing-index (in-naturals))]
(syntax-parse ongoing
#:literals [on during assert track]
[(on E I ...)
(analyze-event! ongoing-index #'E #'(I ...))]
[(during P O ...)
(analyze-during! ongoing-index #'P #'(O ...))]
[(assert w:when-pred P L:meta-level)
(analyze-assertion! ongoing-index #'w.Pred ongoing #'P #'L.level)]
[(track [track-spec ...] I ...)
(void)]))
;; Finally, add in the termination conditions...
(for [(edge (in-list (syntax->list edges)))
(edge-index (in-naturals (length (syntax->list ongoings))))]
(syntax-parse edge
[(E I0 I ...)
(analyze-event! edge-index #'E #'((call-with-values (lambda () I0 I ...) return!)))]))
;; ...and generic linkage-related behaviors.
(add-event-handler!
(lambda (evt-stx)
#`(lambda (s) (generic-actor-behavior #,evt-stx s))))
(define action-fn-stx
#`(lambda (self-id caller-id)
(<spawn>
(lambda ()
(define ((maintain-assertions e) s)
(sequence-transitions0 s #,@(mapply #'e (unbox assertion-maintainers))))
(define (behavior e s)
(and e
(sequence-transitions0 s
#,@(mapply #'e (unbox track-updaters))
#,@(mapply #'e (unbox event-handlers))
(maintain-assertions e)
perform-pending-patch)))
(define initial-state
(actor-state (hasheq)
caller-id
self-id
(vector #,@binding-inits)
(make-immutable-hash
(list
#,@(for/list [(init-stx (unbox aggregate-init-stxs))
(init-idx (in-naturals))]
#`(cons #,init-idx #,init-stx))))
#f
(mux)))
(define (subscribe-to-linkage s)
(define sub-to-callees
(patch-seq (sub (link-active self-id ?))
(sub (link-result self-id ? ?))))
(define initial-subs
#,(if (eq? linkage-kind 'call)
#`(patch-seq sub-to-callees
(core:assert (link-active caller-id self-id)))
#`sub-to-callees))
((extend-pending-patch *linkage-label* initial-subs) s))
(define (run-init-actions s)
(match (actor-state-variables s)
[(vector #,@binding-names)
;; TODO: At the moment we are *not* letting the
;; init-actions update the variables. Is this the
;; right thing?
;; TODO: what about intermediate (state)s? How are the variables updated?
(run-script s (lambda ()
#,@init-actions
(vector #,@binding-names)))]))
(list behavior
(sequence-transitions0 initial-state
subscribe-to-linkage
(maintain-assertions #f)
perform-pending-patch
run-init-actions))))))
;; (local-require racket/pretty)
;; (pretty-print (syntax->datum action-fn-stx))
#`(let ((do-spawn (lambda () (spawn! '#,linkage-kind #,action-fn-stx))))
(if (syndicate-actor-prompt-tag-installed?)
(do-spawn)
(actor-body->spawn-action do-spawn))))
)
;; ;; Given a Pred, computes (and perhaps allocates):
;; ;; - an optional StageProducer for taking on board information from the outside world
;; ;; - syntax for retrieving the current value of the Pred
;; ;; - syntax for evaluating a new value for the Pred
;; ;; - optional syntax for an updater for an aggregate
;; ;; (Syntax <Pred>) -> (Values (Option StageProducer)
;; ;; (Syntax <Expr:Boolean>)
;; ;; (Syntax <Expr:Boolean>)
;; ;; (Option (Syntax <Expr:(Any ActorState -> ActorState)>)))
;; (define (analyze-pred! Pred-stx)
;; (syntax-parse Pred-stx
;; #:literals [not or and exists]
;; [(not Pred)
;; (define-values (upd curr next store) (analyze-pred! #'Pred))
;; (values upd #`(not #,curr) #`(not ,next))]
;; [((~and HEAD (~or or and)) PredN ...)
;; (define-values (upds currs nexts) (analyze-preds! #'(PredN ...)))
;; (values (and (not (null? upds))
;; (lambda (evt-stx)
;; #`(lambda (s) (sequence-transitions0 s #,@(mapply evt-stx upds)))))
;; #`(HEAD #,@currs)
;; #`(HEAD #,@nexts))]
;; [(exists P Pred)
;; ...]
;; [expr
;; (define index (allocate-aggregate!))
;; (values #f
;; #'
;; ...]))
;; (define (analyze-preds! Pred-stxs)
;; (define-values (upds-rev currs-rev nexts-rev)
;; (for/fold [(upds-rev '())
;; (currs-rev '())
;; (nexts-rev '())]
;; [(Pred-stx (in-list (syntax->list Pred-stxs)))]
;; (define-values (upd curr next) (analyze-pred! Pred-stx))
;; (values (if upd (cons upd upds-rev) upds-rev)
;; (cons curr currs-rev)
;; (cons next nexts-rev))))
;; (values (reverse upds-rev)
;; (reverse currs-rev)
;; (reverse nexts-rev)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HLL pattern analysis
(begin-for-syntax
(define (dollar-id? stx)
(and (identifier? stx)
(char=? (string-ref (symbol->string (syntax-e stx)) 0) #\$)))
(define (undollar stx)
(and (dollar-id? stx)
(datum->syntax stx (string->symbol (substring (symbol->string (syntax-e stx)) 1)))))
;; Syntax -> (Values Projection AssertionSetPattern MatchPattern (ListOf Identifier) Syntax)
(define (analyze-pattern outer-expr-stx pat-stx0)
(let walk ((pat-stx pat-stx0))
(syntax-case pat-stx ($ ? quasiquote unquote quote)
;; Extremely limited support for quasiquoting and quoting
[(quasiquote (unquote p)) (walk #'p)]
[(quasiquote (p ...)) (walk #'(list (quasiquote p) ...))]
[(quasiquote p) (values #''p #''p #''p '() #''p)]
[(quote p) (values #''p #''p #''p '() #''p)]
[$v
(dollar-id? #'$v)
(with-syntax [(v (undollar #'$v))]
(values #'(?!)
#'?
#'v
(list #'v)
#'v))]
[($ v p)
(let ()
(define-values (pr g m bs _ins) (walk #'p))
(when (not (null? bs))
(raise-syntax-error #f "nested bindings not supported" outer-expr-stx pat-stx))
(values #`(?! #,pr)
g
#`(and v #,m)
(list #'v)
#'v))]
[(? pred? p)
;; TODO: support pred? in asserted/retracted as well as message events
(let ()
(syntax-parse outer-expr-stx
#:literals [message]
[(message _ ...) 'ok]
[_ (raise-syntax-error #f
"Predicate '?' matching only supported in message events"
outer-expr-stx
pat-stx)])
(define-values (pr g m bs ins) (walk #'p))
(values pr
g
#`(? pred? #,m)
bs
ins))]
[(ctor p ...)
(let ()
(define parts (if (identifier? #'ctor) #'(p ...) #'(ctor p ...)))
(define-values (pr g m bs ins)
(for/fold [(pr '()) (g '()) (m '()) (bs '()) (ins '())] [(p (syntax->list parts))]
(define-values (pr1 g1 m1 bs1 ins1) (walk p))
(values (cons pr1 pr)
(cons g1 g)
(cons m1 m)
(append bs bs1)
(cons ins1 ins))))
(if (identifier? #'ctor)
(values (cons #'ctor (reverse pr))
(cons #'ctor (reverse g))
(cons #'ctor (reverse m))
bs
(cons #'ctor (reverse ins)))
(values (reverse pr)
(reverse g)
(reverse m)
bs
(reverse ins))))]
[?
(raise-syntax-error #f
"Invalid use of '?' in pattern; use '_' instead"
outer-expr-stx
pat-stx)]
[non-pair
(if (and (identifier? #'non-pair)
(free-identifier=? #'non-pair #'_))
(values #'?
#'?
#'_
'()
#'_)
(values #'non-pair
#'non-pair
#'(== non-pair)
'()
#'non-pair))])))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (pretty-print-actor-state s [p (current-output-port)])
(match-define
(actor-state continuation-table caller-id self-id variables aggregates pending-patch mux)
s)
(fprintf p "ACTOR id ~a (caller-id ~a):\n" self-id caller-id)
(fprintf p " - ~a pending continuations\n" (hash-count continuation-table))
(fprintf p " - variables:\n")
(for ((v variables))
(fprintf p " - ")
(display (indented-port-output 6 (lambda (p) (syndicate-pretty-print v p)) #:first-line? #f) p)
(newline p))
(fprintf p " - aggregates:\n")
(for (((index a) (in-hash aggregates)))
(define leader (format " - ~a: " index))
(fprintf p "~a" leader)
(display (indented-port-output #:first-line? #f
(string-length leader)
(lambda (p) (syndicate-pretty-print a p)))
p)
(newline p))
(fprintf p " - pending-patch:\n")
(display (indented-port-output 3 (lambda (p) (syndicate-pretty-print pending-patch p))) p)
(newline p)
(fprintf p " - ")
(display (indented-port-output 3 (lambda (p) (syndicate-pretty-print mux p)) #:first-line? #f) p)
(newline p))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module+ test
(require racket/pretty (for-syntax racket/pretty))
(define (expand-and-print stx)
(pretty-print (syntax->datum (expand stx))))
(begin-for-syntax
(define (analyze-and-print pat-stx)
(let-values (((pr g m bs ins) (analyze-pattern pat-stx pat-stx)))
(pretty-print `((pr ,(map syntax->datum pr))
(g ,(map syntax->datum g))
(m ,(map syntax->datum m))
(bs ,(map syntax->datum bs))
(ins ,(map syntax->datum ins))))))
#;(analyze-and-print #'`(hello ,$who)))
(expand
#'(actor
(until (rising-edge (= count 10))
#:collect [(count 0)]
(during `(present ,$p)
#:collect [(utterance-count 0)]
(on (message `(says ,p ,$what))
(println "(~a) ~a says: ~a" utterance-count p what)
(+ utterance-count 1)))
(on (message `(hello ,$who))
(println "Got hello: ~a" who)
(+ count 1))))))