From 0673d6d9b3664768759e3523b866da49831f348b Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sun, 8 Apr 2018 11:44:32 +0100 Subject: [PATCH] Progress on syntax veneer --- imperative/dataspace.rkt | 251 +++++--- imperative/event-expander.rkt | 23 + imperative/pattern.rkt | 192 +++--- imperative/syntax.rkt | 1141 ++++++++++----------------------- 4 files changed, 615 insertions(+), 992 deletions(-) create mode 100644 imperative/event-expander.rkt diff --git a/imperative/dataspace.rkt b/imperative/dataspace.rkt index 2863807..a41df54 100644 --- a/imperative/dataspace.rkt +++ b/imperative/dataspace.rkt @@ -1,11 +1,52 @@ #lang racket/base -(provide ) +(provide make-dataspace ;; TODO: how to cleanly provide this? + run-scripts! ;; TODO: how to cleanly provide this? + + message-struct + assertion-struct + (struct-out observe) + + dataspace? + generate-id! ;; TODO: shouldn't be provided - inline syntax.rkt?? + + actor? + actor-id + actor-name + + facet? + facet-actor + + field-handle ;; TODO: shouldn't be provided - inline syntax.rkt?? + field-handle? + field-handle-name + field-handle-id + field-handle-owner + field-handle-value + + current-dataspace + current-actor + current-facet + in-script? ;; TODO: shouldn't be provided - inline syntax.rkt?? + capture-facet-context ;; TODO: shouldn't be provided - inline syntax.rkt?? + + add-facet! + stop-facet! + add-endpoint! + terminate-facet! ;; TODO: shouldn't be provided - inline syntax.rkt?? + schedule-script! ;; TODO: shouldn't be provided - inline syntax.rkt?? + push-script! ;; TODO: shouldn't be provided - inline syntax.rkt?? + ensure-in-script! ;; TODO: shouldn't be provided - inline syntax.rkt?? + + dataspace-spawn! ;; TODO: should this be provided? + dataspace-send! ;; TODO: should this be provided? + ) (require syndicate/functional-queue) (require syndicate/dataflow) (require racket/match) (require racket/set) +(require (only-in racket/exn exn->string)) (module+ test (require rackunit)) @@ -13,6 +54,13 @@ (require "pattern.rkt") (require "bag.rkt") +;; TODO: move somewhere sensible +;; Thin veneers over `struct` for declaring intent. +(define-syntax-rule (assertion-struct item ...) (struct item ... #:prefab)) +(define-syntax-rule (message-struct item ...) (struct item ... #:prefab)) + +(assertion-struct observe (specification)) + ;; An `ActorID` uniquely identifies an actor in a `Dataspace`. ;; A `FID` is a Facet ID, uniquely identifying a facet in a `Dataspace`. @@ -65,8 +113,8 @@ [(define (write-proc e p mode) (fprintf p "#" (endpoint-id e)))]) -;; TODO: field ownership: record actor (root facet) ID in field, check -;; it on access. +;; TODO: the field ownership checks during field-ref/field-set! might +;; be quite expensive. Are they worth it? (struct field-handle (name ;; Symbol id ;; Nat owner ;; Actor @@ -78,12 +126,20 @@ #:property prop:procedure (case-lambda [(f) + (when (not (eq? (field-handle-owner f) (current-actor))) (field-scope-error 'field-ref f)) (dataflow-record-observation! (dataspace-dataflow (current-dataspace)) f) (field-handle-value f)] [(f v) + (when (not (eq? (field-handle-owner f) (current-actor))) (field-scope-error 'field-set! f)) (dataflow-record-damage! (dataspace-dataflow (current-dataspace)) f) (set-field-handle-value! f v)])) +(define (field-scope-error who f) + (error who "Field ~a used out-of-scope; owner = ~a, current = ~a" + f + (field-handle-owner f) + (current-actor))) + ;; Parameterof Dataspace (define current-dataspace (make-parameter #f)) @@ -173,7 +229,11 @@ (current-facet f) (in-script? script?)) (with-handlers ([(lambda (e) (not (exn:break? e))) - (lambda (e) (terminate-actor! ds a))]) ;; TODO: tracing + (lambda (e) + (log-error "Actor ~a died with exception:\n~a" + (current-actor) + (exn->string e)) + (terminate-actor! ds a))]) ;; TODO: tracing body ... (void))))) @@ -261,25 +321,25 @@ (set-actor-root-facet! actor f)) (with-current-facet [ds actor f #f] (boot-proc)) - (schedule-script!* ds (lambda () - (when (and (facet-live? f) - (or (and parent (not (facet-live? parent))) - (facet-inert? ds f))) - (terminate-facet! ds f))))) + (push-script! ds (lambda () + (when (and (facet-live? f) + (or (and parent (not (facet-live? parent))) + (facet-inert? ds f))) + (terminate-facet! ds f))))) (define (facet-inert? ds f) (and (hash-empty? (facet-endpoints f)) (set-empty? (facet-children f)))) (define (schedule-script! #:priority [priority *normal-priority*] ds thunk) - (schedule-script!* #:priority priority ds (capture-facet-context thunk))) + (push-script! #:priority priority ds (capture-facet-context thunk))) -(define (schedule-script!* #:priority [priority *normal-priority*] ds thunk) +(define (push-script! #:priority [priority *normal-priority*] ds thunk-with-context) (define v (dataspace-pending-scripts ds)) - (vector-set! v priority (enqueue (vector-ref v priority) thunk))) + (vector-set! v priority (enqueue (vector-ref v priority) thunk-with-context))) (define (retract-facet-assertions-and-subscriptions! ds f) - (schedule-script!* ds (lambda () + (push-script! ds (lambda () (for [((eid ep) (in-hash (facet-endpoints f)))] (dataflow-forget-subject! (dataspace-dataflow ds) (list f eid)) (dataspace-retract! ds (endpoint-assertion ep)) @@ -318,7 +378,7 @@ (retract-facet-assertions-and-subscriptions! ds f) - (schedule-script!* + (push-script! #:priority *gc-priority* ds (lambda () @@ -374,102 +434,103 @@ (define (dataspace-subscribe! ds h) (add-interest! (dataspace-routing-table ds) h)) +(define (ensure-in-script! who) + (when (not (in-script?)) + (error who "Attempt to perform action outside script; are you missing an (on ...)?"))) + (define (dataspace-send! ds body) + (ensure-in-script! 'dataspace-send!) (enqueue-action! ds (message body))) (define (dataspace-spawn! ds name boot-proc initial-assertions) + (ensure-in-script! 'dataspace-spawn!) (enqueue-action! ds (spawn name boot-proc initial-assertions))) (module+ test - ;; TODO: move somewhere sensible - ;; Thin veneers over `struct` for declaring intent. - (define-syntax-rule (assertion-struct item ...) (struct item ... #:prefab)) - (define-syntax-rule (message-struct item ...) (struct item ... #:prefab)) - (message-struct set-box (new-value)) (assertion-struct box-state (value)) - ;; TODO: move somewhere sensible - (assertion-struct observe (specification)) - (define ds (make-dataspace 'ground (lambda () - (dataspace-spawn! - ds - 'box + (schedule-script! + (current-dataspace) (lambda () - (define current-value (field-handle 'current-value - (generate-id! (current-dataspace)) - (facet-actor (current-facet)) - 0)) - (add-endpoint! (current-dataspace) - 'stop-when-ten - (lambda () - (when (= (current-value) 10) - (stop-facet! (current-dataspace) - (current-facet) - (lambda () - (log-info "box: terminating")))) - (void)) - #f) - (add-endpoint! (current-dataspace) - 'assert-box-state - (lambda () (box-state (current-value))) - #f) - (add-endpoint! (current-dataspace) - 'on-message-set-box - (lambda () (observe (set-box (capture (discard))))) - (skeleton-interest (list struct:set-box #f) - '() - '() - '((0 0)) - (capture-facet-context - (lambda (op new-value) - (when (eq? '! op) - (schedule-script! - (current-dataspace) - (lambda () - (log-info "box: taking on new-value ~v" new-value) - (current-value new-value))))))))) - (set)) - (dataspace-spawn! - ds - 'client - (lambda () - (add-endpoint! (current-dataspace) - 'stop-when-retracted-observe-set-box - (lambda () (observe (observe (set-box (discard))))) - (skeleton-interest (list struct:observe (list struct:set-box #f)) - '() - '() - '() - (capture-facet-context - (lambda (op) - (when (eq? '- op) - (stop-facet! - (current-dataspace) - (current-facet) - (lambda () - (log-info "client: box has gone")))))))) - (add-endpoint! (current-dataspace) - 'on-asserted-box-state - (lambda () (observe (box-state (capture (discard))))) - (skeleton-interest (list struct:box-state #f) - '() - '() - '((0 0)) - (capture-facet-context - (lambda (op v) - (when (eq? '+ op) - (schedule-script! - (current-dataspace) - (lambda () - (log-info "client: learned that box's value is now ~v" v) - (dataspace-send! (current-dataspace) - (set-box (+ v 1))))))))))) - (set))))) + (dataspace-spawn! + ds + 'box + (lambda () + (define current-value (field-handle 'current-value + (generate-id! (current-dataspace)) + (current-actor) + 0)) + (add-endpoint! (current-dataspace) + 'stop-when-ten + (lambda () + (when (= (current-value) 10) + (stop-facet! (current-dataspace) + (current-facet) + (lambda () + (log-info "box: terminating")))) + (void)) + #f) + (add-endpoint! (current-dataspace) + 'assert-box-state + (lambda () (box-state (current-value))) + #f) + (add-endpoint! (current-dataspace) + 'on-message-set-box + (lambda () (observe (set-box (capture (discard))))) + (skeleton-interest (list struct:set-box #f) + '() + '() + '((0 0)) + (capture-facet-context + (lambda (op new-value) + (when (eq? '! op) + (schedule-script! + (current-dataspace) + (lambda () + (log-info "box: taking on new-value ~v" new-value) + (current-value new-value))))))))) + (set)) + (dataspace-spawn! + ds + 'client + (lambda () + (add-endpoint! (current-dataspace) + 'stop-when-retracted-observe-set-box + (lambda () (observe (observe (set-box (discard))))) + (skeleton-interest (list struct:observe (list struct:set-box #f)) + '() + '() + '() + (capture-facet-context + (lambda (op) + (when (eq? '- op) + (stop-facet! + (current-dataspace) + (current-facet) + (lambda () + (log-info "client: box has gone")))))))) + (add-endpoint! (current-dataspace) + 'on-asserted-box-state + (lambda () (observe (box-state (capture (discard))))) + (skeleton-interest (list struct:box-state #f) + '() + '() + '((0 0)) + (capture-facet-context + (lambda (op v) + (when (eq? '+ op) + (schedule-script! + (current-dataspace) + (lambda () + (log-info "client: learned that box's value is now ~v" v) + (dataspace-send! (current-dataspace) + (set-box (+ v 1))))))))))) + (set))))))) (require racket/pretty) ;; (pretty-print ds) diff --git a/imperative/event-expander.rkt b/imperative/event-expander.rkt new file mode 100644 index 0000000..1113869 --- /dev/null +++ b/imperative/event-expander.rkt @@ -0,0 +1,23 @@ +#lang racket/base + +(require auxiliary-macro-context) + +(define-auxiliary-macro-context + #:context-name event-expander + #:prop-name prop:event-expander + #:prop-predicate-name event-expander? + #:prop-accessor-name event-expander-proc + #:macro-definer-name define-event-expander + #:introducer-parameter-name current-event-expander-introducer + #:local-introduce-name syntax-local-event-expander-introduce + #:expander-id-predicate-name event-expander-id? + #:expander-transform-name event-expander-transform) + +(provide (for-syntax + prop:event-expander + event-expander? + event-expander-proc + syntax-local-event-expander-introduce + event-expander-id? + event-expander-transform) + define-event-expander) diff --git a/imperative/pattern.rkt b/imperative/pattern.rkt index e4c8b1c..ddcdf13 100644 --- a/imperative/pattern.rkt +++ b/imperative/pattern.rkt @@ -2,16 +2,19 @@ (provide (struct-out discard) (struct-out capture) - analyse-pattern - desc->key - desc->skeleton-proj - desc->capture-proj - desc->skeleton-stx - desc->assertion-stx) -(require racket/match) -(require racket/struct-info) -(require syntax/stx) + (for-syntax analyse-pattern + desc->key + desc->skeleton-proj + desc->skeleton-stx + desc->capture-proj + desc->capture-names + desc->assertion-stx)) + +(require (for-syntax racket/base)) +(require (for-syntax racket/match)) +(require (for-syntax racket/struct-info)) +(require (for-syntax syntax/stx)) (struct discard () #:prefab) (struct capture (detail) #:prefab) @@ -30,96 +33,105 @@ ;; The other `SkProj` generates a second `SkKey` which is used as the ;; input to a handler function. -(define (dollar-id? stx) - (and (identifier? stx) - (char=? (string-ref (symbol->string (syntax-e stx)) 0) #\$))) +(begin-for-syntax + (define (dollar-id? stx) + (and (identifier? stx) + (char=? (string-ref (symbol->string (syntax-e stx)) 0) #\$))) -(define (undollar stx) - (and (dollar-id? stx) - (datum->syntax stx (string->symbol (substring (symbol->string (syntax-e stx)) 1))))) + (define (undollar stx) + (and (dollar-id? stx) + (datum->syntax stx (string->symbol (substring (symbol->string (syntax-e stx)) 1))))) -(define (discard-id? stx) - (and (identifier? stx) - (free-transformer-identifier=? #'_ stx))) + (define (discard-id? stx) + (and (identifier? stx) + (free-transformer-identifier=? #'_ stx))) -(define (id-value stx) - (and (identifier? stx) - (syntax-local-value stx (lambda () #f)))) + (define (id-value stx) + (and (identifier? stx) + (syntax-local-value stx (lambda () #f)))) -(define (list-id? stx) - (and (identifier? stx) - (free-transformer-identifier=? #'list stx))) + (define (list-id? stx) + (and (identifier? stx) + (free-transformer-identifier=? #'list stx))) -(define (analyse-pattern stx) - (syntax-case stx ($) - [(ctor piece ...) - (struct-info? (id-value #'ctor)) - (list* 'compound - (extract-struct-info (id-value #'ctor)) - (stx-map analyse-pattern #'(piece ...)))] - [(list piece ...) - (list-id? #'list) - (list* 'compound - 'list - (stx-map analyse-pattern #'(piece ...)))] - [id - (dollar-id? #'id) - (list 'capture (undollar #'id) (list 'discard))] - [($ id p) - (list 'capture #'id (analyse-pattern #'p))] - [id - (discard-id? #'id) - (list 'discard)] - [_ - (list 'atom stx)])) + (define (analyse-pattern stx) + (syntax-case stx ($) + [(ctor piece ...) + (struct-info? (id-value #'ctor)) + (list* 'compound + (extract-struct-info (id-value #'ctor)) + (stx-map analyse-pattern #'(piece ...)))] + [(list piece ...) + (list-id? #'list) + (list* 'compound + 'list + (stx-map analyse-pattern #'(piece ...)))] + [id + (dollar-id? #'id) + (list 'capture (undollar #'id) (list 'discard))] + [($ id p) + (list 'capture #'id (analyse-pattern #'p))] + [id + (discard-id? #'id) + (list 'discard)] + [_ + (list 'atom stx)])) + ) ;;--------------------------------------------------------------------------- -(define (select-pattern-leaves desc capture-fn atom-fn) - (define (walk-node key-rev desc) +(begin-for-syntax + (define (select-pattern-leaves desc capture-fn atom-fn) + (define (walk-node key-rev desc) + (match desc + [`(compound ,_ ,pieces ...) (walk-edge 0 key-rev pieces)] + [`(capture ,name-stx ,p) (append (capture-fn key-rev name-stx) (walk-node key-rev p))] + [`(discard) (list)] + [`(atom ,v) (atom-fn key-rev v)])) + (define (walk-edge index key-rev pieces) + (match pieces + ['() '()] + [(cons p pieces) (append (walk-node (cons index key-rev) p) + (walk-edge (+ index 1) key-rev pieces))])) + (walk-node '(0) desc)) + + (define (desc->key desc) + (select-pattern-leaves desc + (lambda (key-rev name-stx) (list)) + (lambda (key-rev atom) (list atom)))) + + (define (desc->skeleton-proj desc) + (select-pattern-leaves desc + (lambda (key-rev name-stx) (list)) + (lambda (key-rev atom) (list (reverse key-rev))))) + + (define (desc->skeleton-stx desc) (match desc - [`(compound ,_ ,pieces ...) (walk-edge 0 key-rev pieces)] - [`(capture ,_ ,p) (append (capture-fn key-rev) (walk-node key-rev p))] - [`(discard) (list)] - [`(atom ,v) (atom-fn key-rev v)])) - (define (walk-edge index key-rev pieces) - (match pieces - ['() '()] - [(cons p pieces) (append (walk-node (cons index key-rev) p) - (walk-edge (+ index 1) key-rev pieces))])) - (walk-node '(0) desc)) + [`(compound list ,pieces ...) + #`(list 'list #,@(map desc->skeleton-stx pieces))] + [`(compound (,struct-type ,_ctor ,_pred ,_getters ,_setters ,_super) ,pieces ...) + #`(list #,struct-type #,@(map desc->skeleton-stx pieces))] + [`(capture ,_ ,p) (desc->skeleton-stx p)] + [`(discard) #'#f] + [`(atom ,atom-stx) #'#f])) -(define (desc->key desc) - (select-pattern-leaves desc - (lambda (key-rev) (list)) - (lambda (key-rev atom) (list atom)))) + (define (desc->capture-proj desc) + (select-pattern-leaves desc + (lambda (key-rev name-stx) (list (reverse key-rev))) + (lambda (key-rev atom) (list)))) -(define (desc->skeleton-proj desc) - (select-pattern-leaves desc - (lambda (key-rev) (list)) - (lambda (key-rev atom) (list (reverse key-rev))))) + (define (desc->capture-names desc) + (select-pattern-leaves desc + (lambda (key-rev name-stx) (list name-stx)) + (lambda (key-rev atom) (list)))) -(define (desc->capture-proj desc) - (select-pattern-leaves desc - (lambda (key-rev) (list (reverse key-rev))) - (lambda (key-rev atom) (list)))) - -(define (desc->skeleton-stx desc) - (match desc - [`(compound list ,pieces ...) - #`(list 'list #,@(map desc->skeleton-stx pieces))] - [`(compound (,struct-type ,_ctor ,_pred ,_getters ,_setters ,_super) ,pieces ...) - #`(list #,struct-type #,@(map desc->skeleton-stx pieces))] - [`(capture ,_ ,p) (desc->skeleton-stx p)] - [`(discard) #'#f] - [`(atom ,_) #'#f])) - -(define (desc->assertion-stx desc) - (match desc - [`(compound list ,pieces ...) - #`(list #,@(map desc->assertion-stx pieces))] - [`(compound (,_struct-type ,ctor ,_pred ,_getters ,_setters ,_super) ,pieces ...) - #`(#,ctor #,@(map desc->assertion-stx pieces))] - [`(capture ,_ ,p) #`(capture #,(desc->assertion-stx p))] - [`(discard) #'(discard)] - [`(atom ,v) v])) + (define (desc->assertion-stx desc) + (match desc + [`(compound list ,pieces ...) + #`(list #,@(map desc->assertion-stx pieces))] + [`(compound (,_struct-type ,ctor ,_pred ,_getters ,_setters ,_super) ,pieces ...) + #`(#,ctor #,@(map desc->assertion-stx pieces))] + [`(capture ,_ ,p) #`(capture #,(desc->assertion-stx p))] + [`(discard) #'(discard)] + [`(atom ,v) v])) + ) diff --git a/imperative/syntax.rkt b/imperative/syntax.rkt index d2c42db..b16bd19 100644 --- a/imperative/syntax.rkt +++ b/imperative/syntax.rkt @@ -8,7 +8,6 @@ react/suspend until - current-facet-id field assert stop-facet @@ -18,8 +17,8 @@ on-start on-stop on - during - during/spawn + ;; during + ;; during/spawn begin/dataflow define/dataflow @@ -29,42 +28,29 @@ let-event - query-value - query-set - query-hash - query-hash-set - query-count - query-value* - query-set* - query-hash* - query-hash-set* - query-count* - define/query-value - define/query-set - define/query-hash - define/query-hash-set - define/query-count - immediate-query + ;; query-value + ;; query-set + ;; query-hash + ;; query-hash-set + ;; query-count + ;; query-value* + ;; query-set* + ;; query-hash* + ;; query-hash-set* + ;; query-count* + ;; define/query-value + ;; define/query-set + ;; define/query-hash + ;; define/query-hash-set + ;; define/query-count + ;; immediate-query send! - assert! - retract! - patch! - perform-actions! flush! - syndicate-effects-available? - - ? ;; from pattern.rkt - ;; - current-action-transformer - schedule-action! - schedule-actions! - (for-syntax (rename-out [name actor-name])) - - pretty-print-actor-state + ;; current-action-transformer ) (require (for-syntax racket/base)) @@ -74,6 +60,12 @@ (require "dataspace.rkt") (require (submod "dataspace.rkt" priorities)) +(require "event-expander.rkt") +(require "skeleton.rkt") +(require "pattern.rkt") + +(require racket/set) +(require syndicate/dataflow) (begin-for-syntax (define-splicing-syntax-class actor-wrapper @@ -130,6 +122,11 @@ (lambda () (begin/void-default script ...)) (set assertions.exprs ...)))])) +(define-syntax (begin/void-default stx) + (syntax-parse stx + [(_) (syntax/loc stx (void))] + [(_ expr0 expr ...) (syntax/loc stx (begin expr0 expr ...))])) + (define (react* where boot-proc) (define ds (current-dataspace)) (add-facet! ds @@ -165,7 +162,7 @@ (define (make-field name init) (field-handle name (generate-id! (current-dataspace)) - (fid->actor-fid (current-facet-id)) + (current-actor) init)) (define-syntax (define-field stx) @@ -186,25 +183,25 @@ (quasisyntax/loc stx (add-endpoint! (current-dataspace) #,(source-location->string stx) - (lambda () (when #'w.Pred P)) + (lambda () (when w.Pred P)) #f))])) (define-syntax (stop-facet stx) (syntax-parse stx - [(_ fid-expr script ...) + [(_ f-expr script ...) (quasisyntax/loc stx - (let ((fid fid-expr)) - (when (not (fid-ancestor? (current-facet-id) fid)) - (error 'stop-facet "Attempt to stop non-ancestor facet ~a" fid)) - (stop-facet! (current-dataspace) fid (lambda () (begin/void-default script ...)))))])) + (let ((f f-expr)) + (when (not (equal? (facet-actor f) (current-actor))) + (error 'stop-facet "Attempt to stop unrelated facet ~a from actor ~a" f (current-actor))) + (stop-facet! (current-dataspace) f (lambda () (begin/void-default script ...)))))])) (define-syntax-rule (stop-current-facet script ...) - (stop-facet (current-facet-id) script ...)) + (stop-facet (current-facet) script ...)) (define-syntax-rule (stop-when-true condition script ...) (begin/dataflow (when condition - (stop-facet (current-facet-id) script ...)))) + (stop-facet (current-facet) script ...)))) (define-syntax (on-start stx) (syntax-parse stx @@ -223,7 +220,7 @@ (define-syntax (stop-when stx) (syntax-parse stx [(_ w:when-pred E prio:priority script ...) - (analyze-event stx + (analyse-event stx #'w.Pred #'E (syntax/loc stx (stop-current-facet script ...)) @@ -232,7 +229,7 @@ (define-syntax (on stx) (syntax-parse stx [(_ w:when-pred E prio:priority script ...) - (analyze-event stx + (analyse-event stx #'w.Pred #'E (syntax/loc stx (begin/void-default script ...)) @@ -249,6 +246,7 @@ (define subject-id (current-dataflow-subject-id)) (schedule-script! #:priority prio.level + (current-dataspace) (lambda () (parameterize ((current-dataflow-subject-id subject-id)) expr ...))) @@ -267,6 +265,7 @@ (define-syntax (asserted stx) (raise-syntax-error #f "asserted: Used outside event spec" stx)) (define-syntax (retracted stx) (raise-syntax-error #f "retracted: Used outside event spec" stx)) +(define-syntax (message stx) (raise-syntax-error #f "message: Used outside event spec" stx)) (define-syntax (suspend-script stx) (syntax-parse stx @@ -286,733 +285,291 @@ [(_ [] expr) #'expr] [(_ [e es ...] expr) (quasisyntax/loc #'e (react (stop-when e (-let-event [es ...] expr))))])) -;; HERE - -(define-syntax (during stx) - (syntax-parse stx - [(_ P O ...) - (define E-stx (syntax/loc #'P (asserted P))) - (define-values (_proj _pat _bindings instantiated) - (analyze-pattern E-stx #'P)) - (quasisyntax/loc stx - (on #,E-stx - (let ((p #,instantiated)) - (react (stop-when (retracted p)) - O ...))))])) - -(define-syntax (during/spawn stx) - (syntax-parse stx - [(_ P w:actor-wrapper name:name assertions:assertions parent-let:let-option - oncrash:on-crash-option - O ...) - (define E-stx (syntax/loc #'P (asserted P))) - (define-values (_proj _pat _bindings instantiated) - (analyze-pattern E-stx #'P)) - (quasisyntax/loc stx - (on #,E-stx - (let* ((id (gensym 'during/spawn)) - (p #,instantiated) ;; this is the concrete assertion corresponding to demand - (inst (instance id p))) ;; this is the assertion representing supply - (react (stop-when (asserted inst) - ;; Supply (inst) appeared before demand (p) retracted. - ;; Transition to a state where we monitor demand, but also - ;; express interest in supply: this latter acts as a signal - ;; to the supply that it should stick around. We react to - ;; retraction of supply before retraction of demand by - ;; invoking the on-crash expression, if supplied. Once - ;; demand is retracted, this facet terminates, retracting - ;; its interest in supply, thereby signalling to the supply - ;; that it is no longer wanted. - (react (stop-when (retracted inst) ;; NOT OPTIONAL - #,@(if (attribute oncrash.expr) - #'(oncrash.expr) - #'())) - (stop-when (retracted p)))) - (stop-when (retracted p) - ;; Demand (p) retracted before supply (inst) appeared. We - ;; MUST wait for the supply to fully appear so that we can - ;; reliably tell it to shut down. We must maintain interest - ;; in supply until we see supply, and then terminate, thus - ;; signalling to supply that it is no longer wanted. - (react (stop-when (asserted inst))))) - (let parent-let.clauses - (w.wrapper #:linkage [(assert inst) - (stop-when (retracted (observe inst)))] - #:name name.N - #:assertions* assertions.P - O ...)))))])) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Queries - -(begin-for-syntax - (define-splicing-syntax-class on-add - (pattern (~optional (~seq #:on-add expr) #:defaults ([expr #f])))) - (define-splicing-syntax-class on-remove - (pattern (~optional (~seq #:on-remove expr) #:defaults ([expr #f])))) - - (define (schedule-query-handler-stxs maybe-expr-stx) - (if maybe-expr-stx - (quasisyntax/loc maybe-expr-stx - ((schedule-script! #:priority *query-handler-priority* - (lambda () #,maybe-expr-stx)))) - #'()))) - -(define-syntax (query-value stx) - (syntax-parse stx - [(_ field-name absent-expr args ...) - (quasisyntax/loc stx - (let () - (field [field-name absent-expr]) - (query-value* field-name absent-expr args ...)))])) - -(define-syntax (query-value* stx) - (syntax-parse stx - [(_ field-name absent-expr P expr on-add:on-add on-remove:on-remove) - (quasisyntax/loc stx - (let ((F field-name)) - (on (asserted P) #:priority *query-priority* - #,@(schedule-query-handler-stxs (attribute on-add.expr)) - (F expr)) - (on (retracted P) #:priority *query-priority-high* - #,@(schedule-query-handler-stxs (attribute on-remove.expr)) - (F absent-expr)) - F))])) - -(define-syntax (query-set stx) - (syntax-parse stx - [(_ field-name args ...) - (quasisyntax/loc stx - (let () - (field [field-name (set)]) - (query-set* field-name args ...)))])) - -(define-syntax (query-set* stx) - (syntax-parse stx - [(_ field-name P expr on-add:on-add on-remove:on-remove) - (quasisyntax/loc stx - (let ((F field-name)) - (on (asserted P) #:priority *query-priority* - (let ((V expr)) - (when (not (set-member? (F) V)) - #,@(schedule-query-handler-stxs (attribute on-add.expr)) - (F (set-add (F) V))))) - (on (retracted P) #:priority *query-priority-high* - (let ((V expr)) - (when (set-member? (F) V) - #,@(schedule-query-handler-stxs (attribute on-remove.expr)) - (F (set-remove (F) V))))) - F))])) - -(define-syntax (query-hash stx) - (syntax-parse stx - [(_ field-name args ...) - (quasisyntax/loc stx - (let () - (field [field-name (hash)]) - (query-hash* field-name args ...)))])) - -(define-syntax (query-hash* stx) - (syntax-parse stx - [(_ field-name P key-expr value-expr on-add:on-add on-remove:on-remove) - (quasisyntax/loc stx - (let ((F field-name)) - (on (asserted P) #:priority *query-priority* - (let ((key key-expr)) - (when (hash-has-key? (F) key) - (log-warning "query-hash: field ~v with pattern ~v: overwriting existing entry ~v" - 'field-name - 'P - key)) - #,@(schedule-query-handler-stxs (attribute on-add.expr)) - (F (hash-set (F) key value-expr)))) - (on (retracted P) #:priority *query-priority-high* - #,@(schedule-query-handler-stxs (attribute on-remove.expr)) - (F (hash-remove (F) key-expr))) - F))])) - -(define-syntax (query-hash-set stx) - (syntax-parse stx - [(_ field-name args ...) - (quasisyntax/loc stx - (let () - (field [field-name (hash)]) - (query-hash-set* field-name args ...)))])) - -(define-syntax (query-hash-set* stx) - (syntax-parse stx - [(_ field-name P key-expr value-expr on-add:on-add on-remove:on-remove) - (quasisyntax/loc stx - (let ((F field-name)) - (on (asserted P) #:priority *query-priority* - (let ((K key-expr) (V value-expr)) - (when (not (hashset-member? (F) K V)) - #,@(schedule-query-handler-stxs (attribute on-add.expr)) - (F (hashset-add (F) K V))))) - (on (retracted P) #:priority *query-priority-high* - (let ((K key-expr) (V value-expr)) - (when (hashset-member? (F) K V) - #,@(schedule-query-handler-stxs (attribute on-remove.expr)) - (F (hashset-remove (F) K V))))) - F))])) - -(define-syntax (query-count stx) - (syntax-parse stx - [(_ field-name args ...) - (quasisyntax/loc stx - (let () - (field [field-name (hash)]) - (query-count* field-name args ...)))])) - -(define-syntax (query-count* stx) - (syntax-parse stx - [(_ field-name P expr on-add:on-add on-remove:on-remove) - (quasisyntax/loc stx - (let ((F field-name)) - (on (asserted P) #:priority *query-priority* - (let ((E expr)) - #,@(schedule-query-handler-stxs (attribute on-add.expr)) - (F (hash-set (F) E (+ 1 (hash-ref (F) E 0)))))) - (on (retracted P) #:priority *query-priority-high* - (let ((E expr)) - #,@(schedule-query-handler-stxs (attribute on-remove.expr)) - (let ((F0 (F))) - (F (match (hash-ref F0 E 0) - [0 F0] ;; huh - [1 (hash-remove F0 E)] - [n (hash-set F0 E (- n 1))]))))) - F))])) - -(define-syntax-rule (define/query-value id ae P x ...) (define id (query-value id ae P x ...))) -(define-syntax-rule (define/query-set id P x ...) (define id (query-set id P x ...))) -(define-syntax-rule (define/query-hash id P x ...) (define id (query-hash id P x ...))) -(define-syntax-rule (define/query-hash-set id P x ...) (define id (query-hash-set id P x ...))) -(define-syntax-rule (define/query-count id P x ...) (define id (query-count id P x ...))) - -(define-syntax (immediate-query stx) - (syntax-case stx () - [(_ [op args ...] ...) - (with-syntax [((query-result ...) (generate-temporaries #'(op ...)))] - (syntax/loc stx - (react/suspend (k) - (define query-result (op query-result args ...)) ... - (on-start (flush!) (k (query-result) ...)))))])) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require auxiliary-macro-context) - -(define-auxiliary-macro-context - #:context-name event-expander - #:prop-name prop:event-expander - #:prop-predicate-name event-expander? - #:prop-accessor-name event-expander-proc - #:macro-definer-name define-event-expander - #:introducer-parameter-name current-event-expander-introducer - #:local-introduce-name syntax-local-event-expander-introduce - #:expander-id-predicate-name event-expander-id? - #:expander-transform-name event-expander-transform) - -(provide (for-syntax - prop:event-expander - event-expander? - event-expander-proc - syntax-local-event-expander-introduce - event-expander-id? - event-expander-transform) - define-event-expander) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Syntax-time support - -(define (interests-pre-and-post-patch pat synthetic?) - (define (or* x y) (or x y)) - (define a (current-actor-state)) - (define previous-knowledge (if synthetic? trie-empty (actor-state-previous-knowledge a))) - (define old (trie-lookup previous-knowledge pat #f #:wildcard-union or*)) - (define new (trie-lookup (actor-state-knowledge a) pat #f #:wildcard-union or*)) - (values old new)) - -(define (interest-just-appeared-matching? pat synthetic?) - (define-values (old new) (interests-pre-and-post-patch pat synthetic?)) - (and (not old) new)) - -(define (interest-just-disappeared-matching? pat synthetic?) - (define-values (old new) (interests-pre-and-post-patch pat synthetic?)) - (and old (not new))) - -(define-for-syntax (analyze-asserted/retracted outer-expr-stx - when-pred-stx - event-stx - script-stx - asserted? - P-stx - priority-stx) - (define-values (proj-stx pat bindings _instantiated) - (analyze-pattern event-stx P-stx)) - (define event-predicate-stx (if asserted? #'patch/added? #'patch/removed?)) - (define patch-accessor-stx (if asserted? #'patch-added #'patch-removed)) - (define change-detector-stx - (if asserted? #'interest-just-appeared-matching? #'interest-just-disappeared-matching?)) - (quasisyntax/loc outer-expr-stx - (add-endpoint! #,(source-location->string outer-expr-stx) - (lambda () (if #,when-pred-stx - (core:sub #,pat) - patch-empty)) - (lambda (e current-interests synthetic?) - (when (not (trie-empty? current-interests)) - (core:match-event e - [(? #,event-predicate-stx p) - (define proj #,proj-stx) - (define proj-arity (projection-arity proj)) - (define entry-set (trie-project/set #:take proj-arity - (#,patch-accessor-stx p) - proj)) - (when (not entry-set) - (error 'asserted - "Wildcard interest discovered while projecting by ~v at ~a" - proj - #,(source-location->string P-stx))) - (for [(entry (in-set entry-set))] - (let ((instantiated (instantiate-projection proj entry))) - (and (#,change-detector-stx instantiated synthetic?) - (schedule-script! - #:priority #,priority-stx - (lambda () - (match-define (list #,@bindings) entry) - #,script-stx)))))])))))) - (define-for-syntax orig-insp (variable-reference->module-declaration-inspector (#%variable-reference))) -(define-for-syntax (analyze-event outer-expr-stx +(define-for-syntax (analyse-event outer-expr-stx when-pred-stx armed-event-stx script-stx priority-stx) (define event-stx (syntax-disarm armed-event-stx orig-insp)) (syntax-parse event-stx - #:literals [core:message asserted retracted rising-edge] - [(expander args ...) - #:when (event-expander-id? #'expander) - (event-expander-transform - event-stx - (lambda (result) - (analyze-event outer-expr-stx - when-pred-stx - (syntax-rearm result event-stx) - script-stx - priority-stx)))] - [(core:message P) - (define-values (proj pat bindings _instantiated) - (analyze-pattern event-stx #'P)) + #:literals [message asserted retracted] + [(expander args ...) #:when (event-expander-id? #'expander) + (event-expander-transform event-stx + (lambda (result) + (analyse-event outer-expr-stx + when-pred-stx + (syntax-rearm result event-stx) + script-stx + priority-stx)))] + [(message P) + (define desc (analyse-pattern #'P)) (quasisyntax/loc outer-expr-stx - (add-endpoint! #,(source-location->string outer-expr-stx) - (lambda () (if #,when-pred-stx - (core:sub #,pat) - patch-empty)) - (lambda (e current-interests _synthetic?) - (when (not (trie-empty? current-interests)) - (core:match-event e - [(core:message body) - (define capture-vals - (match-value/captures - body - #,proj)) - (and capture-vals - (schedule-script! - #:priority #,priority-stx - (lambda () - (apply (lambda #,bindings #,script-stx) - capture-vals))))])))))] + (add-endpoint! (current-dataspace) + #,(source-location->string outer-expr-stx) + (lambda () (when #,when-pred-stx (observe #,(desc->assertion-stx desc)))) + (skeleton-interest #,(desc->skeleton-stx desc) + '#,(desc->skeleton-proj desc) + (list #,@(desc->key desc)) + '#,(desc->capture-proj desc) + (capture-facet-context + (lambda (op #,@(desc->capture-names desc)) + (when (eq? op '!) + (schedule-script! + #:priority #,priority-stx + (current-dataspace) + (lambda () + #,script-stx))))))))] [(asserted P) - (analyze-asserted/retracted outer-expr-stx when-pred-stx event-stx script-stx - #t #'P priority-stx)] + (analyze-asserted/retracted outer-expr-stx when-pred-stx script-stx #t #'P priority-stx)] [(retracted P) - (analyze-asserted/retracted outer-expr-stx when-pred-stx event-stx script-stx - #f #'P priority-stx)] - [(rising-edge Pred) - (define field-name - (datum->syntax event-stx - (string->symbol - (format "~a:rising-edge" (source-location->string event-stx))))) - (quasisyntax/loc outer-expr-stx - (let () - (field [#,field-name #f]) - (add-endpoint! #,(source-location->string outer-expr-stx) - (lambda () - (when #,when-pred-stx - (define old-val (#,field-name)) - (define new-val Pred) - (when (not (eq? old-val new-val)) - (#,field-name new-val) - (when new-val - (schedule-script! #:priority #,priority-stx - (lambda () #,script-stx))))) - patch-empty) - void)))])) + (analyze-asserted/retracted outer-expr-stx when-pred-stx script-stx #f #'P priority-stx)])) -(define-syntax (begin/void-default stx) - (syntax-parse stx - [(_) - (syntax/loc stx (void))] - [(_ expr0 expr ...) - (syntax/loc stx (begin expr0 expr ...))])) +(define-for-syntax (analyze-asserted/retracted outer-expr-stx + when-pred-stx + script-stx + asserted? + P-stx + priority-stx) + (define desc (analyse-pattern P-stx)) + (quasisyntax/loc outer-expr-stx + (add-endpoint! (current-dataspace) + #,(source-location->string outer-expr-stx) + (lambda () (when #,when-pred-stx (observe #,(desc->assertion-stx desc)))) + (skeleton-interest #,(desc->skeleton-stx desc) + '#,(desc->skeleton-proj desc) + (list #,@(desc->key desc)) + '#,(desc->capture-proj desc) + (capture-facet-context + (lambda (op #,@(desc->capture-names desc)) + (when (eq? op #,(if asserted? #''+ #''-)) + (schedule-script! + #:priority #,priority-stx + (current-dataspace) + (lambda () + #,script-stx))))))))) + +;; (define-syntax (during stx) +;; (syntax-parse stx +;; [(_ P O ...) +;; (define E-stx (syntax/loc #'P (asserted P))) +;; (define-values (_proj _pat _bindings instantiated) +;; (analyze-pattern E-stx #'P)) +;; (quasisyntax/loc stx +;; (on #,E-stx +;; (let ((p #,instantiated)) +;; (react (stop-when (retracted p)) +;; O ...))))])) + +;; (define-syntax (during/spawn stx) +;; (syntax-parse stx +;; [(_ P w:actor-wrapper name:name assertions:assertions parent-let:let-option +;; oncrash:on-crash-option +;; O ...) +;; (define E-stx (syntax/loc #'P (asserted P))) +;; (define-values (_proj _pat _bindings instantiated) +;; (analyze-pattern E-stx #'P)) +;; (quasisyntax/loc stx +;; (on #,E-stx +;; (let* ((id (gensym 'during/spawn)) +;; (p #,instantiated) ;; this is the concrete assertion corresponding to demand +;; (inst (instance id p))) ;; this is the assertion representing supply +;; (react (stop-when (asserted inst) +;; ;; Supply (inst) appeared before demand (p) retracted. +;; ;; Transition to a state where we monitor demand, but also +;; ;; express interest in supply: this latter acts as a signal +;; ;; to the supply that it should stick around. We react to +;; ;; retraction of supply before retraction of demand by +;; ;; invoking the on-crash expression, if supplied. Once +;; ;; demand is retracted, this facet terminates, retracting +;; ;; its interest in supply, thereby signalling to the supply +;; ;; that it is no longer wanted. +;; (react (stop-when (retracted inst) ;; NOT OPTIONAL +;; #,@(if (attribute oncrash.expr) +;; #'(oncrash.expr) +;; #'())) +;; (stop-when (retracted p)))) +;; (stop-when (retracted p) +;; ;; Demand (p) retracted before supply (inst) appeared. We +;; ;; MUST wait for the supply to fully appear so that we can +;; ;; reliably tell it to shut down. We must maintain interest +;; ;; in supply until we see supply, and then terminate, thus +;; ;; signalling to supply that it is no longer wanted. +;; (react (stop-when (asserted inst))))) +;; (let parent-let.clauses +;; (w.wrapper #:linkage [(assert inst) +;; (stop-when (retracted (observe inst)))] +;; #:name name.N +;; #:assertions* assertions.P +;; O ...)))))])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Field Construction and Access +;; Queries -(define field-counter 0) -(define (make-field name initial-value) - (define desc (field-descriptor name field-counter)) - (set! field-counter (+ field-counter 1)) - (hash-set! (actor-state-field-table (current-actor-state)) - desc - (make-ephemeron desc initial-value)) - (field-handle desc)) +;; (begin-for-syntax +;; (define-splicing-syntax-class on-add +;; (pattern (~optional (~seq #:on-add expr) #:defaults ([expr #f])))) +;; (define-splicing-syntax-class on-remove +;; (pattern (~optional (~seq #:on-remove expr) #:defaults ([expr #f])))) -(define (field-scope-error who desc) - (error who "Field ~a used out-of-scope" (field-descriptor-name desc))) +;; (define (schedule-query-handler-stxs maybe-expr-stx) +;; (if maybe-expr-stx +;; (quasisyntax/loc maybe-expr-stx +;; ((schedule-script! #:priority *query-handler-priority* +;; (lambda () #,maybe-expr-stx)))) +;; #'()))) -(define (field-ref desc) - (ephemeron-value - (hash-ref (actor-state-field-table (current-actor-state)) - desc - (lambda () (field-scope-error 'field-ref desc))))) +;; (define-syntax (query-value stx) +;; (syntax-parse stx +;; [(_ field-name absent-expr args ...) +;; (quasisyntax/loc stx +;; (let () +;; (field [field-name absent-expr]) +;; (query-value* field-name absent-expr args ...)))])) -(define (field-set! desc v) - (define a (current-actor-state)) - (define ft (actor-state-field-table a)) - (unless (hash-has-key? ft desc) - (field-scope-error 'field-set! desc)) - (hash-set! ft desc (make-ephemeron desc v))) +;; (define-syntax (query-value* stx) +;; (syntax-parse stx +;; [(_ field-name absent-expr P expr on-add:on-add on-remove:on-remove) +;; (quasisyntax/loc stx +;; (let ((F field-name)) +;; (on (asserted P) #:priority *query-priority* +;; #,@(schedule-query-handler-stxs (attribute on-add.expr)) +;; (F expr)) +;; (on (retracted P) #:priority *query-priority-high* +;; #,@(schedule-query-handler-stxs (attribute on-remove.expr)) +;; (F absent-expr)) +;; F))])) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Facet Storage in an Actor +;; (define-syntax (query-set stx) +;; (syntax-parse stx +;; [(_ field-name args ...) +;; (quasisyntax/loc stx +;; (let () +;; (field [field-name (set)]) +;; (query-set* field-name args ...)))])) -(define (facet-live? fid) - (hash-has-key? (actor-state-facets (current-actor-state)) fid)) +;; (define-syntax (query-set* stx) +;; (syntax-parse stx +;; [(_ field-name P expr on-add:on-add on-remove:on-remove) +;; (quasisyntax/loc stx +;; (let ((F field-name)) +;; (on (asserted P) #:priority *query-priority* +;; (let ((V expr)) +;; (when (not (set-member? (F) V)) +;; #,@(schedule-query-handler-stxs (attribute on-add.expr)) +;; (F (set-add (F) V))))) +;; (on (retracted P) #:priority *query-priority-high* +;; (let ((V expr)) +;; (when (set-member? (F) V) +;; #,@(schedule-query-handler-stxs (attribute on-remove.expr)) +;; (F (set-remove (F) V))))) +;; F))])) -(define (lookup-facet fid) - (hash-ref (actor-state-facets (current-actor-state)) fid #f)) +;; (define-syntax (query-hash stx) +;; (syntax-parse stx +;; [(_ field-name args ...) +;; (quasisyntax/loc stx +;; (let () +;; (field [field-name (hash)]) +;; (query-hash* field-name args ...)))])) -(define (facet-live-but-inert? fid) - (define f (lookup-facet fid)) - (and f - (hash-empty? (facet-endpoints f)) - (set-empty? (facet-children f)))) +;; (define-syntax (query-hash* stx) +;; (syntax-parse stx +;; [(_ field-name P key-expr value-expr on-add:on-add on-remove:on-remove) +;; (quasisyntax/loc stx +;; (let ((F field-name)) +;; (on (asserted P) #:priority *query-priority* +;; (let ((key key-expr)) +;; (when (hash-has-key? (F) key) +;; (log-warning "query-hash: field ~v with pattern ~v: overwriting existing entry ~v" +;; 'field-name +;; 'P +;; key)) +;; #,@(schedule-query-handler-stxs (attribute on-add.expr)) +;; (F (hash-set (F) key value-expr)))) +;; (on (retracted P) #:priority *query-priority-high* +;; #,@(schedule-query-handler-stxs (attribute on-remove.expr)) +;; (F (hash-remove (F) key-expr))) +;; F))])) -(define (update-facet! fid proc) - (define old-facet (lookup-facet fid)) - (define new-facet (proc old-facet)) - (store-facet! fid new-facet)) +;; (define-syntax (query-hash-set stx) +;; (syntax-parse stx +;; [(_ field-name args ...) +;; (quasisyntax/loc stx +;; (let () +;; (field [field-name (hash)]) +;; (query-hash-set* field-name args ...)))])) -(define (store-facet! fid new-facet) - (define a (current-actor-state)) - (current-actor-state - (struct-copy actor-state a - [facets (hash-set/remove (actor-state-facets a) fid new-facet)]))) +;; (define-syntax (query-hash-set* stx) +;; (syntax-parse stx +;; [(_ field-name P key-expr value-expr on-add:on-add on-remove:on-remove) +;; (quasisyntax/loc stx +;; (let ((F field-name)) +;; (on (asserted P) #:priority *query-priority* +;; (let ((K key-expr) (V value-expr)) +;; (when (not (hashset-member? (F) K V)) +;; #,@(schedule-query-handler-stxs (attribute on-add.expr)) +;; (F (hashset-add (F) K V))))) +;; (on (retracted P) #:priority *query-priority-high* +;; (let ((K key-expr) (V value-expr)) +;; (when (hashset-member? (F) K V) +;; #,@(schedule-query-handler-stxs (attribute on-remove.expr)) +;; (F (hashset-remove (F) K V))))) +;; F))])) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Entering and Leaving Facet Context; Queueing of Work Items +;; (define-syntax (query-count stx) +;; (syntax-parse stx +;; [(_ field-name args ...) +;; (quasisyntax/loc stx +;; (let () +;; (field [field-name (hash)]) +;; (query-count* field-name args ...)))])) -(define-syntax-rule (with-current-facet fid in? body ...) - (parameterize ((current-facet-id fid) - (in-script? in?)) - body ...)) +;; (define-syntax (query-count* stx) +;; (syntax-parse stx +;; [(_ field-name P expr on-add:on-add on-remove:on-remove) +;; (quasisyntax/loc stx +;; (let ((F field-name)) +;; (on (asserted P) #:priority *query-priority* +;; (let ((E expr)) +;; #,@(schedule-query-handler-stxs (attribute on-add.expr)) +;; (F (hash-set (F) E (+ 1 (hash-ref (F) E 0)))))) +;; (on (retracted P) #:priority *query-priority-high* +;; (let ((E expr)) +;; #,@(schedule-query-handler-stxs (attribute on-remove.expr)) +;; (let ((F0 (F))) +;; (F (match (hash-ref F0 E 0) +;; [0 F0] ;; huh +;; [1 (hash-remove F0 E)] +;; [n (hash-set F0 E (- n 1))]))))) +;; F))])) -(define (capture-facet-context proc) - (let ((fid (current-facet-id))) - (lambda args - (with-current-facet fid #t - (call-with-syndicate-effects - (lambda () (apply proc args))))))) +;; (define-syntax-rule (define/query-value id ae P x ...) (define id (query-value id ae P x ...))) +;; (define-syntax-rule (define/query-set id P x ...) (define id (query-set id P x ...))) +;; (define-syntax-rule (define/query-hash id P x ...) (define id (query-hash id P x ...))) +;; (define-syntax-rule (define/query-hash-set id P x ...) (define id (query-hash-set id P x ...))) +;; (define-syntax-rule (define/query-count id P x ...) (define id (query-count id P x ...))) -(define (schedule-script! #:priority [priority *normal-priority*] thunk) - (push-script! priority (capture-facet-context thunk))) - -(define (push-script! priority thunk-with-context) - (define v (current-pending-scripts)) - (vector-set! v priority (enqueue (vector-ref v priority) thunk-with-context))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Action Queue Management - -(define (schedule-action! ac) - (if (patch? ac) - (when (patch-non-empty? ac) - (current-pending-patch (compose-patch ac (current-pending-patch)))) - (begin (flush-pending-patch!) - (current-pending-actions (list (current-pending-actions) - ((current-action-transformer) ac)))))) - -(define (schedule-actions! . acs) - (for [(ac (core:clean-actions acs))] (schedule-action! ac))) - -(define (flush-pending-patch!) - (define p (current-pending-patch)) - (when (patch-non-empty? p) - (current-pending-patch patch-empty) - (current-pending-actions (list (current-pending-actions) - ((current-action-transformer) p))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Endpoint Creation - -(define (add-endpoint! where patch-fn handler-fn) - (when (in-script?) - (error 'add-endpoint! - "~a: Cannot add endpoint in script; are you missing a (react ...)?" - where)) - (define-values (new-eid delta-aggregate) - (let () - (define a (current-actor-state)) - (define new-eid (mux-next-pid (actor-state-mux a))) - (define-values (new-mux _new-eid _delta delta-aggregate) - (mux-add-stream (actor-state-mux a) - (parameterize ((current-dataflow-subject-id - (list (current-facet-id) new-eid))) - (patch-fn)))) - (current-actor-state (struct-copy actor-state (current-actor-state) [mux new-mux])) - (values new-eid delta-aggregate))) - (update-facet! (current-facet-id) - (lambda (f) - (and f - (struct-copy facet f - [endpoints - (hash-set (facet-endpoints f) - new-eid - (endpoint new-eid patch-fn handler-fn))])))) - (schedule-action! delta-aggregate)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Facet Lifecycle - -(define next-fid-uid 0) -(define (add-facet! where setup-proc) - (when (not (in-script?)) - (error 'add-facet! - "~a: Cannot add facet outside script; are you missing an (on ...)?" - where)) - (define parent-fid (current-facet-id)) - (define fid-uid next-fid-uid) - (define fid (cons fid-uid parent-fid)) - (set! next-fid-uid (+ next-fid-uid 1)) - (update-facet! fid (lambda (_f) (facet fid (hasheqv) '() (set)))) - (update-facet! parent-fid - (lambda (pf) - (and pf (struct-copy facet pf - [children (set-add (facet-children pf) fid)])))) - (with-current-facet fid #f - (setup-proc) - (schedule-script! - (lambda () - (when (and (facet-live? fid) - (or (and (pair? parent-fid) (not (facet-live? parent-fid))) - (facet-live-but-inert? fid))) - (terminate-facet! fid))))) - (facet-handle-event! fid - (lookup-facet fid) - (patch (actor-state-knowledge (current-actor-state)) trie-empty) - #t)) - -;; If the named facet is live, terminate it. -(define (terminate-facet! fid) - (define f (lookup-facet fid)) - (when f - (define parent-fid (cdr fid)) - - (when (pair? parent-fid) - (update-facet! parent-fid - (lambda (f) - (and f - (struct-copy facet f - [children (set-remove (facet-children f) - fid)]))))) - - (store-facet! fid #f) - - (for [(child-fid (in-set (facet-children f)))] - (terminate-facet! child-fid)) - - ;; Run stop-scripts after terminating children. This means that - ;; children's stop-scripts run before ours. - (with-current-facet fid #t - (map schedule-script! (reverse (facet-stop-scripts f)))) - - (schedule-script! - (lambda () - (for [((eid ep) (in-hash (facet-endpoints f)))] - (define a (current-actor-state)) - (dataflow-forget-subject! (actor-state-field-dataflow a) (list fid eid)) - (define-values (new-mux _eid _delta delta-aggregate) - (mux-remove-stream (actor-state-mux a) eid)) - (current-actor-state (struct-copy actor-state a [mux new-mux])) - (schedule-action! delta-aggregate)))) - - (schedule-script! - #:priority *gc-priority* - (lambda () - (when (facet-live-but-inert? parent-fid) - (log-info "terminating ~v because it's dead and child ~v terminated" parent-fid fid) - (terminate-facet! parent-fid)))))) - -(define (add-stop-script! script-proc) - (update-facet! (current-facet-id) - (lambda (f) - (and f - (struct-copy facet f - [stop-scripts (cons script-proc (facet-stop-scripts f))]))))) - -(define (make-empty-pending-scripts) - (make-vector priority-count (make-queue))) - -(define (boot-actor script-proc) - (with-store [(current-actor-state - (actor-state (mux) - (hash) - trie-empty - trie-empty - (make-weak-hasheq) - (make-dataflow-graph))) - (current-pending-patch patch-empty) - (current-pending-actions '()) - (current-pending-scripts (make-empty-pending-scripts)) - (current-action-transformer values)] - (with-current-facet '() #f - (schedule-action! (core:retract ?)) - ;; Retract any initial-assertions we might have been given. We - ;; must ensure that we explicitly maintain them: retracting them - ;; here prevents us from accidentally relying on their - ;; persistence from our creation. - (schedule-script! script-proc) - (run-scripts!)))) - -(define (pop-next-script!) - (define priority-levels (current-pending-scripts)) - (let loop ((level 0)) - (and (< level (vector-length priority-levels)) - (let ((q (vector-ref priority-levels level))) - (if (queue-empty? q) - (loop (+ level 1)) - (let-values (((script q) (dequeue q))) - (vector-set! priority-levels level q) - script)))))) - -(define (run-all-pending-scripts!) - (define script (pop-next-script!)) - (when script - (script) - (refresh-facet-assertions!) - (run-all-pending-scripts!))) - -(define (run-scripts!) - (run-all-pending-scripts!) - (flush-pending-patch!) - (define pending-actions (current-pending-actions)) - (current-pending-actions '()) - (if (hash-empty? (actor-state-facets (current-actor-state))) - (core:quit pending-actions) - (core:transition (current-actor-state) pending-actions))) - -(define (refresh-facet-assertions!) - (dataflow-repair-damage! (actor-state-field-dataflow (current-actor-state)) - (lambda (subject-id) - (match-define (list fid eid) subject-id) - (define f (lookup-facet fid)) - (when f - (with-current-facet fid #f - (define ep (hash-ref (facet-endpoints f) eid)) - (define new-patch ((endpoint-patch-fn ep))) - (define a (current-actor-state)) - (define new-interests - (trie-subtract (patch-added new-patch) - (mux-interests-of (actor-state-mux a) eid) - #:combiner (lambda (v1 v2) trie-empty))) - (define newly-relevant-knowledge - (biased-intersection (actor-state-knowledge a) new-interests)) - (update-stream! eid (compose-patch new-patch (core:retract ?))) - (facet-handle-event! fid - (lookup-facet fid) - (patch newly-relevant-knowledge trie-empty) - #t)))))) - -(define (update-stream! eid patch) - (define a (current-actor-state)) - (define-values (new-mux _eid _delta delta-aggregate) - (mux-update-stream (actor-state-mux a) eid patch)) - (current-actor-state (struct-copy actor-state a [mux new-mux])) - (schedule-action! delta-aggregate)) - -(define (actor-behavior e a) - (and e - (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)) - (current-action-transformer values)] - (for [((fid f) (in-hash (actor-state-facets a)))] - (facet-handle-event! fid f e #f)) - (run-scripts!)))) - -(define (facet-handle-event! fid f e synthetic?) - (define mux (actor-state-mux (current-actor-state))) - (with-current-facet fid #f - (for [(ep (in-hash-values (facet-endpoints f)))] - ((endpoint-handler-fn ep) e (mux-interests-of mux (endpoint-id ep)) synthetic?)))) - -(module+ implementation-details - (provide actor-behavior - boot-actor - make-field - (struct-out field-descriptor) - (struct-out field-handle) - (struct-out actor-state) - (struct-out facet) - (struct-out endpoint) - - field-ref - field-set! - - suspend-script - suspend-script* - - capture-actor-actions)) +;; (define-syntax (immediate-query stx) +;; (syntax-case stx () +;; [(_ [op args ...] ...) +;; (with-syntax [((query-result ...) (generate-temporaries #'(op ...)))] +;; (syntax/loc stx +;; (react/suspend (k) +;; (define query-result (op query-result args ...)) ... +;; (on-start (flush!) (k (query-result) ...)))))])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Script suspend-and-resume. (define prompt-tag (make-continuation-prompt-tag 'syndicate)) -(define (syndicate-effects-available?) - (continuation-prompt-available? prompt-tag)) - (define (call-with-syndicate-effects thunk) (call-with-continuation-prompt thunk prompt-tag)) -(define (capture-actor-actions thunk) - (call-with-syndicate-effects - (lambda () - (with-store [(current-pending-actions '()) - (current-pending-patch patch-empty) - (current-action-transformer values)] - (call-with-values thunk - (lambda results - (flush-pending-patch!) - (when (> (length results) 1) - (error 'capture-actor-actions - "~a values supplied in top-level Syndicate action; more than one is unacceptable" - (length results))) - (cons results (current-pending-actions)))))))) - -(module+ for-module-begin - (provide capture-actor-actions)) - +;; TODO: this is completely bogus -- it's the old Syndicate/rkt implementation. Needs rewriting (define (suspend-script* where proc) (when (not (in-script?)) (error 'suspend-script @@ -1023,7 +580,7 @@ (abort-current-continuation prompt-tag (lambda () - (define suspended-fid (current-facet-id)) + (define suspended-f (current-facet)) (define in? (in-script?)) (define stale? #f) (define raw-resume-parent @@ -1040,88 +597,58 @@ (abort-current-continuation prompt-tag (lambda () - (let ((invoking-fid (current-facet-id))) - (when (not (equal? invoking-fid suspended-fid)) - (terminate-facet! invoking-fid))) - (push-script! *normal-priority* + (let ((invoking-f (current-facet))) + (when (not (eq? invoking-f suspended-f)) + (terminate-facet! (current-dataspace) invoking-f))) + (push-script! (current-dataspace) (lambda () (apply raw-resume-parent results))))))) (proc resume-parent)))) prompt-tag)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Immediate actions - -(define (ensure-in-script! who) - (when (not (in-script?)) - (error who "Attempt to perform action outside script; are you missing an (on ...)?"))) - -(define (send! M) - (ensure-in-script! 'send!) - (schedule-action! (core:message M))) - -(define *adhoc-label* -1) - -(define (assert! P) - (ensure-in-script! 'assert!) - (update-stream! *adhoc-label* (core:assert P))) - -(define (retract! P) - (ensure-in-script! 'retract!) - (update-stream! *adhoc-label* (core:retract P))) - -(define (patch! p) - (ensure-in-script! 'patch!) - (update-stream! *adhoc-label* p)) - -(define (perform-actions! acs) - (ensure-in-script! 'perform-actions!) - (for [(ac (core:clean-actions acs))] - (match ac - [(? patch? p) (update-stream! *adhoc-label* p)] - [_ (schedule-action! ac)]))) +(define (send! m) + (dataspace-send! (current-dataspace) m)) (define (flush!) (ensure-in-script! 'flush!) (define ack (gensym 'flush!)) - (until (core:message ack) - (on-start (send! ack)))) + (until (message ack) + (on-start (send! ack)))) -(define (quit-dataspace!) - (ensure-in-script! 'quit-dataspace!) - (schedule-action! (core:quit-dataspace))) +;;--------------------------------------------------------------------------- -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(module+ test + (message-struct set-box (new-value)) + (assertion-struct box-state (value)) -(define (format-field-descriptor d) - (match-define (field-descriptor name id) d) - (format "~a/~a" name id)) + (define ds + (make-dataspace + 'ground + (lambda () + (schedule-script! + (current-dataspace) + (lambda () + (spawn (field [current-value 0]) + (assert (box-state (current-value))) + (stop-when-true (= (current-value) 10) + (log-info "box: terminating")) + (on (message (set-box $new-value)) + (log-info "box: taking on new-value ~v" new-value) + (current-value new-value))) -(define (pretty-print-actor-state a p) - (match-define (actor-state mux facets _ knowledge field-table dfg) a) - (fprintf p "ACTOR:\n") - (fprintf p " - ") - (display (indented-port-output 3 (lambda (p) (syndicate-pretty-print mux p)) #:first-line? #f) p) - (newline p) - (fprintf p " - Knowledge:\n ~a" (trie->pretty-string knowledge #:indent 3)) - (fprintf p " - Facets:\n") - (for ([(fid f) (in-hash facets)]) - (match-define (facet _fid endpoints _ children) f) - (fprintf p " ---- facet ~a, children=~a" fid (set->list children)) - (when (not (hash-empty? endpoints)) - (fprintf p ", endpoints=~a" (hash-keys endpoints))) - (newline p)) - (when (not (hash-empty? field-table)) - (fprintf p " - Fields:\n") - (for ([(d ve) (in-hash field-table)]) - (define subject-ids (hash-ref (dataflow-graph-edges-forward dfg) d set)) - (define v (ephemeron-value ve)) - (define v* - (indented-port-output 6 (lambda (p) (syndicate-pretty-print v p)) #:first-line? #f)) - (if (set-empty? subject-ids) - (fprintf p " - ~a: ~a\n" (format-field-descriptor d) v*) - (fprintf p " - ~a: ~a ~a\n" - (format-field-descriptor d) - (for/list [(subject-id subject-ids)] - (match-define (list fid eid) subject-id) - (format "~a:~a" fid eid)) - v*))))) + (spawn (stop-when (retracted (observe (set-box _))) + (log-info "client: box has gone")) + (on (asserted (box-state $v)) + (log-info "client: learned that box's value is now ~v" v) + (send! (set-box (+ v 1))))) + ))))) + + (require racket/pretty) + ;; (pretty-print ds) + (#;time values + (let loop ((i 0)) + ;; (printf "--- i = ~v\n" i) + (when (run-scripts! ds) + ;; (pretty-print ds) + (loop (+ i 1))))) + ;; (pretty-print ds) + )