Refine script priorities for use by track-set and friends
This commit is contained in:
parent
be80ac038f
commit
53efb1fcd4
|
@ -106,6 +106,36 @@
|
||||||
|
|
||||||
(struct endpoint (id patch-fn handler-fn) #:prefab)
|
(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!
|
;; Parameters. Many of these are *updated* during facet execution!
|
||||||
|
|
||||||
|
@ -125,7 +155,7 @@
|
||||||
(define current-pending-actions (make-parameter '()))
|
(define current-pending-actions (make-parameter '()))
|
||||||
|
|
||||||
(define (make-empty-pending-scripts)
|
(define (make-empty-pending-scripts)
|
||||||
(vector '() '()))
|
(make-vector priority-count '()))
|
||||||
|
|
||||||
;; Parameterof (Vector (List Script) (List Script))
|
;; Parameterof (Vector (List Script) (List Script))
|
||||||
(define current-pending-scripts (make-parameter (make-empty-pending-scripts)))
|
(define current-pending-scripts (make-parameter (make-empty-pending-scripts)))
|
||||||
|
@ -147,7 +177,11 @@
|
||||||
|
|
||||||
(define-splicing-syntax-class meta-level
|
(define-splicing-syntax-class meta-level
|
||||||
(pattern (~seq #:meta-level level:integer))
|
(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)
|
(define-syntax (actor stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
|
@ -230,8 +264,8 @@
|
||||||
|
|
||||||
(define-syntax (stop-when stx)
|
(define-syntax (stop-when stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ E script ...)
|
[(_ E prio:priority script ...)
|
||||||
(analyze-event stx #'E #t (syntax/loc stx (begin/void-default script ...)))]))
|
(analyze-event stx #'E #t (syntax/loc stx (begin/void-default script ...)) #'prio.level)]))
|
||||||
|
|
||||||
(define-syntax (on-start stx)
|
(define-syntax (on-start stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
|
@ -254,7 +288,7 @@
|
||||||
(core:match-event e
|
(core:match-event e
|
||||||
clause ...))))]))
|
clause ...))))]))
|
||||||
|
|
||||||
(define (on-event* where proc #:priority [priority 0])
|
(define (on-event* where proc #:priority [priority *normal-priority*])
|
||||||
(add-endpoint! where
|
(add-endpoint! where
|
||||||
(lambda () patch-empty)
|
(lambda () patch-empty)
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
|
@ -262,8 +296,8 @@
|
||||||
|
|
||||||
(define-syntax (on stx)
|
(define-syntax (on stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ E script ...)
|
[(_ E prio:priority script ...)
|
||||||
(analyze-event stx #'E #f (syntax/loc stx (begin/void-default script ...)))]))
|
(analyze-event stx #'E #f (syntax/loc stx (begin/void-default script ...)) #'prio.level)]))
|
||||||
|
|
||||||
(define-syntax (during stx)
|
(define-syntax (during stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
|
@ -324,7 +358,8 @@
|
||||||
script-stx
|
script-stx
|
||||||
asserted?
|
asserted?
|
||||||
P-stx
|
P-stx
|
||||||
meta-level)
|
meta-level
|
||||||
|
priority-stx)
|
||||||
(define-values (proj-stx pat bindings _instantiated)
|
(define-values (proj-stx pat bindings _instantiated)
|
||||||
(analyze-pattern event-stx P-stx))
|
(analyze-pattern event-stx P-stx))
|
||||||
(define event-predicate-stx (if asserted? #'patch/added? #'patch/removed?))
|
(define event-predicate-stx (if asserted? #'patch/added? #'patch/removed?))
|
||||||
|
@ -352,6 +387,7 @@
|
||||||
(let ((instantiated (instantiate-projection proj entry)))
|
(let ((instantiated (instantiate-projection proj entry)))
|
||||||
(and (#,change-detector-stx instantiated)
|
(and (#,change-detector-stx instantiated)
|
||||||
(schedule-script!
|
(schedule-script!
|
||||||
|
#:priority #,priority-stx
|
||||||
#,(if terminal? #'#t #'#f)
|
#,(if terminal? #'#t #'#f)
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(match-define (list #,@bindings) entry)
|
(match-define (list #,@bindings) entry)
|
||||||
|
@ -375,7 +411,7 @@
|
||||||
stx
|
stx
|
||||||
#`(at-meta #,(prepend-at-meta-stx stx (- level 1)))))
|
#`(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
|
(syntax-parse event-stx
|
||||||
#:literals [core:message asserted retracted rising-edge]
|
#:literals [core:message asserted retracted rising-edge]
|
||||||
[(core:message P L:meta-level)
|
[(core:message P L:meta-level)
|
||||||
|
@ -393,14 +429,17 @@
|
||||||
#,(prepend-at-meta-stx proj (syntax-e #'L.level))))
|
#,(prepend-at-meta-stx proj (syntax-e #'L.level))))
|
||||||
(and capture-vals
|
(and capture-vals
|
||||||
(schedule-script!
|
(schedule-script!
|
||||||
|
#:priority #,priority-stx
|
||||||
#,(if terminal? #'#t #'#f)
|
#,(if terminal? #'#t #'#f)
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(apply (lambda #,bindings #,script-stx)
|
(apply (lambda #,bindings #,script-stx)
|
||||||
capture-vals))))]))))]
|
capture-vals))))]))))]
|
||||||
[(asserted P L:meta-level)
|
[(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)
|
[(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)
|
[(rising-edge Pred)
|
||||||
(define field-name (format "~a:rising-edge" (source-location->string event-stx)))
|
(define field-name (format "~a:rising-edge" (source-location->string event-stx)))
|
||||||
(quasisyntax/loc outer-expr-stx
|
(quasisyntax/loc outer-expr-stx
|
||||||
|
@ -413,9 +452,10 @@
|
||||||
(when (not (eq? old-val new-val))
|
(when (not (eq? old-val new-val))
|
||||||
(edge-state new-val)
|
(edge-state new-val)
|
||||||
(when new-val
|
(when new-val
|
||||||
(schedule-script! #,(if terminal? #'#t #'#f)
|
(schedule-script! #:priority #,priority-stx
|
||||||
|
#,(if terminal? #'#t #'#f)
|
||||||
(lambda () #,script-stx)))))
|
(lambda () #,script-stx)))))
|
||||||
#:priority 1)))]))
|
#:priority *rising-edge-priority*)))]))
|
||||||
|
|
||||||
(define-syntax (begin/void-default stx)
|
(define-syntax (begin/void-default stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
|
@ -489,7 +529,7 @@
|
||||||
(lambda () (apply proc args))
|
(lambda () (apply proc args))
|
||||||
prompt-tag)))))
|
prompt-tag)))))
|
||||||
|
|
||||||
(define (schedule-script! #:priority [priority 0] terminal? thunk)
|
(define (schedule-script! #:priority [priority *normal-priority*] terminal? thunk)
|
||||||
(if terminal?
|
(if terminal?
|
||||||
(let ((f (terminate-facet! (current-facet-id))))
|
(let ((f (terminate-facet! (current-facet-id))))
|
||||||
(when f ;; only want to run a terminal script if we genuinely terminated
|
(when f ;; only want to run a terminal script if we genuinely terminated
|
||||||
|
@ -730,7 +770,8 @@
|
||||||
(let ((invoking-fid (current-facet-id)))
|
(let ((invoking-fid (current-facet-id)))
|
||||||
(when (not (equal? invoking-fid suspended-fid))
|
(when (not (equal? invoking-fid suspended-fid))
|
||||||
(terminate-facet! invoking-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))))
|
(proc resume-parent))))
|
||||||
prompt-tag))
|
prompt-tag))
|
||||||
|
|
||||||
|
|
|
@ -2,11 +2,13 @@
|
||||||
|
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
|
|
||||||
|
(require (submod syndicate/actor priorities))
|
||||||
|
|
||||||
(define-syntax-rule (track-set field-name P expr)
|
(define-syntax-rule (track-set field-name P expr)
|
||||||
(let ()
|
(let ()
|
||||||
(field [field-name (set)])
|
(field [field-name (set)])
|
||||||
(on (asserted P) (field-name (set-add (field-name) expr)))
|
(on (asserted P) #:priority *track-priority* (field-name (set-add (field-name) expr)))
|
||||||
(on (retracted P) (field-name (set-remove (field-name) expr)))
|
(on (retracted P) #:priority *track-priority* (field-name (set-remove (field-name) expr)))
|
||||||
field-name))
|
field-name))
|
||||||
|
|
||||||
(define-syntax-rule (track-hash field-name P key-expr value-expr)
|
(define-syntax-rule (track-hash field-name P key-expr value-expr)
|
||||||
|
|
Loading…
Reference in New Issue