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 63c36d7010
commit 2a72f63084
1 changed files with 77 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
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,7 +180,8 @@
;; 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)
(let/ec fail
(define (walk work visited st#) (define (walk work visited st#)
(match work (match work
['() ['()
@ -192,55 +191,67 @@
(values sn (state sn txns)))) (values sn (state sn txns))))
;; TODO - st0 might have changed ;; TODO - st0 might have changed
(role-graph st0 states)] (role-graph st0 states)]
[(cons (work-item from prev to by with effs) more-work) [(cons (work-item from path/r to by with effs) more-work)
(define txn# (state-transitions (hash-ref orig-st# to))) (define prev (first path/r))
(define txn# (state-transitions (hash-ref orig-st#+ to)))
(define visited+ (set-add visited to)) (define visited+ (set-add visited to))
(define st#+ (if (hash-has-key? st# to) st# (hash-set st# to (hash)))) (define st#+ (if (hash-has-key? st# to) st# (hash-set st# to (hash))))
(define new-paths-work (define new-paths-work
(for*/list (#:unless (set-member? visited to) (for*/list (#:unless (set-member? visited to)
[(D txns) txn#] [(D txns) (in-hash txn#)]
#:when (external-evt? D) #:when (external-evt? D)
#:unless (equal? D DataflowEvt) #:unless (equal? D DataflowEvt)
[t (in-set txns)]) [t (in-set txns)])
(match-define (transition es dst) t) (match-define (transition es dst) t)
(work-item to to dst D (effs->internal-events es) es))) (work-item to (list to) dst D (effs->internal-events es) es)))
(define new-events (route-internal (hash-ref assertion# prev) (define new-events (route-internal (hash-ref assertion# prev)
(hash-ref assertion# to))) (hash-ref assertion# to)))
(cond (cond
[(and (empty? with) [(and (empty? with)
(set-empty? new-events)) (set-empty? new-events)
(not (hash-has-key? txn# DataflowEvt)))
(define new-st# (update-path st#+ from to by effs)) (define new-st# (update-path st#+ from to by effs))
(walk (append more-work new-paths-work) visited+ new-st#)] (walk (append more-work new-paths-work) visited+ new-st#)]
[else [else
;; TODO - this is saying something about how the implementation schedules handlers; ;; TODO - this is saying something about how the implementation schedules handlers;
;; I think it should be something like exploring (append with (permutations new-events)) ;; I think it should be something like exploring (append with (permutations new-events))
(define new-events* (set->list new-events)) (define new-events* (set->list new-events))
(define pending (append with new-events*)) (define new-events/df (if (hash-has-key? txn# DataflowEvt) (cons DataflowEvt new-events*) new-events*))
(define pending (append with new-events/df))
(define pending/first-relevant (define pending/first-relevant
(dropf pending (dropf pending
(lambda (evt) (lambda (evt)
(not (not
(for/or ([D (in-hash-keys txn#)]) (for/or ([D (in-hash-keys txn#)])
;; TODO - think I want non-empty intersection instead of subtyping ;; TODO - think I want non-empty intersection instead of subtyping
(or (D<:? evt D) (D<:? evt D))))))
(D<:? D evt)))))))
(match pending/first-relevant (match pending/first-relevant
['() ['()
(define new-st# (update-path st#+ from to by effs)) (define new-st# (update-path st#+ from to by effs))
(walk (append more-work new-paths-work) visited+ new-st#)] (walk (append more-work new-paths-work) visited+ new-st#)]
[(cons evt more-pending) [(cons evt more-pending)
(define path/r+ (cons to path/r))
(define more-labor (define more-labor
(for*/list ([(D ts) (in-hash txn#)] (for*/list ([(D ts) (in-hash txn#)]
#:when (or (D<:? evt D) #:when (D<:? evt D)
(D<:? D evt))
[t (in-set ts)]) [t (in-set ts)])
(match-define (transition more-effs dest) t) (match-define (transition more-effs dest) t)
(when (member dest path/r+)
(fail (list (reverse (cons dest path/r+))
by
evt
D)))
(define internal-effs (effs->internal-events more-effs)) (define internal-effs (effs->internal-events more-effs))
(work-item from to dest (append more-pending internal-effs) (append effs 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 (append more-work more-labor new-paths-work) visited+ st#+)])])]))
(walk (list (work-item (set) (set) st0 StartEvt '() '())) (walk (list (work-item (set) (list (set)) st0 StartEvt '() '()))
(set) (set)
(hash))) (hash))))
(module+ test (module+ test
(test-case (test-case