2015-11-23 22:33:12 +00:00
|
|
|
#lang racket/base
|
|
|
|
|
2015-12-03 21:31:36 +00:00
|
|
|
(provide actor
|
2015-12-11 17:45:15 +00:00
|
|
|
network
|
2015-11-23 22:33:12 +00:00
|
|
|
;; background
|
2015-11-25 15:42:13 +00:00
|
|
|
state
|
2015-11-23 22:33:12 +00:00
|
|
|
|
|
|
|
until
|
|
|
|
forever
|
|
|
|
|
|
|
|
assert!
|
|
|
|
retract!
|
|
|
|
send!
|
2015-12-11 02:23:32 +00:00
|
|
|
return!
|
|
|
|
return/no-link-result!
|
2015-12-11 17:52:16 +00:00
|
|
|
perform-core-action!
|
2015-11-23 22:33:12 +00:00
|
|
|
|
|
|
|
;; forall
|
|
|
|
|
2015-12-11 18:02:13 +00:00
|
|
|
actor-body->spawn-action
|
2015-12-11 02:23:32 +00:00
|
|
|
|
2015-11-23 22:33:12 +00:00
|
|
|
;;----------------------------------------
|
|
|
|
(struct-out actor-state)
|
2015-12-11 02:23:32 +00:00
|
|
|
pretty-print-actor-state
|
2016-02-02 23:05:59 +00:00
|
|
|
|
|
|
|
(for-syntax analyze-pattern)
|
2016-02-05 23:03:40 +00:00
|
|
|
syndicate-actor-prompt-tag-installed?
|
2015-11-23 22:33:12 +00:00
|
|
|
)
|
|
|
|
|
|
|
|
(require (for-syntax racket/base))
|
2015-12-09 23:59:49 +00:00
|
|
|
(require (for-syntax racket/sequence))
|
2015-11-23 22:33:12 +00:00
|
|
|
(require "support/dsl.rkt")
|
2015-12-11 02:23:32 +00:00
|
|
|
(require "pretty.rkt")
|
2015-11-23 22:33:12 +00:00
|
|
|
|
|
|
|
(define&provide-dsl-helper-syntaxes "state/until/forever form"
|
|
|
|
[on
|
2016-02-29 15:24:25 +00:00
|
|
|
during
|
2015-11-23 22:33:12 +00:00
|
|
|
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)
|
|
|
|
|
2016-01-18 19:29:48 +00:00
|
|
|
(require (except-in "core.rkt" assert network)
|
|
|
|
(rename-in "core.rkt" [assert core:assert] [network core:network]))
|
2015-11-23 22:33:12 +00:00
|
|
|
(require "route.rkt")
|
2015-12-09 01:12:27 +00:00
|
|
|
(require "mux.rkt")
|
2015-11-23 22:33:12 +00:00
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
2015-11-25 15:42:13 +00:00
|
|
|
;; Actor State
|
|
|
|
|
2015-12-09 23:59:49 +00:00
|
|
|
;; 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.
|
2015-11-25 15:42:13 +00:00
|
|
|
|
2015-12-11 07:25:17 +00:00
|
|
|
;; A Script is a (-> Variables). It is to be executed inside
|
2015-11-25 15:42:13 +00:00
|
|
|
;; the special syndicate-hll prompt, and so may have Instruction
|
|
|
|
;; side-effects.
|
|
|
|
|
|
|
|
;; An Instruction is one of
|
|
|
|
;; - (patch-instruction Patch (Void -> Instruction))
|
2015-12-09 01:12:27 +00:00
|
|
|
;; - (action-instruction Action (Void -> Instruction))
|
2015-12-11 02:23:32 +00:00
|
|
|
;; - (return-instruction (Option (Listof Any)))
|
2015-12-09 01:12:27 +00:00
|
|
|
;; - (spawn-instruction LinkageKind (Symbol Symbol -> Spawn) (Void -> Instruction))
|
2015-11-25 15:42:13 +00:00
|
|
|
;; - (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
|
2015-12-03 21:31:36 +00:00
|
|
|
;; `retract!`. Action instructions are issued when the actor uses
|
2015-12-11 17:52:16 +00:00
|
|
|
;; `perform-core-action!`, and return instructions when `return!` is
|
|
|
|
;; called. Script-complete instructions are automatically issued when
|
|
|
|
;; a Script terminates successfully.
|
2015-11-25 15:42:13 +00:00
|
|
|
;;
|
|
|
|
;; Spawn instructions are issued when `actor`, `network`, and `state`
|
|
|
|
;; are used, directly or indirectly. (TODO: `background`?) The
|
2015-12-09 01:12:27 +00:00
|
|
|
;; 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).
|
2015-11-25 15:42:13 +00:00
|
|
|
;;
|
|
|
|
;; (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)
|
2015-12-03 21:31:36 +00:00
|
|
|
(struct action-instruction (action k) #:transparent)
|
2015-12-11 02:23:32 +00:00
|
|
|
(struct return-instruction (result-values) #:transparent)
|
2015-12-09 01:12:27 +00:00
|
|
|
(struct spawn-instruction (linkage-kind action-fn k) #:transparent)
|
2015-11-25 15:42:13 +00:00
|
|
|
(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
|
2015-12-09 23:59:49 +00:00
|
|
|
aggregates ;; Aggregates
|
2015-12-09 01:12:27 +00:00
|
|
|
pending-patch ;; (Option Patch) - aggregate patch being accumulated
|
|
|
|
mux ;; Mux
|
2015-11-25 15:42:13 +00:00
|
|
|
)
|
2015-12-11 02:23:32 +00:00
|
|
|
#:transparent
|
|
|
|
#:methods gen:prospect-pretty-printable
|
|
|
|
[(define (prospect-pretty-print s [p (current-output-port)])
|
|
|
|
(pretty-print-actor-state s p))])
|
2015-11-25 15:42:13 +00:00
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; 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) #:prefab)
|
|
|
|
;;
|
|
|
|
;; 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) #:prefab) ;; message
|
|
|
|
|
|
|
|
;; Projection for observing LinkActive.
|
|
|
|
(define link-active-projection (compile-projection (link-active ? (?!))))
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Producing Instruction side-effects
|
|
|
|
|
|
|
|
(define prompt (make-continuation-prompt-tag 'syndicate-hll))
|
|
|
|
|
2016-02-05 23:03:40 +00:00
|
|
|
(define (syndicate-actor-prompt-tag-installed?)
|
|
|
|
(continuation-prompt-available? prompt))
|
|
|
|
|
2015-11-25 15:42:13 +00:00
|
|
|
;; (Any ... -> Nothing) -> (Any ... -> Instruction)
|
|
|
|
(define (reply-to k)
|
|
|
|
(lambda reply-values
|
|
|
|
(call-with-continuation-prompt (lambda ()
|
2015-12-11 02:23:32 +00:00
|
|
|
(apply k reply-values)
|
2015-12-11 03:25:03 +00:00
|
|
|
(error 'reply-to "Script returned directly"))
|
2015-11-25 15:42:13 +00:00
|
|
|
prompt)))
|
|
|
|
|
|
|
|
;; (-> Instruction) -> Nothing
|
|
|
|
(define (call-in-raw-context/abort proc)
|
|
|
|
(abort-current-continuation prompt proc))
|
|
|
|
|
|
|
|
;; ((Any ... -> Instruction) -> Instruction)
|
|
|
|
(define (call-in-raw-context proc)
|
2016-02-05 23:03:40 +00:00
|
|
|
(when (not (syndicate-actor-prompt-tag-installed?))
|
|
|
|
(error 'call-in-raw-context
|
|
|
|
"Attempt to invoke imperative Syndicate actor action outside actor context."))
|
2015-11-25 15:42:13 +00:00
|
|
|
(call-with-composable-continuation
|
|
|
|
(lambda (k) (abort-current-continuation prompt (lambda () (proc (reply-to k)))))
|
|
|
|
prompt))
|
|
|
|
|
|
|
|
;; Returns void
|
2015-12-11 02:23:32 +00:00
|
|
|
(define (assert! P #:meta-level [meta-level 0])
|
2015-11-25 15:42:13 +00:00
|
|
|
(call-in-raw-context
|
2015-12-11 02:23:32 +00:00
|
|
|
(lambda (k) (patch-instruction (core:assert P #:meta-level meta-level) k))))
|
2015-11-25 15:42:13 +00:00
|
|
|
|
|
|
|
;; Returns void
|
2015-12-11 02:23:32 +00:00
|
|
|
(define (retract! P #:meta-level [meta-level 0])
|
2015-11-25 15:42:13 +00:00
|
|
|
(call-in-raw-context
|
2015-12-11 02:23:32 +00:00
|
|
|
(lambda (k) (patch-instruction (retract P #:meta-level meta-level) k))))
|
2015-11-25 15:42:13 +00:00
|
|
|
|
|
|
|
;; Returns void
|
2015-12-11 02:23:32 +00:00
|
|
|
(define (send! M #:meta-level [meta-level 0])
|
2015-12-11 17:52:16 +00:00
|
|
|
(perform-core-action! (message (prepend-at-meta M meta-level))))
|
2015-12-03 21:31:36 +00:00
|
|
|
|
|
|
|
;; Returns void
|
2015-12-11 17:52:16 +00:00
|
|
|
(define (perform-core-action! A)
|
2015-11-25 15:42:13 +00:00
|
|
|
(call-in-raw-context
|
2015-12-03 21:31:36 +00:00
|
|
|
(lambda (k) (action-instruction A k))))
|
2015-11-25 15:42:13 +00:00
|
|
|
|
2015-12-11 02:23:32 +00:00
|
|
|
;; 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!)
|
2015-11-25 15:42:13 +00:00
|
|
|
(call-in-raw-context/abort
|
2015-12-11 02:23:32 +00:00
|
|
|
(lambda () (return-instruction #f))))
|
2015-11-23 22:33:12 +00:00
|
|
|
|
2015-11-25 15:42:13 +00:00
|
|
|
;; Returns new variables, plus values from spawned actor if any.
|
2015-12-09 01:12:27 +00:00
|
|
|
(define (spawn! linkage-kind action-fn)
|
2015-11-25 15:42:13 +00:00
|
|
|
(call-in-raw-context
|
2015-12-09 01:12:27 +00:00
|
|
|
(lambda (k) (spawn-instruction linkage-kind action-fn k))))
|
2015-11-25 15:42:13 +00:00
|
|
|
|
2015-12-11 03:24:42 +00:00
|
|
|
(begin-for-syntax
|
|
|
|
(define-splicing-syntax-class init
|
|
|
|
(pattern (~seq #:init [I ...]))
|
|
|
|
(pattern (~seq) #:attr [I 1] '()))
|
|
|
|
|
2016-02-29 15:24:25 +00:00
|
|
|
(define-splicing-syntax-class done
|
|
|
|
(pattern (~seq #:done [I ...]))
|
|
|
|
(pattern (~seq) #:attr [I 1] '()))
|
|
|
|
|
2015-12-11 03:24:42 +00:00
|
|
|
(define-splicing-syntax-class bindings
|
|
|
|
(pattern (~seq #:collect [(id init) ...]))
|
|
|
|
(pattern (~seq) #:attr [id 1] '() #:attr [init 1] '())))
|
2015-12-11 02:23:32 +00:00
|
|
|
|
2015-11-25 15:42:13 +00:00
|
|
|
;; Syntax for spawning a 'call-linked actor.
|
2015-11-23 22:33:12 +00:00
|
|
|
(define-syntax (state stx)
|
|
|
|
(syntax-parse stx
|
2015-12-11 03:24:42 +00:00
|
|
|
[(_ init:init [bs:bindings O ...] [E Oe ...] ...)
|
|
|
|
(expand-state 'call #'(init.I ...) #'(bs.id ...) #'(bs.init ...) #'(O ...) #'([E Oe ...] ...))]))
|
2015-11-23 22:33:12 +00:00
|
|
|
|
2015-11-25 15:42:13 +00:00
|
|
|
;; Sugar
|
2015-12-11 03:24:42 +00:00
|
|
|
(define-syntax (until stx)
|
|
|
|
(syntax-parse stx
|
2016-02-29 15:24:25 +00:00
|
|
|
[(_ E init:init done:done bs:bindings O ...)
|
|
|
|
#'(state #:init [init.I ...] [#:collect [(bs.id bs.init) ...] O ...] [E done.I ... (values)])]))
|
2015-11-23 22:33:12 +00:00
|
|
|
|
2015-11-25 15:42:13 +00:00
|
|
|
;; Sugar
|
2015-12-11 03:24:42 +00:00
|
|
|
(define-syntax (forever stx)
|
|
|
|
(syntax-parse stx
|
|
|
|
[(_ init:init bs:bindings O ...)
|
|
|
|
#'(state #:init [init.I ...] [#:collect [(bs.id bs.init) ...] O ...])]))
|
2015-11-23 22:33:12 +00:00
|
|
|
|
2015-12-03 21:31:36 +00:00
|
|
|
;; Spawn actors with 'actor linkage
|
|
|
|
(define-syntax (actor stx)
|
|
|
|
(syntax-parse stx
|
|
|
|
[(_ I ...)
|
2015-12-11 02:23:32 +00:00
|
|
|
(expand-state 'actor #'(I ... (return/no-link-result!)) #'() #'() #'() #'())]))
|
2015-12-03 21:31:36 +00:00
|
|
|
|
2015-12-11 17:45:15 +00:00
|
|
|
;; Spawn whole networks
|
|
|
|
(define-syntax (network stx)
|
|
|
|
(syntax-parse stx
|
|
|
|
[(_ I ...)
|
|
|
|
(expand-state 'network
|
|
|
|
#'(I
|
|
|
|
...
|
2016-01-18 19:29:48 +00:00
|
|
|
(perform-core-action! (quit-network))
|
2015-12-11 17:45:15 +00:00
|
|
|
(return/no-link-result!))
|
|
|
|
#'()
|
|
|
|
#'()
|
|
|
|
#'()
|
|
|
|
#'())]))
|
|
|
|
|
2015-11-23 22:33:12 +00:00
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
2015-11-25 15:42:13 +00:00
|
|
|
;; Main behavior of HLL actors
|
2015-11-23 22:33:12 +00:00
|
|
|
|
2015-12-09 01:12:27 +00:00
|
|
|
;; 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.
|
2015-12-03 20:55:40 +00:00
|
|
|
;; TODO: Revisit this, it is a bit ugly
|
2015-12-09 01:12:27 +00:00
|
|
|
(define *linkage-label* -2)
|
2015-12-03 20:55:40 +00:00
|
|
|
|
2015-11-25 15:42:13 +00:00
|
|
|
;; Behavior
|
|
|
|
(define (generic-actor-behavior e s)
|
2015-11-23 22:33:12 +00:00
|
|
|
(match e
|
|
|
|
[(? patch/removed? p)
|
|
|
|
(define continuation-table (actor-state-continuation-table s))
|
|
|
|
(define quit?
|
2016-01-22 02:55:41 +00:00
|
|
|
(for/or [(callee-id (trie-project/set/single (patch-removed p) link-active-projection))]
|
2015-11-25 15:42:13 +00:00
|
|
|
(hash-has-key? continuation-table callee-id)))
|
2015-11-23 22:33:12 +00:00
|
|
|
(if quit? ;; TODO: raise exception instead? Signal the cause of the quit somehow?
|
|
|
|
(quit)
|
|
|
|
#f)]
|
2016-02-20 01:09:40 +00:00
|
|
|
[(message (link-result (== (actor-state-self-id s)) callee-id reply-values))
|
2016-02-20 16:41:07 +00:00
|
|
|
;; ^ 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.
|
2015-11-25 15:42:13 +00:00
|
|
|
(invoke-stored-continuation s callee-id reply-values)]
|
2015-11-23 22:33:12 +00:00
|
|
|
[_ #f]))
|
|
|
|
|
2015-11-25 15:42:13 +00:00
|
|
|
;; ActorState Symbol (Variables Any ... -> Instruction) -> ActorState
|
|
|
|
(define (store-continuation s callee-id get-next-instr)
|
2015-11-23 22:33:12 +00:00
|
|
|
(struct-copy actor-state s
|
|
|
|
[continuation-table
|
|
|
|
(hash-set (actor-state-continuation-table s)
|
2015-11-25 15:42:13 +00:00
|
|
|
callee-id
|
2015-11-23 22:33:12 +00:00
|
|
|
get-next-instr)]))
|
|
|
|
|
2015-11-25 15:42:13 +00:00
|
|
|
;; ActorState Symbol (Listof Any) -> Transition
|
|
|
|
(define (invoke-stored-continuation s callee-id reply-values)
|
2015-11-23 22:33:12 +00:00
|
|
|
(define continuation-table (actor-state-continuation-table s))
|
2015-11-25 15:42:13 +00:00
|
|
|
(define continuation (hash-ref continuation-table callee-id #f))
|
|
|
|
(define new-table (hash-remove continuation-table callee-id))
|
2015-12-11 03:25:14 +00:00
|
|
|
;; (log-info "invoke-stored-continuation self=~a callee=~a values=~v k=~v"
|
|
|
|
;; (actor-state-self-id s)
|
|
|
|
;; callee-id
|
|
|
|
;; reply-values
|
|
|
|
;; continuation)
|
2015-11-23 22:33:12 +00:00
|
|
|
(handle-actor-syscall (transition (struct-copy actor-state s [continuation-table new-table])
|
|
|
|
'())
|
2015-12-11 17:20:50 +00:00
|
|
|
(apply continuation
|
|
|
|
(append reply-values (vector->list (actor-state-variables s))))))
|
2015-11-23 22:33:12 +00:00
|
|
|
|
2015-12-09 01:12:27 +00:00
|
|
|
;; 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])
|
|
|
|
'()))
|
|
|
|
|
2015-11-25 15:42:13 +00:00
|
|
|
;; ActorState Script -> Transition
|
2015-11-23 22:33:12 +00:00
|
|
|
(define (run-script s script)
|
|
|
|
(handle-actor-syscall (transition s '())
|
|
|
|
((reply-to (lambda (dummy)
|
2015-12-11 07:25:17 +00:00
|
|
|
(define new-variables (script))
|
2015-11-25 15:42:13 +00:00
|
|
|
(call-in-raw-context/abort
|
|
|
|
(lambda ()
|
|
|
|
(script-complete-instruction new-variables)))))
|
2015-11-23 22:33:12 +00:00
|
|
|
(void))))
|
|
|
|
|
2015-12-11 18:02:13 +00:00
|
|
|
(define (actor-body->spawn-action thunk)
|
2015-12-11 02:23:32 +00:00
|
|
|
(match ((reply-to (lambda (dummy)
|
2015-12-11 18:02:13 +00:00
|
|
|
(actor (thunk))
|
2015-12-11 02:23:32 +00:00
|
|
|
(error '%%boot "Reached end of boot thunk")))
|
|
|
|
(void))
|
|
|
|
[(spawn-instruction 'actor action-fn _get-next-instr)
|
|
|
|
(action-fn (gensym 'root-actor) (gensym 'boot-actor))]))
|
|
|
|
|
2015-11-25 15:42:13 +00:00
|
|
|
;; Transition Instruction -> Transition
|
2015-11-23 22:33:12 +00:00
|
|
|
(define (handle-actor-syscall t instr)
|
|
|
|
(match instr
|
|
|
|
[(patch-instruction p get-next-instr)
|
2015-12-09 01:12:27 +00:00
|
|
|
(handle-actor-syscall (sequence-transitions t
|
|
|
|
(extend-pending-patch *adhoc-label* p))
|
2015-11-23 22:33:12 +00:00
|
|
|
(get-next-instr (void)))]
|
2015-12-03 21:31:36 +00:00
|
|
|
[(action-instruction a get-next-instr)
|
2015-12-09 01:12:27 +00:00
|
|
|
(handle-actor-syscall (sequence-transitions t
|
|
|
|
perform-pending-patch
|
|
|
|
(lambda (s) (transition s a)))
|
2015-11-23 22:33:12 +00:00
|
|
|
(get-next-instr (void)))]
|
2015-12-11 02:23:32 +00:00
|
|
|
[(return-instruction result-values)
|
2015-12-09 01:12:27 +00:00
|
|
|
(sequence-transitions t
|
|
|
|
perform-pending-patch
|
2015-12-11 02:23:32 +00:00
|
|
|
(lambda (s)
|
|
|
|
(if result-values
|
|
|
|
(quit (message (link-result (actor-state-caller-id s)
|
|
|
|
(actor-state-self-id s)
|
|
|
|
result-values)))
|
|
|
|
(quit))))]
|
2015-12-09 01:12:27 +00:00
|
|
|
[(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)
|
2015-12-11 02:23:32 +00:00
|
|
|
(define callee-id (gensym linkage-kind))
|
2015-12-11 17:45:15 +00:00
|
|
|
(define spawn-action (action-fn callee-id (actor-state-self-id s)))
|
2015-12-09 01:12:27 +00:00
|
|
|
(transition (if blocking?
|
|
|
|
(store-continuation s callee-id get-next-instr)
|
|
|
|
s)
|
2015-12-11 17:45:15 +00:00
|
|
|
(if (eq? linkage-kind 'network)
|
2016-01-18 19:29:48 +00:00
|
|
|
(spawn-network spawn-action)
|
2015-12-11 17:45:15 +00:00
|
|
|
spawn-action)))))
|
2015-12-09 01:12:27 +00:00
|
|
|
(if blocking?
|
|
|
|
next-t
|
|
|
|
(handle-actor-syscall next-t (get-next-instr (void))))]
|
2015-11-23 22:33:12 +00:00
|
|
|
[(script-complete-instruction new-variables)
|
2015-12-09 01:12:27 +00:00
|
|
|
(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])
|
|
|
|
'())))]))
|
2015-11-23 22:33:12 +00:00
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
2015-11-25 15:42:13 +00:00
|
|
|
;; Compilation of HLL actors
|
2015-11-23 22:33:12 +00:00
|
|
|
|
2015-12-11 02:23:32 +00:00
|
|
|
;; TODO: track
|
|
|
|
;; TODO: default to hll
|
2015-12-17 22:45:01 +00:00
|
|
|
;; TODO: some better means of keeping track of nested network levels
|
2015-12-11 02:23:32 +00:00
|
|
|
|
2015-11-23 22:33:12 +00:00
|
|
|
(begin-for-syntax
|
2015-12-11 03:24:42 +00:00
|
|
|
(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))
|
|
|
|
(pattern (~seq) #:attr level #'0))
|
|
|
|
|
2015-11-25 15:42:13 +00:00
|
|
|
(define (expand-state linkage-kind init-actions binding-names binding-inits ongoings edges)
|
2015-12-09 03:18:36 +00:00
|
|
|
;; ----------------------------------------
|
2015-12-09 23:59:49 +00:00
|
|
|
(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 '()))
|
2015-11-23 22:33:12 +00:00
|
|
|
|
2015-12-09 03:18:36 +00:00
|
|
|
(define (box-adjoin! v val) (set-box! v (append (unbox v) (list val))))
|
|
|
|
;; ----------------------------------------
|
2015-11-23 22:33:12 +00:00
|
|
|
|
2015-12-09 23:59:49 +00:00
|
|
|
(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))
|
|
|
|
|
2015-12-11 07:25:17 +00:00
|
|
|
(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)))]))
|
2015-12-09 23:59:49 +00:00
|
|
|
|
|
|
|
(define (add-assertion-maintainer! endpoint-index
|
|
|
|
assert-stx
|
|
|
|
pat-stx
|
2015-12-11 02:23:32 +00:00
|
|
|
maybe-Pred-stx
|
|
|
|
L-stx)
|
2015-12-09 23:59:49 +00:00
|
|
|
(box-adjoin! assertion-maintainers
|
|
|
|
(lambda (evt-stx)
|
|
|
|
#`(lambda (s)
|
2015-12-11 04:55:34 +00:00
|
|
|
(match-define (vector #,@binding-names)
|
|
|
|
(actor-state-variables s))
|
2015-12-09 23:59:49 +00:00
|
|
|
(define old-assertions
|
2015-12-11 04:36:32 +00:00
|
|
|
(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)))
|
2015-12-09 23:59:49 +00:00
|
|
|
(define new-assertions
|
|
|
|
#,(if maybe-Pred-stx
|
|
|
|
#`(if #,maybe-Pred-stx
|
2015-12-11 04:36:32 +00:00
|
|
|
(compute-new-assertions)
|
2016-01-22 02:55:41 +00:00
|
|
|
(trie-empty))
|
2015-12-11 04:36:32 +00:00
|
|
|
#`(compute-new-assertions)))
|
2015-12-09 23:59:49 +00:00
|
|
|
(and (not (eq? old-assertions new-assertions))
|
2015-12-11 02:23:32 +00:00
|
|
|
((extend-pending-patch
|
|
|
|
#,endpoint-index
|
2016-01-22 02:55:41 +00:00
|
|
|
(patch-seq (patch (trie-empty) old-assertions)
|
|
|
|
(patch new-assertions (trie-empty))))
|
2015-12-11 04:36:32 +00:00
|
|
|
s))))))
|
2015-12-09 23:59:49 +00:00
|
|
|
|
2015-12-11 07:24:20 +00:00
|
|
|
(define (analyze-asserted-or-retracted! endpoint-index asserted? outer-expr-stx P-stx I-stxs L-stx)
|
2016-02-29 15:24:25 +00:00
|
|
|
(define-values (proj-stx pat match-pat bindings _instantiated)
|
|
|
|
(analyze-pattern outer-expr-stx P-stx))
|
2015-12-11 04:36:32 +00:00
|
|
|
(add-assertion-maintainer! endpoint-index #'sub pat #f L-stx)
|
2015-12-09 23:59:49 +00:00
|
|
|
(add-event-handler!
|
|
|
|
(lambda (evt-stx)
|
2015-12-11 02:23:32 +00:00
|
|
|
#`(let ((proj (compile-projection (prepend-at-meta #,proj-stx #,L-stx))))
|
2015-12-09 23:59:49 +00:00
|
|
|
(lambda (s)
|
|
|
|
(match #,evt-stx
|
|
|
|
[(? #,(if asserted? #'patch/added? #'patch/removed?) p)
|
|
|
|
(sequence-transitions0*
|
|
|
|
s
|
2016-01-22 02:55:41 +00:00
|
|
|
(for/list [(entry (in-set (trie-project/set
|
2015-12-09 23:59:49 +00:00
|
|
|
#,(if asserted?
|
|
|
|
#'(patch-added p)
|
|
|
|
#'(patch-removed p))
|
|
|
|
proj)))]
|
2015-12-11 07:25:17 +00:00
|
|
|
(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)]))))]
|
2015-12-09 23:59:49 +00:00
|
|
|
[_ #f]))))))
|
2015-12-09 03:18:36 +00:00
|
|
|
|
2015-12-11 02:23:32 +00:00
|
|
|
(define (prepend-at-meta-stx stx level)
|
|
|
|
(if (zero? level)
|
|
|
|
stx
|
|
|
|
#`(at-meta #,(prepend-at-meta-stx stx (- level 1)))))
|
|
|
|
|
2015-12-11 07:24:20 +00:00
|
|
|
(define (analyze-message-subscription! endpoint-index outer-expr-stx P-stx I-stxs L-stx)
|
2016-02-29 15:24:25 +00:00
|
|
|
(define-values (proj pat match-pat bindings _instantiated)
|
|
|
|
(analyze-pattern outer-expr-stx P-stx))
|
2015-12-11 04:36:32 +00:00
|
|
|
(add-assertion-maintainer! endpoint-index #'sub pat #f L-stx)
|
2015-12-11 02:23:32 +00:00
|
|
|
(add-event-handler!
|
|
|
|
(lambda (evt-stx)
|
|
|
|
#`(lambda (s)
|
2015-12-11 07:25:17 +00:00
|
|
|
(match (actor-state-variables s)
|
|
|
|
[(vector #,@binding-names)
|
|
|
|
(match #,evt-stx
|
|
|
|
[(message #,(prepend-at-meta-stx match-pat (syntax-e L-stx)))
|
|
|
|
#,(make-run-script-call outer-expr-stx #'s I-stxs)]
|
|
|
|
[_ #f])])))))
|
2015-12-11 02:23:32 +00:00
|
|
|
|
2015-12-09 03:18:36 +00:00
|
|
|
(define (analyze-event! index E-stx I-stxs)
|
2015-12-09 23:59:49 +00:00
|
|
|
(syntax-parse E-stx
|
|
|
|
#:literals [asserted retracted message rising-edge]
|
2015-12-11 07:24:20 +00:00
|
|
|
[(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)]
|
2015-12-09 23:59:49 +00:00
|
|
|
[(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)
|
2015-12-11 07:25:17 +00:00
|
|
|
(match-define (vector #,@binding-names) (actor-state-variables s))
|
2015-12-09 23:59:49 +00:00
|
|
|
(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
|
2015-12-11 07:25:17 +00:00
|
|
|
#,(make-run-script-call E-stx #'s I-stxs)
|
2015-12-09 23:59:49 +00:00
|
|
|
(transition s '())))))))]))
|
2015-12-09 03:18:36 +00:00
|
|
|
|
2016-02-29 15:24:25 +00:00
|
|
|
(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)))
|
|
|
|
|
2015-12-11 07:24:20 +00:00
|
|
|
(define (analyze-assertion! index Pred-stx outer-expr-stx P-stx L-stx)
|
2016-02-29 15:24:25 +00:00
|
|
|
(define-values (proj pat match-pat bindings _instantiated)
|
|
|
|
(analyze-pattern outer-expr-stx P-stx))
|
2015-12-11 04:36:32 +00:00
|
|
|
(add-assertion-maintainer! index #'core:assert pat Pred-stx L-stx))
|
2015-12-09 03:18:36 +00:00
|
|
|
|
|
|
|
(define (analyze-tracks! index track-spec-stxs I-stxs)
|
2015-12-09 23:59:49 +00:00
|
|
|
(error 'analyze-tracks! "unimplemented"))
|
2015-12-09 03:18:36 +00:00
|
|
|
|
2015-12-09 23:59:49 +00:00
|
|
|
;; 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.
|
2015-12-09 03:18:36 +00:00
|
|
|
(for [(ongoing (in-list (syntax->list ongoings)))
|
|
|
|
(ongoing-index (in-naturals))]
|
|
|
|
(syntax-parse ongoing
|
2016-02-29 15:24:25 +00:00
|
|
|
#:literals [on during assert track]
|
2015-12-09 03:18:36 +00:00
|
|
|
[(on E I ...)
|
|
|
|
(analyze-event! ongoing-index #'E #'(I ...))]
|
2016-02-29 15:24:25 +00:00
|
|
|
[(during P O ...)
|
|
|
|
(analyze-during! ongoing-index #'P #'(O ...))]
|
2015-12-11 03:24:42 +00:00
|
|
|
[(assert w:when-pred P L:meta-level)
|
2015-12-11 07:24:20 +00:00
|
|
|
(analyze-assertion! ongoing-index #'w.Pred ongoing #'P #'L.level)]
|
2015-12-09 03:18:36 +00:00
|
|
|
[(track [track-spec ...] I ...)
|
2015-12-09 23:59:49 +00:00
|
|
|
(void)]))
|
2015-12-09 03:18:36 +00:00
|
|
|
|
2015-12-09 23:59:49 +00:00
|
|
|
;; Finally, add in the termination conditions...
|
2015-12-09 03:18:36 +00:00
|
|
|
(for [(edge (in-list (syntax->list edges)))
|
|
|
|
(edge-index (in-naturals (length (syntax->list ongoings))))]
|
|
|
|
(syntax-parse edge
|
2016-01-17 02:59:30 +00:00
|
|
|
[(E I0 I ...)
|
|
|
|
(analyze-event! edge-index #'E #'((call-with-values (lambda () I0 I ...) return!)))]))
|
2015-12-09 23:59:49 +00:00
|
|
|
|
|
|
|
;; ...and generic linkage-related behaviors.
|
|
|
|
(add-event-handler!
|
|
|
|
(lambda (evt-stx)
|
|
|
|
#`(lambda (s) (generic-actor-behavior #,evt-stx s))))
|
2015-11-23 22:33:12 +00:00
|
|
|
|
2015-12-09 01:12:27 +00:00
|
|
|
(define action-fn-stx
|
|
|
|
#`(lambda (self-id caller-id)
|
|
|
|
(<spawn>
|
|
|
|
(lambda ()
|
2015-12-09 23:59:49 +00:00
|
|
|
(define ((maintain-assertions e) s)
|
|
|
|
(sequence-transitions0 s #,@(mapply #'e (unbox assertion-maintainers))))
|
2015-12-09 01:12:27 +00:00
|
|
|
|
|
|
|
(define (behavior e s)
|
2015-12-09 23:59:49 +00:00
|
|
|
(and e
|
|
|
|
(sequence-transitions0 s
|
|
|
|
#,@(mapply #'e (unbox track-updaters))
|
|
|
|
#,@(mapply #'e (unbox event-handlers))
|
2015-12-11 04:55:34 +00:00
|
|
|
(maintain-assertions e)
|
|
|
|
perform-pending-patch)))
|
2015-12-09 01:12:27 +00:00
|
|
|
|
|
|
|
(define initial-state
|
|
|
|
(actor-state (hasheq)
|
|
|
|
caller-id
|
|
|
|
self-id
|
2015-12-09 23:59:49 +00:00
|
|
|
(vector #,@binding-inits)
|
|
|
|
(make-immutable-hash
|
|
|
|
(list
|
|
|
|
#,@(for/list [(init-stx (unbox aggregate-init-stxs))
|
|
|
|
(init-idx (in-naturals))]
|
|
|
|
#`(cons #,init-idx #,init-stx))))
|
2015-12-09 01:12:27 +00:00
|
|
|
#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
|
2015-12-11 02:23:32 +00:00
|
|
|
(core:assert (link-active caller-id self-id)))
|
2015-12-09 01:12:27 +00:00
|
|
|
#`sub-to-callees))
|
2015-12-09 03:18:36 +00:00
|
|
|
((extend-pending-patch *linkage-label* initial-subs) s))
|
2015-12-09 01:12:27 +00:00
|
|
|
|
|
|
|
(define (run-init-actions s)
|
2015-12-11 07:25:17 +00:00
|
|
|
(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)))]))
|
2015-12-09 01:12:27 +00:00
|
|
|
|
|
|
|
(list behavior
|
2015-12-09 23:59:49 +00:00
|
|
|
(sequence-transitions0 initial-state
|
|
|
|
subscribe-to-linkage
|
|
|
|
(maintain-assertions #f)
|
|
|
|
perform-pending-patch
|
|
|
|
run-init-actions))))))
|
|
|
|
|
2015-12-15 02:05:28 +00:00
|
|
|
;; (local-require racket/pretty)
|
|
|
|
;; (pretty-print (syntax->datum action-fn-stx))
|
2015-12-09 01:12:27 +00:00
|
|
|
|
2016-02-05 23:03:40 +00:00
|
|
|
#`(let ((do-spawn (lambda () (spawn! '#,linkage-kind #,action-fn-stx))))
|
|
|
|
(if (syndicate-actor-prompt-tag-installed?)
|
|
|
|
(do-spawn)
|
|
|
|
(actor-body->spawn-action do-spawn))))
|
2015-11-23 22:33:12 +00:00
|
|
|
)
|
|
|
|
|
2015-12-09 23:59:49 +00:00
|
|
|
;; ;; 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)))
|
|
|
|
|
2015-11-23 22:33:12 +00:00
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
2015-11-25 15:42:13 +00:00
|
|
|
;; HLL pattern analysis
|
2015-11-23 22:33:12 +00:00
|
|
|
|
|
|
|
(begin-for-syntax
|
|
|
|
(define (dollar-id? stx)
|
|
|
|
(and (identifier? stx)
|
|
|
|
(char=? (string-ref (symbol->string (syntax-e stx)) 0) #\$)))
|
|
|
|
|
2016-02-28 02:13:37 +00:00
|
|
|
(define (undollar stx)
|
2015-11-23 22:33:12 +00:00
|
|
|
(and (dollar-id? stx)
|
2016-02-28 02:13:37 +00:00
|
|
|
(datum->syntax stx (string->symbol (substring (symbol->string (syntax-e stx)) 1)))))
|
2015-11-23 22:33:12 +00:00
|
|
|
|
2016-02-29 15:24:25 +00:00
|
|
|
;; Syntax -> (Values Projection AssertionSetPattern MatchPattern (ListOf Identifier) Syntax)
|
2015-12-11 07:24:20 +00:00
|
|
|
(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) ...))]
|
2016-02-29 15:24:25 +00:00
|
|
|
[(quasiquote p) (values #''p #''p #''p '() #''p)]
|
|
|
|
[(quote p) (values #''p #''p #''p '() #''p)]
|
2015-12-11 07:24:20 +00:00
|
|
|
|
|
|
|
[$v
|
|
|
|
(dollar-id? #'$v)
|
2016-02-28 02:13:37 +00:00
|
|
|
(with-syntax [(v (undollar #'$v))]
|
2015-12-11 07:24:20 +00:00
|
|
|
(values #'(?!)
|
2015-11-23 22:33:12 +00:00
|
|
|
#'?
|
2015-12-11 07:24:20 +00:00
|
|
|
#'v
|
2016-02-29 15:24:25 +00:00
|
|
|
(list #'v)
|
|
|
|
#'v))]
|
2015-12-11 07:24:20 +00:00
|
|
|
|
|
|
|
[($ v p)
|
|
|
|
(let ()
|
2016-02-29 15:24:25 +00:00
|
|
|
(define-values (pr g m bs _ins) (walk #'p))
|
2015-12-11 07:24:20 +00:00
|
|
|
(when (not (null? bs))
|
|
|
|
(raise-syntax-error #f "nested bindings not supported" outer-expr-stx pat-stx))
|
|
|
|
(values #`(?! #,pr)
|
|
|
|
g
|
|
|
|
#`(and v #,m)
|
2016-02-29 15:24:25 +00:00
|
|
|
(list #'v)
|
|
|
|
#'v))]
|
2015-12-11 07:24:20 +00:00
|
|
|
|
|
|
|
[(? 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)])
|
2016-02-29 15:24:25 +00:00
|
|
|
(define-values (pr g m bs ins) (walk #'p))
|
2015-12-11 07:24:20 +00:00
|
|
|
(values pr
|
|
|
|
g
|
|
|
|
#`(? pred? #,m)
|
2016-02-29 15:24:25 +00:00
|
|
|
bs
|
|
|
|
ins))]
|
2015-12-11 07:24:20 +00:00
|
|
|
|
|
|
|
[(ctor p ...)
|
|
|
|
(let ()
|
|
|
|
(define parts (if (identifier? #'ctor) #'(p ...) #'(ctor p ...)))
|
2016-02-29 15:24:25 +00:00
|
|
|
(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))
|
2015-12-11 07:24:20 +00:00
|
|
|
(values (cons pr1 pr)
|
|
|
|
(cons g1 g)
|
|
|
|
(cons m1 m)
|
2016-02-29 15:24:25 +00:00
|
|
|
(append bs bs1)
|
|
|
|
(cons ins1 ins))))
|
2015-12-11 07:24:20 +00:00
|
|
|
(if (identifier? #'ctor)
|
|
|
|
(values (cons #'ctor (reverse pr))
|
|
|
|
(cons #'ctor (reverse g))
|
|
|
|
(cons #'ctor (reverse m))
|
2016-02-29 15:24:25 +00:00
|
|
|
bs
|
|
|
|
(cons #'ctor (reverse ins)))
|
2015-12-11 07:24:20 +00:00
|
|
|
(values (reverse pr)
|
|
|
|
(reverse g)
|
|
|
|
(reverse m)
|
2016-02-29 15:24:25 +00:00
|
|
|
bs
|
|
|
|
(reverse ins))))]
|
2015-12-11 07:24:20 +00:00
|
|
|
|
|
|
|
[?
|
|
|
|
(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 #'?
|
|
|
|
#'?
|
|
|
|
#'_
|
2016-02-29 15:24:25 +00:00
|
|
|
'()
|
|
|
|
#'_)
|
2015-12-11 07:24:20 +00:00
|
|
|
(values #'non-pair
|
|
|
|
#'non-pair
|
|
|
|
#'(== non-pair)
|
2016-02-29 15:24:25 +00:00
|
|
|
'()
|
|
|
|
#'non-pair))])))
|
2015-11-23 22:33:12 +00:00
|
|
|
|
|
|
|
)
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
2015-12-11 02:23:32 +00:00
|
|
|
(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) (prospect-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) (prospect-pretty-print a p)))
|
|
|
|
p)
|
|
|
|
(newline p))
|
|
|
|
(fprintf p " - pending-patch:\n")
|
|
|
|
(display (indented-port-output 3 (lambda (p) (prospect-pretty-print pending-patch p))) p)
|
|
|
|
(newline p)
|
|
|
|
(fprintf p " - ")
|
|
|
|
(display (indented-port-output 3 (lambda (p) (prospect-pretty-print mux p)) #:first-line? #f) p)
|
|
|
|
(newline p))
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
2015-11-23 22:33:12 +00:00
|
|
|
(module+ test
|
|
|
|
(require racket/pretty (for-syntax racket/pretty))
|
|
|
|
|
|
|
|
(define (expand-and-print stx)
|
2015-12-09 23:59:49 +00:00
|
|
|
(pretty-print (syntax->datum (expand stx))))
|
2015-11-23 22:33:12 +00:00
|
|
|
|
|
|
|
(begin-for-syntax
|
|
|
|
(define (analyze-and-print pat-stx)
|
2016-02-29 15:24:25 +00:00
|
|
|
(let-values (((pr g m bs ins) (analyze-pattern pat-stx pat-stx)))
|
2015-11-23 22:33:12 +00:00
|
|
|
(pretty-print `((pr ,(map syntax->datum pr))
|
|
|
|
(g ,(map syntax->datum g))
|
|
|
|
(m ,(map syntax->datum m))
|
2016-02-29 15:24:25 +00:00
|
|
|
(bs ,(map syntax->datum bs))
|
|
|
|
(ins ,(map syntax->datum ins))))))
|
2015-11-23 22:33:12 +00:00
|
|
|
|
2015-12-09 23:59:49 +00:00
|
|
|
#;(analyze-and-print #'`(hello ,$who)))
|
2015-11-23 22:33:12 +00:00
|
|
|
|
2015-12-09 23:59:49 +00:00
|
|
|
(expand
|
2015-11-23 22:33:12 +00:00
|
|
|
#'(actor
|
2015-12-04 01:49:11 +00:00
|
|
|
(until (rising-edge (= count 10))
|
2015-11-23 22:33:12 +00:00
|
|
|
#:collect [(count 0)]
|
2016-02-29 15:24:25 +00:00
|
|
|
(during `(present ,$p)
|
|
|
|
#:collect [(utterance-count 0)]
|
|
|
|
(on (message `(says ,p ,$what))
|
|
|
|
(println "(~a) ~a says: ~a" utterance-count p what)
|
|
|
|
(+ utterance-count 1)))
|
2015-11-23 22:33:12 +00:00
|
|
|
(on (message `(hello ,$who))
|
|
|
|
(println "Got hello: ~a" who)
|
|
|
|
(+ count 1))))))
|