More progress toward compilation of state forms
This commit is contained in:
parent
c05393aa2e
commit
4876a60f93
|
@ -61,7 +61,7 @@
|
||||||
;; An Instruction is one of
|
;; An Instruction is one of
|
||||||
;; - (patch-instruction Patch (Void -> Instruction))
|
;; - (patch-instruction Patch (Void -> Instruction))
|
||||||
;; - (action-instruction Action (Void -> Instruction))
|
;; - (action-instruction Action (Void -> Instruction))
|
||||||
;; - (quit-instruction (Option Exn))
|
;; - (quit-instruction (Option Exn) (Listof Any))
|
||||||
;; - (spawn-instruction LinkageKind (Symbol Symbol -> Spawn) (Void -> Instruction))
|
;; - (spawn-instruction LinkageKind (Symbol Symbol -> Spawn) (Void -> Instruction))
|
||||||
;; - (script-complete-instruction Variables)
|
;; - (script-complete-instruction Variables)
|
||||||
;; and represents a side-effect for an actor to take in its
|
;; and represents a side-effect for an actor to take in its
|
||||||
|
@ -92,7 +92,7 @@
|
||||||
;;
|
;;
|
||||||
(struct patch-instruction (patch k) #:transparent)
|
(struct patch-instruction (patch k) #:transparent)
|
||||||
(struct action-instruction (action k) #:transparent)
|
(struct action-instruction (action k) #:transparent)
|
||||||
(struct quit-instruction (maybe-exn) #:transparent)
|
(struct quit-instruction (maybe-exn result-values) #:transparent)
|
||||||
(struct spawn-instruction (linkage-kind action-fn k) #:transparent)
|
(struct spawn-instruction (linkage-kind action-fn k) #:transparent)
|
||||||
(struct script-complete-instruction (variables) #:transparent)
|
(struct script-complete-instruction (variables) #:transparent)
|
||||||
|
|
||||||
|
@ -148,7 +148,7 @@
|
||||||
(with-handlers [((lambda (e) #t)
|
(with-handlers [((lambda (e) #t)
|
||||||
(lambda (exn)
|
(lambda (exn)
|
||||||
(call-in-raw-context/abort
|
(call-in-raw-context/abort
|
||||||
(lambda () (quit-instruction exn)))))]
|
(lambda () (quit-instruction exn '())))))]
|
||||||
(apply k reply-values)
|
(apply k reply-values)
|
||||||
(error 'reply-to "Script returned directly")))
|
(error 'reply-to "Script returned directly")))
|
||||||
prompt)))
|
prompt)))
|
||||||
|
@ -182,9 +182,9 @@
|
||||||
(lambda (k) (action-instruction A k))))
|
(lambda (k) (action-instruction A k))))
|
||||||
|
|
||||||
;; Does not return
|
;; Does not return
|
||||||
(define (quit! [maybe-exn #f])
|
(define (quit! #:exception [maybe-exn #f] . result-values)
|
||||||
(call-in-raw-context/abort
|
(call-in-raw-context/abort
|
||||||
(lambda () (quit-instruction maybe-exn))))
|
(lambda () (quit-instruction maybe-exn result-values))))
|
||||||
|
|
||||||
;; Returns new variables, plus values from spawned actor if any.
|
;; Returns new variables, plus values from spawned actor if any.
|
||||||
(define (spawn! linkage-kind action-fn)
|
(define (spawn! linkage-kind action-fn)
|
||||||
|
@ -309,7 +309,8 @@
|
||||||
perform-pending-patch
|
perform-pending-patch
|
||||||
(lambda (s) (transition s a)))
|
(lambda (s) (transition s a)))
|
||||||
(get-next-instr (void)))]
|
(get-next-instr (void)))]
|
||||||
[(quit-instruction maybe-exn)
|
[(quit-instruction maybe-exn result-values)
|
||||||
|
(log-error "Ignoring result-values: ~v" result-values)
|
||||||
(sequence-transitions t
|
(sequence-transitions t
|
||||||
perform-pending-patch
|
perform-pending-patch
|
||||||
(lambda (s) (quit #:exception maybe-exn)))]
|
(lambda (s) (quit #:exception maybe-exn)))]
|
||||||
|
@ -343,23 +344,55 @@
|
||||||
|
|
||||||
(begin-for-syntax
|
(begin-for-syntax
|
||||||
(define (expand-state linkage-kind init-actions binding-names binding-inits ongoings edges)
|
(define (expand-state linkage-kind init-actions binding-names binding-inits ongoings edges)
|
||||||
(define state-variable-init-exps binding-inits)
|
;; ----------------------------------------
|
||||||
|
(define state-variable-init-exps (box binding-inits))
|
||||||
|
(define track-update-stxs (box '()))
|
||||||
|
(define event-handler-stxs (box '())) ;; to include termination checks
|
||||||
|
(define maintain-assertions-stxs (box '()))
|
||||||
|
|
||||||
|
(define (box-adjoin! v val) (set-box! v (append (unbox v) (list val))))
|
||||||
|
;; ----------------------------------------
|
||||||
|
|
||||||
(define (allocate-state-variable! init-exp)
|
(define (allocate-state-variable! init-exp)
|
||||||
(set! state-variable-init-exps
|
(box-adjoin! state-variable-init-exps init-exp)
|
||||||
(append state-variable-init-exps (list init-exp)))
|
(- (length (unbox state-variable-init-exps)) 1))
|
||||||
(- (length state-variable-init-exps) 1))
|
|
||||||
|
|
||||||
(for ((edge (syntax->list edges)))
|
(define (analyze-event! index E-stx I-stxs)
|
||||||
(printf "~v\n" (syntax->datum edge)))
|
(printf "event ~v ~v\n" E-stx (syntax->datum I-stxs)))
|
||||||
|
|
||||||
|
(define (analyze-assertion! index Pred-stx P-stx)
|
||||||
|
(printf "assert ~v ~v\n" Pred-stx P-stx))
|
||||||
|
|
||||||
|
(define (analyze-tracks! index track-spec-stxs I-stxs)
|
||||||
|
(printf "tracks ~v ~v\n" track-spec-stxs I-stxs))
|
||||||
|
|
||||||
|
(for [(ongoing (in-list (syntax->list ongoings)))
|
||||||
|
(ongoing-index (in-naturals))]
|
||||||
|
(syntax-parse ongoing
|
||||||
|
#:literals [on assert track]
|
||||||
|
[(on E I ...)
|
||||||
|
(analyze-event! ongoing-index #'E #'(I ...))]
|
||||||
|
[(assert #:when Pred P)
|
||||||
|
(analyze-assertion! ongoing-index #'Pred #'P)]
|
||||||
|
[(assert P)
|
||||||
|
(analyze-assertion! ongoing-index #'#t #'P)]
|
||||||
|
[(track [track-spec ...] I ...)
|
||||||
|
(analyze-tracks! ongoing-index #'(track-spec ...) #'(I ...))]))
|
||||||
|
|
||||||
|
(for [(edge (in-list (syntax->list edges)))
|
||||||
|
(edge-index (in-naturals (length (syntax->list ongoings))))]
|
||||||
|
(syntax-parse edge
|
||||||
|
[(E I ...)
|
||||||
|
(analyze-event! edge-index #'E #'((call-with-values (lambda () (I ...)) quit!)))]))
|
||||||
|
|
||||||
(define action-fn-stx
|
(define action-fn-stx
|
||||||
#`(lambda (self-id caller-id)
|
#`(lambda (self-id caller-id)
|
||||||
(<spawn>
|
(<spawn>
|
||||||
(lambda ()
|
(lambda ()
|
||||||
;; ActorState -> Transition
|
;; ActorState -> Transition
|
||||||
(define (update-ongoing-interests s)
|
(define (maintain-assertions s)
|
||||||
blah blah)
|
(log-error "TODO: maintain-assertions")
|
||||||
|
(transition s '()))
|
||||||
|
|
||||||
(define (behavior e s)
|
(define (behavior e s)
|
||||||
(log-error "TODO: event handling"))
|
(log-error "TODO: event handling"))
|
||||||
|
@ -368,7 +401,7 @@
|
||||||
(actor-state (hasheq)
|
(actor-state (hasheq)
|
||||||
caller-id
|
caller-id
|
||||||
self-id
|
self-id
|
||||||
(vector #,@state-variable-init-exps)
|
(vector #,@(unbox state-variable-init-exps))
|
||||||
#f
|
#f
|
||||||
(mux)))
|
(mux)))
|
||||||
|
|
||||||
|
@ -381,7 +414,7 @@
|
||||||
#`(patch-seq sub-to-callees
|
#`(patch-seq sub-to-callees
|
||||||
(assert (link-active caller-id self-id)))
|
(assert (link-active caller-id self-id)))
|
||||||
#`sub-to-callees))
|
#`sub-to-callees))
|
||||||
(transition s initial-subs))
|
((extend-pending-patch *linkage-label* initial-subs) s))
|
||||||
|
|
||||||
(define (run-init-actions s)
|
(define (run-init-actions s)
|
||||||
(run-script s (lambda (vs)
|
(run-script s (lambda (vs)
|
||||||
|
@ -391,7 +424,9 @@
|
||||||
(list behavior
|
(list behavior
|
||||||
(sequence-transitions (transition initial-state '())
|
(sequence-transitions (transition initial-state '())
|
||||||
subscribe-to-linkage
|
subscribe-to-linkage
|
||||||
run-init-actions))))))
|
run-init-actions
|
||||||
|
maintain-assertions
|
||||||
|
perform-pending-patch))))))
|
||||||
|
|
||||||
#`(spawn! '#,linkage-kind #,action-fn-stx))
|
#`(spawn! '#,linkage-kind #,action-fn-stx))
|
||||||
)
|
)
|
||||||
|
@ -475,7 +510,7 @@
|
||||||
(require racket/pretty (for-syntax racket/pretty))
|
(require racket/pretty (for-syntax racket/pretty))
|
||||||
|
|
||||||
(define (expand-and-print stx)
|
(define (expand-and-print stx)
|
||||||
(pretty-print (syntax->datum (expand stx))))
|
(values #;pretty-print (syntax->datum (expand stx))))
|
||||||
|
|
||||||
(begin-for-syntax
|
(begin-for-syntax
|
||||||
(define (analyze-and-print pat-stx)
|
(define (analyze-and-print pat-stx)
|
||||||
|
|
Loading…
Reference in New Issue