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

Repair scheduling of inner dataspaces, thus allowing e.g. double nesting

This commit is contained in:
Tony Garnock-Jones 2018-04-29 16:07:49 +01:00
parent e69473a115
commit b3d6b74dab
5 changed files with 75 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
syndicate/dataspace.rkt
View File

@ -479,7 +479,7 @@
(define (stop-facet! f stop-script)
(define ac (facet-actor f))
(with-current-facet [ac (facet-parent f) #t] ;; run in parent context wrt terminating facet
(with-current-facet [ac (facet-parent f) #f] ;; run in parent context wrt terminating facet
(schedule-script! ac (lambda ()
(terminate-facet! f)
(schedule-script! ac stop-script)))))

54
syndicate/relay.rkt
View File

@ -16,33 +16,41 @@
(require "bag.rkt")
(require (for-syntax racket/base))
(require (for-syntax syntax/parse))
(require "syntax-classes.rkt")
(struct inbound (assertion) #:prefab)
(struct outbound (assertion) #:prefab)
(define-syntax (dataspace stx)
(syntax-case stx ()
[(_ form ...)
(syntax-parse stx
[(_ name:name form ...)
(syntax/loc stx
(spawn (define outer-actor (current-actor))
(define outer-facet (current-facet))
(define inner-ds (make-dataspace
(lambda ()
(schedule-script!
(current-actor)
(lambda ()
(spawn #:name 'dataspace-relay
(boot-relay outer-actor
outer-facet))
(spawn* form ...))))))
(on-start (schedule-turn! inner-ds))))]))
(let ((ds-name name.N))
(spawn #:name ds-name
(define outer-actor (current-actor))
(define outer-facet (current-facet))
(define (schedule-inner!)
(push-script!
outer-actor
(lambda ()
(with-current-facet [outer-actor outer-facet #t]
(defer-turn! (lambda ()
(when (run-scripts! inner-ds)
(schedule-inner!))))))))
(define inner-ds (make-dataspace
(lambda ()
(schedule-script!
(current-actor)
(lambda ()
(spawn #:name (list 'ds-link ds-name)
(boot-relay schedule-inner!
outer-actor
outer-facet))
(spawn* form ...))))))
(on-start (schedule-inner!)))))]))
(define (schedule-turn! inner-ds)
(defer-turn! (lambda ()
(when (run-scripts! inner-ds)
(schedule-turn! inner-ds)))))
(define (boot-relay outer-actor outer-facet)
(define (boot-relay schedule-inner! outer-actor outer-facet)
(define inbound-endpoints (make-hash))
(define outbound-endpoints (make-hash))
@ -63,14 +71,16 @@
(match op
['+ (adhoc-assert! inner-actor term)]
['- (adhoc-retract! inner-actor term)]
['! (enqueue-send! inner-actor term)]))))
['! (enqueue-send! inner-actor term)])))
(schedule-inner!))
(lambda (cache)
(push-script! inner-actor
(lambda ()
(for [(captured-values (in-bag cache))]
(define term
(inbound (instantiate-term->value x captured-values)))
(adhoc-retract! inner-actor term)))))))
(adhoc-retract! inner-actor term))))
(schedule-inner!))))
(hash-set! inbound-endpoints
x
(add-endpoint! outer-facet

10
syndicate/test-implementation.rkt
View File

@ -18,6 +18,7 @@
no-crashes
expected-output
expected-output-set
run-syndicate-test!
log-test-result!
@ -29,6 +30,7 @@
(require racket/exn)
(require racket/match)
(require racket/set)
(require (only-in racket/string string-split string-join string-contains?))
(require "bag.rkt")
@ -158,6 +160,14 @@
(equal? (collected-lines)
(list line ...))))]))
(define-syntax (expected-output-set stx)
(syntax-case stx ()
[(_ line ...)
(quasisyntax/loc stx
(it "should produce correct set of output lines"
(equal? (list->set (collected-lines))
(set line ...))))]))
(define RED ";31")
(define BRIGHT-RED ";1;31")
(define GREEN ";32")

28
syndicate/test/core/double-cross-layer.rkt Normal file
View File

@ -0,0 +1,28 @@
#lang imperative-syndicate/test-implementation
(test-case
[(assertion-struct greeting (text))
(spawn #:name "A" (assert (greeting "Hi from outer space!")))
(spawn #:name "B" (on (asserted (greeting $t))
(printf "Outer dataspace: ~a\n" t)))
(dataspace #:name "C"
(spawn #:name "D" (assert (outbound (greeting "Hi from middle!"))))
(spawn #:name "E" (on (asserted (inbound (greeting $t)))
(printf "Middle dataspace: ~a\n" t)))
(dataspace #:name "F"
(spawn #:name "G" (assert (outbound (outbound (greeting "Inner!")))))
(spawn #:name "H" (on (asserted (inbound (inbound (greeting $t))))
(printf "Inner dataspace: ~a\n" t)))))]
no-crashes
(expected-output-set "Outer dataspace: Hi from outer space!"
"Middle dataspace: Hi from outer space!"
"Inner dataspace: Hi from outer space!"
"Outer dataspace: Hi from middle!"
"Middle dataspace: Hi from middle!"
"Inner dataspace: Hi from middle!"
"Outer dataspace: Inner!"
"Middle dataspace: Inner!"
"Inner dataspace: Inner!"))

8
syndicate/test/core/simple-cross-layer.rkt
View File

@ -12,7 +12,7 @@
(spawn #:name "E" (on (asserted (inbound (greeting $t)))
(printf "Inner dataspace: ~a\n" t))))]
no-crashes
(expected-output "Outer dataspace: Hi from outer space!"
"Inner dataspace: Hi from outer space!"
"Outer dataspace: Hi from inner!"
"Inner dataspace: Hi from inner!"))
(expected-output-set "Outer dataspace: Hi from outer space!"
"Inner dataspace: Hi from outer space!"
"Outer dataspace: Hi from inner!"
"Inner dataspace: Hi from inner!"))