syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

detect cycles when compiling internal events

This commit is contained in:
Sam Caldwell 2019-06-21 13:07:27 -04:00
parent e6524174e1
commit 27abf8ab1e
1 changed files with 77 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

143
racket/typed/proto.rkt
View File

@ -166,15 +166,13 @@
(define (compile/internal-events rg role) (define (compile/internal-events rg role)
(match-define (role-graph st0 orig-st#) rg) (match-define (role-graph st0 orig-st#) rg)
;; doing funny business with state (set) here ;; doing funny business with state (set) here
(define orig-st#* (hash-set orig-st# (set) (state (set) (hash)))) (define orig-st#+ (hash-set orig-st# (set) (state (set) (hash))))
(define assertion# (hash-set (all-states-assertions/internal (in-hash-keys orig-st#) role) (define assertion# (all-states-assertions/internal (in-hash-keys orig-st#+) role))
(set)
(set)))
;; a WorkItem is a ;; a WorkItem is a
;; (work-item StateName StateName D (Listof D) (Listof TransitionEffect)) ;; (work-item StateName (Listof StateName) D (Listof D) (Listof TransitionEffect))
;; such as (work-item from prev to by with effs), where ;; such as (work-item from path/r to by with effs), where
;; - from is the origin state for this chain of events ;; - from is the origin state for this chain of events
;; - prev is the prior state in the sequence ;; - path/r is the list of states in the path to this point, in reverse
;; - to is the current state that has been reached ;; - to is the current state that has been reached
;; - by is the external event that kicked off this sequence ;; - by is the external event that kicked off this sequence
;; - with is a list of pending events to be processed ;; - with is a list of pending events to be processed
@ -182,65 +180,78 @@
;; NOTE: the initial work item is a hack, setting from and prev to (set) and ;; NOTE: the initial work item is a hack, setting from and prev to (set) and
;; by to DataflowEvt. The first case in the outer match removes (set) from the ;; by to DataflowEvt. The first case in the outer match removes (set) from the
;; states to compensate for this. ;; states to compensate for this.
(struct work-item (from prev to by with effs) #:transparent) (struct work-item (from path/r to by with effs) #:transparent)
(define (walk work visited st#) (let/ec fail
(match work (define (walk work visited st#)
['() (match work
(define states ['()
(for/hash ([(sn txns) (in-hash st#)] (define states
#:unless (set-empty? sn)) (for/hash ([(sn txns) (in-hash st#)]
(values sn (state sn txns)))) #:unless (set-empty? sn))
;; TODO - st0 might have changed (values sn (state sn txns))))
(role-graph st0 states)] ;; TODO - st0 might have changed
[(cons (work-item from prev to by with effs) more-work) (role-graph st0 states)]
(define txn# (state-transitions (hash-ref orig-st# to))) [(cons (work-item from path/r to by with effs) more-work)
(define visited+ (set-add visited to)) (define prev (first path/r))
(define st#+ (if (hash-has-key? st# to) st# (hash-set st# to (hash)))) (define txn# (state-transitions (hash-ref orig-st#+ to)))
(define new-paths-work (define visited+ (set-add visited to))
(for*/list (#:unless (set-member? visited to) (define st#+ (if (hash-has-key? st# to) st# (hash-set st# to (hash))))
[(D txns) txn#] (define new-paths-work
#:when (external-evt? D) (for*/list (#:unless (set-member? visited to)
#:unless (equal? D DataflowEvt) [(D txns) (in-hash txn#)]
[t (in-set txns)]) #:when (external-evt? D)
(match-define (transition es dst) t) #:unless (equal? D DataflowEvt)
(work-item to to dst D (effs->internal-events es) es))) [t (in-set txns)])
(define new-events (route-internal (hash-ref assertion# prev) (match-define (transition es dst) t)
(hash-ref assertion# to))) (work-item to (list to) dst D (effs->internal-events es) es)))
(cond (define new-events (route-internal (hash-ref assertion# prev)
[(and (empty? with) (hash-ref assertion# to)))
(set-empty? new-events)) (cond
(define new-st# (update-path st#+ from to by effs)) [(and (empty? with)
(walk (append more-work new-paths-work) visited+ new-st#)] (set-empty? new-events)
[else (not (hash-has-key? txn# DataflowEvt)))
;; TODO - this is saying something about how the implementation schedules handlers; (define new-st# (update-path st#+ from to by effs))
;; I think it should be something like exploring (append with (permutations new-events)) (walk (append more-work new-paths-work) visited+ new-st#)]
(define new-events* (set->list new-events)) [else
(define pending (append with new-events*)) ;; TODO - this is saying something about how the implementation schedules handlers;
(define pending/first-relevant ;; I think it should be something like exploring (append with (permutations new-events))
(dropf pending (define new-events* (set->list new-events))
(lambda (evt) (define new-events/df (if (hash-has-key? txn# DataflowEvt) (cons DataflowEvt new-events*) new-events*))
(not (define pending (append with new-events/df))
(for/or ([D (in-hash-keys txn#)]) (define pending/first-relevant
;; TODO - think I want non-empty intersection instead of subtyping (dropf pending
(or (D<:? evt D) (lambda (evt)
(D<:? D evt))))))) (not
(match pending/first-relevant (for/or ([D (in-hash-keys txn#)])
['() ;; TODO - think I want non-empty intersection instead of subtyping
(define new-st# (update-path st#+ from to by effs)) (D<:? evt D))))))
(walk (append more-work new-paths-work) visited+ new-st#)] (match pending/first-relevant
[(cons evt more-pending) ['()
(define more-labor (define new-st# (update-path st#+ from to by effs))
(for*/list ([(D ts) (in-hash txn#)] (walk (append more-work new-paths-work) visited+ new-st#)]
#:when (or (D<:? evt D) [(cons evt more-pending)
(D<:? D evt)) (define path/r+ (cons to path/r))
[t (in-set ts)]) (define more-labor
(match-define (transition more-effs dest) t) (for*/list ([(D ts) (in-hash txn#)]
(define internal-effs (effs->internal-events more-effs)) #:when (D<:? evt D)
(work-item from to dest (append more-pending internal-effs) (append effs more-effs)))) [t (in-set ts)])
(walk (append more-work more-labor new-paths-work) visited+ st#+)])])])) (match-define (transition more-effs dest) t)
(walk (list (work-item (set) (set) st0 StartEvt '() '())) (when (member dest path/r+)
(set) (fail (list (reverse (cons dest path/r+))
(hash))) by
evt
D)))
(define internal-effs (effs->internal-events more-effs))
(work-item from
path/r+
dest
by
(append more-pending internal-effs)
(append effs more-effs))))
(walk (append more-work more-labor new-paths-work) visited+ st#+)])])]))
(walk (list (work-item (set) (list (set)) st0 StartEvt '() '()))
(set)
(hash))))
(module+ test (module+ test
(test-case (test-case