From 0cff79abec2c01c60d007a571db2a8ab60c55e4b Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 28 Jul 2016 15:39:52 -0400 Subject: [PATCH] Switch from parameters to "stores". A store is like a parameter, except stores are independent of each other, unlike parameters which are bundled together into a single parameterization. This was observable in cases like the example-action-after-suspension code checked in here, where dataflow invoked a script, which parameterized current-dataflow-subject-id. This captured *too much* of things like the pending-patch and pending-actions. Subsequent `schedule-action!` calls' effects were then lost. --- racket/syndicate/actor.rkt | 64 ++++++------ .../actor/example-action-after-suspension.rkt | 39 ++++++++ racket/syndicate/lang.rkt | 5 +- racket/syndicate/store.rkt | 98 +++++++++++++++++++ 4 files changed, 173 insertions(+), 33 deletions(-) create mode 100644 racket/syndicate/examples/actor/example-action-after-suspension.rkt create mode 100644 racket/syndicate/store.rkt diff --git a/racket/syndicate/actor.rkt b/racket/syndicate/actor.rkt index 0b944db..241dea2 100644 --- a/racket/syndicate/actor.rkt +++ b/racket/syndicate/actor.rkt @@ -82,6 +82,7 @@ (require "trie.rkt") (require "pattern.rkt") (require "dataflow.rkt") +(require "store.rkt") (require "support/hash.rkt") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -207,28 +208,26 @@ (require (submod "." priorities)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Parameters. Many of these are *updated* during facet execution! +;; Parameters and Stores. Many of these are *updated* during facet execution! ;; Parameterof (Setof FieldDescriptor) (define current-field-descriptors (make-parameter 'unset:current-field-descriptors)) -;; Parameterof ActorState -(define current-actor-state (make-parameter #f)) +;; Storeof ActorState +(define current-actor-state (make-store)) ;; Parameterof FID (define current-facet-id (make-parameter #f)) -;; Parameterof Patch -(define current-pending-patch (make-parameter patch-empty)) +;; Storeof Patch +(define current-pending-patch (make-store)) -;; Parameterof (Constreeof Action) -(define current-pending-actions (make-parameter '())) +;; Storeof (Constreeof Action) +(define current-pending-actions (make-store)) -(define (make-empty-pending-scripts) - (make-vector priority-count '())) - -;; Parameterof (Vector (List Script) (List Script)) -(define current-pending-scripts (make-parameter (make-empty-pending-scripts))) +;; Storeof (Vector (List Script) (List Script)) +;; Mutates the vector! +(define current-pending-scripts (make-store)) ;; Parameterof Boolean (define in-script? (make-parameter #f)) @@ -965,17 +964,20 @@ (struct-copy facet f [stop-scripts (cons script-proc (facet-stop-scripts f))]))))) +(define (make-empty-pending-scripts) + (make-vector priority-count '())) + (define (boot-actor script-proc) - (parameterize ((current-actor-state - (actor-state (mux) - (hasheqv) - trie-empty - trie-empty - (hash) - (make-dataflow-graph))) - (current-pending-patch patch-empty) - (current-pending-actions '()) - (current-pending-scripts (make-empty-pending-scripts))) + (with-store [(current-actor-state + (actor-state (mux) + (hasheqv) + trie-empty + trie-empty + (hash) + (make-dataflow-graph))) + (current-pending-patch patch-empty) + (current-pending-actions '()) + (current-pending-scripts (make-empty-pending-scripts))] (with-current-facet #f (set) #f (schedule-script! #f script-proc) (run-scripts!)))) @@ -1024,15 +1026,15 @@ (define (actor-behavior e a) (and e - (parameterize ((current-actor-state - (if (patch? e) - (struct-copy actor-state a - [previous-knowledge (actor-state-knowledge a)] - [knowledge (update-interests (actor-state-knowledge a) e)]) - a)) - (current-pending-patch patch-empty) - (current-pending-actions '()) - (current-pending-scripts (make-empty-pending-scripts))) + (with-store [(current-actor-state + (if (patch? e) + (struct-copy actor-state a + [previous-knowledge (actor-state-knowledge a)] + [knowledge (update-interests (actor-state-knowledge a) e)]) + a)) + (current-pending-patch patch-empty) + (current-pending-actions '()) + (current-pending-scripts (make-empty-pending-scripts))] (for [((fid f) (in-hash (actor-state-facets a)))] (facet-handle-event! fid f e)) (run-scripts!)))) diff --git a/racket/syndicate/examples/actor/example-action-after-suspension.rkt b/racket/syndicate/examples/actor/example-action-after-suspension.rkt new file mode 100644 index 0000000..d4f20f2 --- /dev/null +++ b/racket/syndicate/examples/actor/example-action-after-suspension.rkt @@ -0,0 +1,39 @@ +#lang syndicate/actor +;; Test case for a bug relating to use of parameters to accumulate +;; actions across react/suspend when an intermediate parameterization +;; for current-dataflow-subject-id has taken place. +;; +;; Expected output: +;; flag: 'clear +;; - 'first +;; flag: 'set +;; - '(saw ping) +;; +;; Buggy output: +;; flag: 'clear +;; - 'first +;; flag: 'clear + +(struct x (v) #:prefab) + +(actor (forever (on (message (x 'ping)) + (send! (x 'pong))))) + +(actor (react + (field [flag 'clear]) + (begin/dataflow + (printf "flag: ~v\n" (flag))) + + (field [spec #f]) + (begin/dataflow + (when (spec) + (let-event [(asserted (observe (x (spec))))] + (send! (x (list 'saw (spec)))) + (flag 'set)))) + + (on-start (send! (x 'first))) + (on (message (x 'first)) + (spec 'ping)))) + +(actor (forever (on (message (x $v)) + (printf "- ~v\n" v)))) diff --git a/racket/syndicate/lang.rkt b/racket/syndicate/lang.rkt index bde4f0a..6cd0cd8 100644 --- a/racket/syndicate/lang.rkt +++ b/racket/syndicate/lang.rkt @@ -5,6 +5,7 @@ (require racket/match) (require "main.rkt") (require (submod "actor.rkt" for-module-begin)) +(require "store.rkt") (provide (rename-out [module-begin #%module-begin]) activate @@ -95,8 +96,8 @@ (define (capture-actor-actions thunk) (call-with-syndicate-effects (lambda () - (parameterize ((current-pending-actions '()) - (current-pending-patch patch-empty)) + (with-store [(current-pending-actions '()) + (current-pending-patch patch-empty)] (define result (thunk)) (flush-pending-patch!) (cons result (current-pending-actions)))))) diff --git a/racket/syndicate/store.rkt b/racket/syndicate/store.rkt new file mode 100644 index 0000000..777a403 --- /dev/null +++ b/racket/syndicate/store.rkt @@ -0,0 +1,98 @@ +#lang racket/base +;; Continuation-mark-based explicitly-scoped stores + +(provide (struct-out store) + make-store + with-store + store-box + store-ref + store-set!) + +(struct store (mark-key) + #:property prop:procedure + (case-lambda + [(s) (store-ref s)] + [(s v) (store-set! s v)])) + +(define (make-store) + (store (make-continuation-mark-key (gensym 'store)))) + +(define (store-box s) + (or (continuation-mark-set-first #f (store-mark-key s)) + (error 'store-box + "Attempt to access store that is not currently in scope"))) + +(define (store-ref s) + (unbox (store-box s))) + +(define (store-set! s v) + (set-box! (store-box s) v)) + +(define-syntax with-store + (syntax-rules () + [(_ [] body ...) + (let () body ...)] + [(_ [(st initial-val) more ...] body ...) + (let ((s st)) + (with-continuation-mark (store-mark-key s) (box initial-val) + (with-store [more ...] body ...)))])) + +(module+ test + (require rackunit) + + (define p (make-parameter 123)) + + (define t (make-continuation-prompt-tag 'store-test)) + + (define s1 (make-store)) + (define s2 (make-store)) + + (with-store [(s1 's1)] + (check-equal? (s1) 's1) + (s1 'b) + (check-equal? (s1) 'b)) + + (with-store [(s1 's1) + (s2 's2)] + (check-equal? (s1) 's1) + (check-equal? (s2) 's2) + (s1 'b) + (s2 'b) + (with-store [(s1 'c)] + (check-equal? (s1) 'c) + (check-equal? (s2) 'b) + (s1 'd) + (s2 'd) + (check-equal? (s1) 'd) + (check-equal? (s2) 'd)) + (check-equal? (s1) 'b) + (check-equal? (s2) 'd)) + + (define (s1-push! x) + (s1 (cons x (s1)))) + + (with-store [(s1 '())] + (define k + (call-with-continuation-prompt + (lambda () + (s1-push! 'a) + (s1-push! (p)) + (parameterize ((p 234)) + (s1-push! (p)) + (s1-push! (call-with-composable-continuation + (lambda (k) + (abort-current-continuation + t + (lambda () + (s1-push! 'x) + k))) + t)) + (s1-push! 'b) + (s1-push! (p))) + (s1-push! (p)) + (s1-push! 'c)) + t)) + (s1-push! 'y) + (k 99) + (s1-push! 'd) + (check-equal? (reverse (s1)) '(a 123 234 x y 99 b 234 123 c d))))