From 37bd64bf05b2882d65bc02edbe31a63430fa0050 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 1 Jun 2021 10:04:10 +0200 Subject: [PATCH] First attempt at novy syntax --- .../event-expander.rkt | 0 syndicate/go.rkt | 116 +++++----- syndicate/info.rkt | 2 + syndicate/syntax.rkt | 204 ++++++++++++++++++ 4 files changed, 262 insertions(+), 60 deletions(-) rename {OLD-syndicate => syndicate}/event-expander.rkt (100%) create mode 100644 syndicate/syntax.rkt diff --git a/OLD-syndicate/event-expander.rkt b/syndicate/event-expander.rkt similarity index 100% rename from OLD-syndicate/event-expander.rkt rename to syndicate/event-expander.rkt diff --git a/syndicate/go.rkt b/syndicate/go.rkt index 35f04a4..03c585c 100644 --- a/syndicate/go.rkt +++ b/syndicate/go.rkt @@ -3,69 +3,67 @@ (require racket/match) (require preserves) -(require "main.rkt") +(require (except-in "main.rkt" actor-system)) (require "bag.rkt") (require "schemas/gen/box-protocol.rkt") (require "schemas/gen/dataspace.rkt") -(define ((box ds LIMIT REPORT_EVERY) turn) - (define value (turn-field! turn 'box-value 0)) - (turn-assert/dataflow! turn ds (lambda (turn) (BoxState->preserves (BoxState (value))))) - (define start-time (current-inexact-milliseconds)) - (define prev-value 0) - (turn-assert! turn ds - (Observe->preserves - (Observe 'SetBox - (turn-ref turn - (entity #:message - (lambda (turn new-value-rec) - (define new-value (SetBox-value new-value-rec)) - (when (zero? (remainder new-value REPORT_EVERY)) - (define end-time (current-inexact-milliseconds)) - (define delta (/ (- end-time start-time) 1000.0)) - (define count (- new-value prev-value)) - (set! prev-value new-value) - (set! start-time end-time) - (log-info "Box got ~a (~a Hz)" - new-value - (/ count delta))) - (when (= new-value LIMIT) - (turn-stop-actor! turn)) - (value new-value)))))))) +(require "syntax.rkt") -(define ((client ds) turn) - (turn-assert! turn ds - (Observe->preserves - (Observe 'BoxState - (turn-ref turn - (entity #:assert - (lambda (turn current-value _handle) - ;; (log-info "Client got ~a" current-value) - (turn-message! turn ds - (SetBox->preserves - (SetBox - (+ (BoxState-value current-value) - 1)))))))))) - (let ((count 0)) - (turn-assert! turn ds - (Observe->preserves - (Observe 'BoxState - (turn-ref turn - (entity #:assert - (lambda (turn current-value _handle) +(define box + (action (ds LIMIT REPORT_EVERY) + (spawn (define root-facet this-facet) + (define-field value 0) + (define start-time (current-inexact-milliseconds)) + (define prev-value 0) + (at ds + (assert (BoxState->preserves (BoxState (value)))) + (when (message (SetBox new-value)) + (when (zero? (remainder new-value REPORT_EVERY)) + (define end-time (current-inexact-milliseconds)) + (define delta (/ (- end-time start-time) 1000.0)) + (define count (- new-value prev-value)) + (set! prev-value new-value) + (set! start-time end-time) + (log-info "Box got ~a (~a Hz)" new-value (/ count delta))) + (when (= new-value LIMIT) + (stop-facet root-facet)) + (value new-value)))))) + +(define client + (action (ds) + (spawn (define root-facet this-facet) + (define count 0) + (at ds + (when (asserted (BoxState value)) + (send! ds (SetBox->preserves (SetBox (+ value 1))))) + ;; (during (BoxState _) + ;; (on-start (set! count (+ count 1))) + ;; (on-stop (set! count (- count 1)) + ;; (when (zero? count) + ;; (log-info "Client detected box termination") + ;; (stop-facet root-facet)))) + (assert (Observe->preserves + (Observe 'BoxState + (ref (entity #:assert + (action (_v _h) (set! count (+ count 1))) #:retract - (lambda (turn _handle) + (action (_h) (set! count (- count 1)) (when (zero? count) (log-info "Client detected box termination") - (turn-stop-actor! turn)))))))))) + (stop-facet root-facet)))))))) + ;; (during (BoxState _) + ;; (on-stop (log-info "Client detected box termination") + ;; (stop-facet root-facet))) + )))) (define (dataspace) (define handles (make-hash)) (define assertions (make-bag)) (define subscriptions (make-hash)) - (entity #:assert (lambda (turn rec handle) + (entity #:assert (action (rec handle) (when (record? rec) (hash-set! handles handle rec) (when (eq? (bag-change! assertions rec +1) 'absent->present) @@ -76,17 +74,17 @@ (hash-set! (hash-ref! subscriptions label make-hasheq) observer seen) (for [(existing (in-bag assertions))] (when (preserve=? (record-label existing) label) - (hash-set! seen existing (turn-assert! turn observer existing))))]) + (hash-set! seen existing (turn-assert! this-turn observer existing))))]) (for [((observer seen) (in-hash (hash-ref subscriptions (record-label rec) '#hash())))] (unless (hash-has-key? seen rec) - (hash-set! seen rec (turn-assert! turn observer rec))))))) - #:retract (lambda (turn upstream-handle) + (hash-set! seen rec (turn-assert! this-turn observer rec))))))) + #:retract (action (upstream-handle) (define rec (hash-ref handles upstream-handle #f)) (when rec (hash-remove! handles upstream-handle) (when (eq? (bag-change! assertions rec -1) 'present->absent) (for [(seen (in-hash-values (hash-ref subscriptions (record-label rec) '#hash())))] - (turn-retract! turn (hash-ref seen rec)) + (turn-retract! this-turn (hash-ref seen rec)) (hash-remove! seen rec)) (match (parse-Observe rec) [(? eof-object?) (void)] @@ -95,17 +93,15 @@ (hash-remove! subscribers observer) (when (hash-empty? subscribers) (hash-remove! subscriptions label)))])))) - #:message (lambda (turn message) + #:message (action (message) (when (record? message) (for [(peer (in-hash-keys (hash-ref subscriptions (record-label message) '#hash())))] - (turn-message! turn peer message)))))) + (turn-message! this-turn peer message)))))) (module+ main (time (actor-system - (lambda (turn) - (actor-daemon! (facet-actor (turn-active-facet turn)) #t) - (define disarm (facet-prevent-inert-check! (turn-active-facet turn))) - (define ds (turn-ref turn (dataspace))) - (turn-spawn! turn (box ds 500000 100000)) - (turn-spawn! turn (client ds)))))) + (define disarm (facet-prevent-inert-check! this-facet)) + (define ds (ref (dataspace))) + (box this-turn ds 500000 100000) + (client this-turn ds)))) diff --git a/syndicate/info.rkt b/syndicate/info.rkt index 2de0fc1..a41d18d 100644 --- a/syndicate/info.rkt +++ b/syndicate/info.rkt @@ -4,6 +4,8 @@ (define deps '( "base" + + "auxiliary-macro-context" "preserves" "struct-defaults" diff --git a/syndicate/syntax.rkt b/syndicate/syntax.rkt new file mode 100644 index 0000000..2097ebc --- /dev/null +++ b/syndicate/syntax.rkt @@ -0,0 +1,204 @@ +#lang racket/base + +(provide this-turn + this-facet + this-actor + + action + + entity + actor-system + + with-fresh-turn + ref + react + define-field + stop-facet + stop-current-facet + on-start + on-stop + sync! + send! + spawn + + begin/dataflow + define/dataflow + + this-target + at + assert + (rename-out [event:when when]) + during) + +(require racket/match) +(require racket/stxparam) +(require (for-syntax racket/base)) +(require (for-syntax racket/syntax)) + +(require "actor.rkt") +(require (prefix-in actor: "actor.rkt")) + +(require "event-expander.rkt") + +(define-syntax-parameter this-turn + (lambda (stx) + (raise-syntax-error #f "Illegal use outside an Actor turn" stx))) + +(define-syntax-rule (with-this-turn id expr ...) + (syntax-parameterize ([this-turn (make-rename-transformer #'id)]) + expr ...)) + +(define-syntax this-facet + (syntax-id-rules () + [_ (turn-active-facet this-turn)])) + +(define-syntax this-actor + (syntax-id-rules () + [_ (facet-actor this-facet)])) + +(define-syntax-rule (action formals expr ...) + (lambda (turn . formals) + (with-this-turn turn expr ...))) + +(define-syntax-rule (actor-system expr ...) + (actor:actor-system (action () expr ...))) + +(define-syntax-rule (with-fresh-turn expr ...) + (turn-freshen this-turn (action () expr ...))) + +(define-syntax-rule (ref e) + (turn-ref this-turn e)) + +(define-syntax-rule (react setup-expr ...) + (turn-facet! this-turn (action () setup-expr ...))) + +(define-syntax-rule (define-field id initial-value) + (define id (turn-field! this-turn 'id initial-value))) + +(define-syntax stop-facet + (syntax-rules () + [(_ f) (turn-stop! this-turn f)] + [(_ f expr ...) (turn-stop! this-turn f (action () expr ...))])) + +(define-syntax-rule (stop-current-facet expr ...) + (stop-facet this-facet expr ...)) + +(define-syntax-rule (on-start expr ...) + ;; TODO: delay to end of turn (?) + (begin expr ...)) + +(define-syntax-rule (on-stop expr ...) + (facet-on-stop! this-facet (action () expr ...))) + +(define-syntax-rule (sync! peer expr ...) + (turn-sync! this-turn peer (action (_reply) expr ...))) + +(define-syntax-rule (send! peer assertion) + (turn-message! this-turn peer assertion)) + +(define-syntax-rule (spawn setup-expr ...) + (turn-spawn! this-turn (action () setup-expr ...))) + +(define-syntax-rule (begin/dataflow expr ...) + (turn-dataflow! this-turn (action () expr ...))) + +(define-syntax-rule (define/dataflow id expr) + (begin (define-field id #f) + (begin/dataflow (id expr)))) + +;;--------------------------------------------------------------------------- + +(define-for-syntax orig-insp + (variable-reference->module-declaration-inspector (#%variable-reference))) + +(define-syntax-parameter this-target + (lambda (stx) + (raise-syntax-error #f "Illegal use outside an Actor turn" stx))) + +(define-syntax (at stx) + (syntax-case stx () + [(_ target-expr items ...) + #`(let ((target target-expr)) + (syntax-parameterize ([this-target (make-rename-transformer #'target)]) + #,@(for/list [(item-stx (in-list (syntax->list #'(items ...))))] + (let loop ((item-stx item-stx)) + (define disarmed-item-stx (syntax-disarm item-stx orig-insp)) + (syntax-case disarmed-item-stx () + [(expander args ...) + (event-expander-id? #'expander) + (event-expander-transform disarmed-item-stx + (lambda (r) (loop (syntax-rearm r item-stx))))] + [_ + item-stx])))))])) + +(define-event-expander assert + (syntax-rules () + [(_ expr) + (turn-assert/dataflow! this-turn this-target (action () expr))])) + +(require "schemas/gen/dataspace.rkt") + +(define-event-expander event:when + (lambda (stx) + (syntax-case stx (message asserted) + [(_ (message (label fields ...)) expr ...) + #`(assert (Observe->preserves + (Observe 'label + (ref (entity #:message + (action (rec) + (match (#,(format-id #'label "parse-~a" (syntax-e #'label)) rec) + [(? eof-object?) (void)] + [(label fields ...) + expr ...])))))))] + [(_ (asserted (label fields ...)) expr ...) + #`(assert (Observe->preserves + (Observe 'label + (ref (entity #:assert + (action (rec handle) + (match (#,(format-id #'label "parse-~a" (syntax-e #'label)) rec) + [(? eof-object?) (void)] + [(label fields ...) + expr ...])))))))])) + (syntax-rules () + [(_ test expr ...) + (when test expr ...)])) + +(define-event-expander during + (lambda (stx) + (syntax-case stx () + [(_ (label fields ...) expr ...) + #`(assert (Observe->preserves + (Observe 'label + (ref (let ((assertion-map (make-hash))) + (entity #:assert + (action (rec handle) + (match (#,(format-id #'label "parse-~a" (syntax-e #'label)) rec) + [(? eof-object?) (void)] + [(label fields ...) + (let ((facet (react + (facet-prevent-inert-check! this-facet) + expr ...))) + (match (hash-ref assertion-map handle #f) + [#f + (hash-set! assertion-map handle facet)] + ['dead + (hash-remove! assertion-map handle) + (stop-facet facet)] + [_ + (error 'during "Duplicate assertion handle ~a" handle)]))])) + #:retract + (action (handle) + (match (hash-ref assertion-map handle #f) + [#f + (hash-set! assertion-map handle 'dead)] + ['dead + (error 'during "Duplicate retraction handle ~a" handle)] + [facet + (hash-remove! assertion-map handle) + (stop-facet facet)]))))))))]))) + +;;--------------------------------------------------------------------------- +;;; Local Variables: +;;; eval: (put 'action 'scheme-indent-function 1) +;;; eval: (put 'action 'racket-indent-function 1) +;;; End: