From 4e1bab4b9059b308f7f5489a771d40252dd3f1ee Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sun, 31 Jul 2016 17:24:48 -0400 Subject: [PATCH] Introduce make-spawn to capture parameterizations. Closes #10. --- examples/platformer/lll-main.rkt | 7 +-- racket/syndicate/actor.rkt | 2 +- racket/syndicate/core.rkt | 31 +++++++--- .../syndicate/examples/actor/parameters.rkt | 57 +++++++++++++++++++ racket/syndicate/monolithic/core.rkt | 20 +++---- racket/syndicate/relay.rkt | 27 ++++----- racket/syndicate/threaded.rkt | 22 +++---- 7 files changed, 119 insertions(+), 47 deletions(-) create mode 100644 racket/syndicate/examples/actor/parameters.rkt diff --git a/examples/platformer/lll-main.rkt b/examples/platformer/lll-main.rkt index dc05f24..8017d33 100644 --- a/examples/platformer/lll-main.rkt +++ b/examples/platformer/lll-main.rkt @@ -914,10 +914,9 @@ ;; LevelSpawner (define (spawn-standalone-assertions . patches) - ( (lambda () - (list (lambda (e s) #f) - (transition (void) (patch-seq* patches)) - #f)))) + (spawn (lambda (e s) #f) + (void) + patches)) (define (spawn-background-image level-size scene) (match-define (vector level-width level-height) level-size) diff --git a/racket/syndicate/actor.rkt b/racket/syndicate/actor.rkt index 80cb224..f70055d 100644 --- a/racket/syndicate/actor.rkt +++ b/racket/syndicate/actor.rkt @@ -269,7 +269,7 @@ (syntax-parse stx [(_ name:name script ...) (quasisyntax/loc stx - (core: + (core:make-spawn (lambda () (list actor-behavior (boot-actor (lambda () (begin/void-default script ...))) diff --git a/racket/syndicate/core.rkt b/racket/syndicate/core.rkt index b3f38d4..310f4e4 100644 --- a/racket/syndicate/core.rkt +++ b/racket/syndicate/core.rkt @@ -45,6 +45,7 @@ unsub (rename-out [make-quit quit]) + make-spawn (rename-out [spawn-process spawn]) spawn/stateless @@ -162,18 +163,32 @@ (define (make-quit #:exception [exn #f] . actions) (quit exn actions)) +(define (make-spawn spawn-producing-thunk) + (spawn (let ((parameterization (current-parameterization))) + (lambda () + (call-with-parameterization + parameterization + (lambda () + (match (spawn-producing-thunk) + [(list (? procedure? raw-beh) (? general-transition? txn) name) + (list (lambda (e s) + (call-with-parameterization parameterization (lambda () (raw-beh e s)))) + txn + name)] + [other other]))))))) ;; punt on error checking to dataspace boot code + (define-syntax spawn-process (syntax-rules () [(_ #:name name-exp behavior-exp initial-state-exp initial-action-tree-exp) - (spawn (lambda () - (list behavior-exp - (transition initial-state-exp initial-action-tree-exp) - name-exp)))] + (make-spawn (lambda () + (list behavior-exp + (transition initial-state-exp initial-action-tree-exp) + name-exp)))] [(_ behavior-exp initial-state-exp initial-action-tree-exp) - (spawn (lambda () - (list behavior-exp - (transition initial-state-exp initial-action-tree-exp) - #f)))])) + (make-spawn (lambda () + (list behavior-exp + (transition initial-state-exp initial-action-tree-exp) + #f)))])) (define-syntax spawn/stateless (syntax-rules () diff --git a/racket/syndicate/examples/actor/parameters.rkt b/racket/syndicate/examples/actor/parameters.rkt new file mode 100644 index 0000000..265a382 --- /dev/null +++ b/racket/syndicate/examples/actor/parameters.rkt @@ -0,0 +1,57 @@ +#lang syndicate/actor +;; Demonstrate use of parameters with actors. +;; +;; Per https://github.com/tonyg/syndicate/issues/10, "Parameters don't +;; work well with actors". Output from this program running against +;; buggy Syndicate: +;; +;; spawn-ps: (set) +;; start-ps: (set) +;; ps: (set) +;; start-ps: (set 'unset) +;; spawn-ps: (set 'second 'unset 'first) +;; ps: (set 'unset) +;; Survey-response: 'unset +;; Survey-response: 'unset +;; Survey-response: 'unset +;; +;; ... and against a fixed Syndicate: +;; +;; spawn-ps: (set) +;; start-ps: (set) +;; ps: (set) +;; start-ps: (set 'second 'unset 'first) +;; spawn-ps: (set 'second 'unset 'first) +;; ps: (set 'second 'unset 'first) +;; Survey-response: 'unset +;; Survey-response: 'first +;; Survey-response: 'second + +(define p (make-parameter 'unset)) + +(define (spawn-one) + (define p-at-spawn-time (p)) + (actor #:name (list 'spawn-one p-at-spawn-time) + (define p-at-start-time (p)) + (react + (assert `(p-at-spawn-time ,p-at-spawn-time)) + (assert `(p-at-start-time ,p-at-start-time)) + (assert `(p ,(p))) + (on (message 'survey) + (send! `(survey-response ,(p))))))) + +(actor + (spawn-one) + (parameterize ((p 'first)) (spawn-one)) + (parameterize ((p 'second)) (spawn-one)) + (flush!) + (until (asserted (observe 'survey))) + (react (on-start (send! 'survey)) + (define/query-set spawn-ps `(p-at-spawn-time ,$v) v) + (define/query-set start-ps `(p-at-start-time ,$v) v) + (define/query-set ps `(p ,$v) v) + (begin/dataflow (printf "spawn-ps: ~v\n" (spawn-ps))) + (begin/dataflow (printf "start-ps: ~v\n" (start-ps))) + (begin/dataflow (printf "ps: ~v\n" (ps))) + (on (message `(survey-response ,$v)) + (printf "Survey-response: ~v\n" v)))) diff --git a/racket/syndicate/monolithic/core.rkt b/racket/syndicate/monolithic/core.rkt index 5d6b184..a3ee7ec 100644 --- a/racket/syndicate/monolithic/core.rkt +++ b/racket/syndicate/monolithic/core.rkt @@ -122,17 +122,17 @@ (define-syntax spawn-monolithic (syntax-rules () [(_ #:name name-exp behavior-exp initial-state-exp initial-action-tree-exp) - ( (lambda () - (list (wrap-monolithic-behaviour behavior-exp) - (differentiate-outgoing (wrap-monolithic-state initial-state-exp) - (clean-actions initial-action-tree-exp)) - name-exp)))] + (make-spawn (lambda () + (list (wrap-monolithic-behaviour behavior-exp) + (differentiate-outgoing (wrap-monolithic-state initial-state-exp) + (clean-actions initial-action-tree-exp)) + name-exp)))] [(_ behavior-exp initial-state-exp initial-action-tree-exp) - ( (lambda () - (list (wrap-monolithic-behaviour behavior-exp) - (differentiate-outgoing (wrap-monolithic-state initial-state-exp) - (clean-actions initial-action-tree-exp)) - #f)))])) + (make-spawn (lambda () + (list (wrap-monolithic-behaviour behavior-exp) + (differentiate-outgoing (wrap-monolithic-state initial-state-exp) + (clean-actions initial-action-tree-exp)) + #f)))])) (define-syntax spawn-monolithic/stateless (syntax-rules () diff --git a/racket/syndicate/relay.rkt b/racket/syndicate/relay.rkt index f18d5ff..84abcb8 100644 --- a/racket/syndicate/relay.rkt +++ b/racket/syndicate/relay.rkt @@ -90,19 +90,20 @@ inbound-constructor inbound-parenthesis inner-spawn) - ( (lambda () - (define-values (proc initial-transition) (spawn->process+transition inner-spawn)) - (define initial-relay-state (relay outbound? - outbound-assertion - outbound-parenthesis - inbound-constructor - inbound-parenthesis - proc)) - (list relay-handle-event - (relay-transition (transition-bind (inject-relay-subscription initial-relay-state) - initial-transition) - initial-relay-state) - (process-name proc))))) + (make-spawn (lambda () + (define-values (proc initial-transition) (spawn->process+transition inner-spawn)) + (define initial-relay-state (relay outbound? + outbound-assertion + outbound-parenthesis + inbound-constructor + inbound-parenthesis + proc)) + (list relay-handle-event + (relay-transition + (transition-bind (inject-relay-subscription initial-relay-state) + initial-transition) + initial-relay-state) + (process-name proc))))) (define (pretty-print-relay r p) (fprintf p "RELAY ~a/~a\n" diff --git a/racket/syndicate/threaded.rkt b/racket/syndicate/threaded.rkt index 28a3fb7..b133f68 100644 --- a/racket/syndicate/threaded.rkt +++ b/racket/syndicate/threaded.rkt @@ -27,17 +27,17 @@ #f])) (define (spawn-threaded-actor spawn-action-thunk) - ( (lambda () - (define path (current-actor-path)) - (define thd (thread (lambda () (run-thread path spawn-action-thunk)))) - (thread (lambda () - (sync (thread-dead-evt thd)) - (send-ground-message (thread-quit #f '()) #:path path) - (signal-background-activity! #f))) - (signal-background-activity! #t) - (list proxy-behaviour - (transition (proxy-state thd) '()) - 'threaded-proxy)))) + (make-spawn (lambda () + (define path (current-actor-path)) + (define thd (thread (lambda () (run-thread path spawn-action-thunk)))) + (thread (lambda () + (sync (thread-dead-evt thd)) + (send-ground-message (thread-quit #f '()) #:path path) + (signal-background-activity! #f))) + (signal-background-activity! #t) + (list proxy-behaviour + (transition (proxy-state thd) '()) + 'threaded-proxy)))) (define (run-thread actor-path spawn-action-thunk) (define actor-path-rev (reverse actor-path))