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

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.
This commit is contained in:
Tony Garnock-Jones 2016-07-28 15:39:52 -04:00
parent 2e24e105b8
commit 0cff79abec
4 changed files with 173 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
racket/syndicate/actor.rkt
View File

@ -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!))))

39
racket/syndicate/examples/actor/example-action-after-suspension.rkt Normal file
View File

@ -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))))

5
racket/syndicate/lang.rkt
View File

@ -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))))))

98
racket/syndicate/store.rkt Normal file
View File

@ -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))))