From 53efb1fcd4d2208804a23f2f903739f20e671e3f Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 13 Jul 2016 16:34:16 -0400 Subject: [PATCH] Refine script priorities for use by track-set and friends --- racket/syndicate/actor.rkt | 71 +++++++++++++++---- racket/syndicate/examples/actor/track-set.rkt | 6 +- 2 files changed, 60 insertions(+), 17 deletions(-) diff --git a/racket/syndicate/actor.rkt b/racket/syndicate/actor.rkt index 98d3cb7..31c70ce 100644 --- a/racket/syndicate/actor.rkt +++ b/racket/syndicate/actor.rkt @@ -106,6 +106,36 @@ (struct endpoint (id patch-fn handler-fn) #:prefab) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Script priorities. These are used to ensure that the results of +;; some *side effects* are visible to certain pieces of code. + +(module priorities racket/base + (require (for-syntax racket/base)) + + (define-syntax (define-priority-levels stx) + (let loop ((counter 0) (stx (syntax-case stx () + [(_ level ...) #'(level ...)]))) + (syntax-case stx () + [() + #'(void)] + [(#:count c) + #`(begin (define c #,counter) + (provide c))] + [(this-level more ...) + #`(begin (define this-level #,counter) + (provide this-level) + #,(loop (+ counter 1) #'(more ...)))]))) + + (define-priority-levels ;; highest-priority to lowest-priority + *track-priority* + *track-handler-priority* + *normal-priority* + *rising-edge-priority* + #:count priority-count)) + +(require (submod "." priorities)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Parameters. Many of these are *updated* during facet execution! @@ -125,7 +155,7 @@ (define current-pending-actions (make-parameter '())) (define (make-empty-pending-scripts) - (vector '() '())) + (make-vector priority-count '())) ;; Parameterof (Vector (List Script) (List Script)) (define current-pending-scripts (make-parameter (make-empty-pending-scripts))) @@ -147,7 +177,11 @@ (define-splicing-syntax-class meta-level (pattern (~seq #:meta-level level:integer)) - (pattern (~seq) #:attr level #'0))) + (pattern (~seq) #:attr level #'0)) + + (define-splicing-syntax-class priority + (pattern (~seq #:priority level)) + (pattern (~seq) #:attr level #'*normal-priority*))) (define-syntax (actor stx) (syntax-parse stx @@ -230,8 +264,8 @@ (define-syntax (stop-when stx) (syntax-parse stx - [(_ E script ...) - (analyze-event stx #'E #t (syntax/loc stx (begin/void-default script ...)))])) + [(_ E prio:priority script ...) + (analyze-event stx #'E #t (syntax/loc stx (begin/void-default script ...)) #'prio.level)])) (define-syntax (on-start stx) (syntax-parse stx @@ -254,7 +288,7 @@ (core:match-event e clause ...))))])) -(define (on-event* where proc #:priority [priority 0]) +(define (on-event* where proc #:priority [priority *normal-priority*]) (add-endpoint! where (lambda () patch-empty) (lambda (e) @@ -262,8 +296,8 @@ (define-syntax (on stx) (syntax-parse stx - [(_ E script ...) - (analyze-event stx #'E #f (syntax/loc stx (begin/void-default script ...)))])) + [(_ E prio:priority script ...) + (analyze-event stx #'E #f (syntax/loc stx (begin/void-default script ...)) #'prio.level)])) (define-syntax (during stx) (syntax-parse stx @@ -324,7 +358,8 @@ script-stx asserted? P-stx - meta-level) + meta-level + 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?)) @@ -352,6 +387,7 @@ (let ((instantiated (instantiate-projection proj entry))) (and (#,change-detector-stx instantiated) (schedule-script! + #:priority #,priority-stx #,(if terminal? #'#t #'#f) (lambda () (match-define (list #,@bindings) entry) @@ -375,7 +411,7 @@ stx #`(at-meta #,(prepend-at-meta-stx stx (- level 1))))) -(define-for-syntax (analyze-event outer-expr-stx event-stx terminal? script-stx) +(define-for-syntax (analyze-event outer-expr-stx event-stx terminal? script-stx priority-stx) (syntax-parse event-stx #:literals [core:message asserted retracted rising-edge] [(core:message P L:meta-level) @@ -393,14 +429,17 @@ #,(prepend-at-meta-stx proj (syntax-e #'L.level)))) (and capture-vals (schedule-script! + #:priority #,priority-stx #,(if terminal? #'#t #'#f) (lambda () (apply (lambda #,bindings #,script-stx) capture-vals))))]))))] [(asserted P L:meta-level) - (analyze-asserted/retracted outer-expr-stx event-stx terminal? script-stx #t #'P #'L.level)] + (analyze-asserted/retracted outer-expr-stx event-stx terminal? script-stx + #t #'P #'L.level priority-stx)] [(retracted P L:meta-level) - (analyze-asserted/retracted outer-expr-stx event-stx terminal? script-stx #f #'P #'L.level)] + (analyze-asserted/retracted outer-expr-stx event-stx terminal? script-stx + #f #'P #'L.level priority-stx)] [(rising-edge Pred) (define field-name (format "~a:rising-edge" (source-location->string event-stx))) (quasisyntax/loc outer-expr-stx @@ -413,9 +452,10 @@ (when (not (eq? old-val new-val)) (edge-state new-val) (when new-val - (schedule-script! #,(if terminal? #'#t #'#f) + (schedule-script! #:priority #,priority-stx + #,(if terminal? #'#t #'#f) (lambda () #,script-stx))))) - #:priority 1)))])) + #:priority *rising-edge-priority*)))])) (define-syntax (begin/void-default stx) (syntax-parse stx @@ -489,7 +529,7 @@ (lambda () (apply proc args)) prompt-tag))))) -(define (schedule-script! #:priority [priority 0] terminal? thunk) +(define (schedule-script! #:priority [priority *normal-priority*] terminal? thunk) (if terminal? (let ((f (terminate-facet! (current-facet-id)))) (when f ;; only want to run a terminal script if we genuinely terminated @@ -730,7 +770,8 @@ (let ((invoking-fid (current-facet-id))) (when (not (equal? invoking-fid suspended-fid)) (terminate-facet! invoking-fid))) - (push-script! 0 (lambda () (apply raw-resume-parent results))))))) + (push-script! *normal-priority* + (lambda () (apply raw-resume-parent results))))))) (proc resume-parent)))) prompt-tag)) diff --git a/racket/syndicate/examples/actor/track-set.rkt b/racket/syndicate/examples/actor/track-set.rkt index ad0322c..e6ba410 100644 --- a/racket/syndicate/examples/actor/track-set.rkt +++ b/racket/syndicate/examples/actor/track-set.rkt @@ -2,11 +2,13 @@ (require racket/set) +(require (submod syndicate/actor priorities)) + (define-syntax-rule (track-set field-name P expr) (let () (field [field-name (set)]) - (on (asserted P) (field-name (set-add (field-name) expr))) - (on (retracted P) (field-name (set-remove (field-name) expr))) + (on (asserted P) #:priority *track-priority* (field-name (set-add (field-name) expr))) + (on (retracted P) #:priority *track-priority* (field-name (set-remove (field-name) expr))) field-name)) (define-syntax-rule (track-hash field-name P key-expr value-expr)