From b3d6b74dab13481e98662aa9a2ca0f75c2c34bb9 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sun, 29 Apr 2018 16:07:49 +0100 Subject: [PATCH] Repair scheduling of inner dataspaces, thus allowing e.g. double nesting --- syndicate/dataspace.rkt | 2 +- syndicate/relay.rkt | 54 +++++++++++++--------- syndicate/test-implementation.rkt | 10 ++++ syndicate/test/core/double-cross-layer.rkt | 28 +++++++++++ syndicate/test/core/simple-cross-layer.rkt | 8 ++-- 5 files changed, 75 insertions(+), 27 deletions(-) create mode 100644 syndicate/test/core/double-cross-layer.rkt diff --git a/syndicate/dataspace.rkt b/syndicate/dataspace.rkt index 853c561..3fff4dd 100644 --- a/syndicate/dataspace.rkt +++ b/syndicate/dataspace.rkt @@ -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))))) diff --git a/syndicate/relay.rkt b/syndicate/relay.rkt index 054141f..8c19d7f 100644 --- a/syndicate/relay.rkt +++ b/syndicate/relay.rkt @@ -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 diff --git a/syndicate/test-implementation.rkt b/syndicate/test-implementation.rkt index f2a0b79..38ad31e 100644 --- a/syndicate/test-implementation.rkt +++ b/syndicate/test-implementation.rkt @@ -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") diff --git a/syndicate/test/core/double-cross-layer.rkt b/syndicate/test/core/double-cross-layer.rkt new file mode 100644 index 0000000..ce76614 --- /dev/null +++ b/syndicate/test/core/double-cross-layer.rkt @@ -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!")) diff --git a/syndicate/test/core/simple-cross-layer.rkt b/syndicate/test/core/simple-cross-layer.rkt index 56a7d2a..12a4236 100644 --- a/syndicate/test/core/simple-cross-layer.rkt +++ b/syndicate/test/core/simple-cross-layer.rkt @@ -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!"))