Repair scheduling of inner dataspaces, thus allowing e.g. double nesting
This commit is contained in:
parent
e69473a115
commit
b3d6b74dab
|
@ -479,7 +479,7 @@
|
||||||
|
|
||||||
(define (stop-facet! f stop-script)
|
(define (stop-facet! f stop-script)
|
||||||
(define ac (facet-actor f))
|
(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 ()
|
(schedule-script! ac (lambda ()
|
||||||
(terminate-facet! f)
|
(terminate-facet! f)
|
||||||
(schedule-script! ac stop-script)))))
|
(schedule-script! ac stop-script)))))
|
||||||
|
|
|
@ -16,33 +16,41 @@
|
||||||
(require "bag.rkt")
|
(require "bag.rkt")
|
||||||
|
|
||||||
(require (for-syntax racket/base))
|
(require (for-syntax racket/base))
|
||||||
|
(require (for-syntax syntax/parse))
|
||||||
|
(require "syntax-classes.rkt")
|
||||||
|
|
||||||
(struct inbound (assertion) #:prefab)
|
(struct inbound (assertion) #:prefab)
|
||||||
(struct outbound (assertion) #:prefab)
|
(struct outbound (assertion) #:prefab)
|
||||||
|
|
||||||
(define-syntax (dataspace stx)
|
(define-syntax (dataspace stx)
|
||||||
(syntax-case stx ()
|
(syntax-parse stx
|
||||||
[(_ form ...)
|
[(_ name:name form ...)
|
||||||
(syntax/loc stx
|
(syntax/loc stx
|
||||||
(spawn (define outer-actor (current-actor))
|
(let ((ds-name name.N))
|
||||||
(define outer-facet (current-facet))
|
(spawn #:name ds-name
|
||||||
(define inner-ds (make-dataspace
|
(define outer-actor (current-actor))
|
||||||
(lambda ()
|
(define outer-facet (current-facet))
|
||||||
(schedule-script!
|
(define (schedule-inner!)
|
||||||
(current-actor)
|
(push-script!
|
||||||
(lambda ()
|
outer-actor
|
||||||
(spawn #:name 'dataspace-relay
|
(lambda ()
|
||||||
(boot-relay outer-actor
|
(with-current-facet [outer-actor outer-facet #t]
|
||||||
outer-facet))
|
(defer-turn! (lambda ()
|
||||||
(spawn* form ...))))))
|
(when (run-scripts! inner-ds)
|
||||||
(on-start (schedule-turn! 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)
|
(define (boot-relay schedule-inner! outer-actor outer-facet)
|
||||||
(defer-turn! (lambda ()
|
|
||||||
(when (run-scripts! inner-ds)
|
|
||||||
(schedule-turn! inner-ds)))))
|
|
||||||
|
|
||||||
(define (boot-relay outer-actor outer-facet)
|
|
||||||
(define inbound-endpoints (make-hash))
|
(define inbound-endpoints (make-hash))
|
||||||
(define outbound-endpoints (make-hash))
|
(define outbound-endpoints (make-hash))
|
||||||
|
|
||||||
|
@ -63,14 +71,16 @@
|
||||||
(match op
|
(match op
|
||||||
['+ (adhoc-assert! inner-actor term)]
|
['+ (adhoc-assert! inner-actor term)]
|
||||||
['- (adhoc-retract! inner-actor term)]
|
['- (adhoc-retract! inner-actor term)]
|
||||||
['! (enqueue-send! inner-actor term)]))))
|
['! (enqueue-send! inner-actor term)])))
|
||||||
|
(schedule-inner!))
|
||||||
(lambda (cache)
|
(lambda (cache)
|
||||||
(push-script! inner-actor
|
(push-script! inner-actor
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(for [(captured-values (in-bag cache))]
|
(for [(captured-values (in-bag cache))]
|
||||||
(define term
|
(define term
|
||||||
(inbound (instantiate-term->value x captured-values)))
|
(inbound (instantiate-term->value x captured-values)))
|
||||||
(adhoc-retract! inner-actor term)))))))
|
(adhoc-retract! inner-actor term))))
|
||||||
|
(schedule-inner!))))
|
||||||
(hash-set! inbound-endpoints
|
(hash-set! inbound-endpoints
|
||||||
x
|
x
|
||||||
(add-endpoint! outer-facet
|
(add-endpoint! outer-facet
|
||||||
|
|
|
@ -18,6 +18,7 @@
|
||||||
|
|
||||||
no-crashes
|
no-crashes
|
||||||
expected-output
|
expected-output
|
||||||
|
expected-output-set
|
||||||
|
|
||||||
run-syndicate-test!
|
run-syndicate-test!
|
||||||
log-test-result!
|
log-test-result!
|
||||||
|
@ -29,6 +30,7 @@
|
||||||
|
|
||||||
(require racket/exn)
|
(require racket/exn)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
|
(require racket/set)
|
||||||
(require (only-in racket/string string-split string-join string-contains?))
|
(require (only-in racket/string string-split string-join string-contains?))
|
||||||
|
|
||||||
(require "bag.rkt")
|
(require "bag.rkt")
|
||||||
|
@ -158,6 +160,14 @@
|
||||||
(equal? (collected-lines)
|
(equal? (collected-lines)
|
||||||
(list line ...))))]))
|
(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 RED ";31")
|
||||||
(define BRIGHT-RED ";1;31")
|
(define BRIGHT-RED ";1;31")
|
||||||
(define GREEN ";32")
|
(define GREEN ";32")
|
||||||
|
|
|
@ -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!"))
|
|
@ -12,7 +12,7 @@
|
||||||
(spawn #:name "E" (on (asserted (inbound (greeting $t)))
|
(spawn #:name "E" (on (asserted (inbound (greeting $t)))
|
||||||
(printf "Inner dataspace: ~a\n" t))))]
|
(printf "Inner dataspace: ~a\n" t))))]
|
||||||
no-crashes
|
no-crashes
|
||||||
(expected-output "Outer dataspace: Hi from outer space!"
|
(expected-output-set "Outer dataspace: Hi from outer space!"
|
||||||
"Inner dataspace: Hi from outer space!"
|
"Inner dataspace: Hi from outer space!"
|
||||||
"Outer dataspace: Hi from inner!"
|
"Outer dataspace: Hi from inner!"
|
||||||
"Inner dataspace: Hi from inner!"))
|
"Inner dataspace: Hi from inner!"))
|
||||||
|
|
Loading…
Reference in New Issue