diff --git a/racket/syndicate/actor.rkt b/racket/syndicate/actor.rkt index 15abb9d..de2c250 100644 --- a/racket/syndicate/actor.rkt +++ b/racket/syndicate/actor.rkt @@ -64,6 +64,7 @@ (require "trie.rkt") (require "pattern.rkt") (require "dataflow.rkt") +(require "support/hash.rkt") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Data Definitions and Structures @@ -506,10 +507,7 @@ (define a (current-actor-state)) (current-actor-state (struct-copy actor-state a - [facets - (if new-facet - (hash-set (actor-state-facets a) fid new-facet) - (hash-remove (actor-state-facets a) fid))]))) + [facets (hash-set/remove (actor-state-facets a) fid new-facet)]))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Entering and Leaving Facet Context; Queueing of Work Items diff --git a/racket/syndicate/dataflow.rkt b/racket/syndicate/dataflow.rkt index b26b08d..db6d62d 100644 --- a/racket/syndicate/dataflow.rkt +++ b/racket/syndicate/dataflow.rkt @@ -12,6 +12,7 @@ dataflow-repair-damage!) (require racket/set) +(require "support/hash.rkt") (struct dataflow-graph (edges-forward ;; object-id -> (Setof subject-id) edges-reverse ;; subject-id -> (Setof object-id) @@ -26,25 +27,13 @@ (hash) (set))) -(define (hash-set-add ht k v [set-ctor set]) - (hash-set ht k (set-add (hash-ref ht k set-ctor) v))) - -(define (hash-set-remove ht k v) - (define old (hash-ref ht k #f)) - (if old - (let ((new (set-remove old v))) - (if (set-empty? new) - (hash-remove ht k) - (hash-set ht k new))) - ht)) - (define (dataflow-record-observation! g object-id) (define subject-id (current-dataflow-subject-id)) (when subject-id (define fwd (dataflow-graph-edges-forward g)) - (set-dataflow-graph-edges-forward! g (hash-set-add fwd object-id subject-id)) + (set-dataflow-graph-edges-forward! g (hashset-add fwd object-id subject-id)) (define rev (dataflow-graph-edges-reverse g)) - (set-dataflow-graph-edges-reverse! g (hash-set-add rev subject-id object-id)))) + (set-dataflow-graph-edges-reverse! g (hashset-add rev subject-id object-id)))) (define (dataflow-record-damage! g object-id) (set-dataflow-graph-damaged-nodes! g (set-add (dataflow-graph-damaged-nodes g) object-id))) @@ -55,7 +44,7 @@ (set-dataflow-graph-edges-reverse! g (hash-remove rev subject-id)) (for [(object-id (in-set subject-objects))] (define fwd (dataflow-graph-edges-forward g)) - (set-dataflow-graph-edges-forward! g (hash-set-remove fwd object-id subject-id)))) + (set-dataflow-graph-edges-forward! g (hashset-remove fwd object-id subject-id)))) (define (dataflow-repair-damage! g repair-node!) (define repaired-this-round (set)) diff --git a/racket/syndicate/demand-matcher.rkt b/racket/syndicate/demand-matcher.rkt index f7a95d4..dbcfe2e 100644 --- a/racket/syndicate/demand-matcher.rkt +++ b/racket/syndicate/demand-matcher.rkt @@ -6,6 +6,7 @@ (require "core.rkt") (require "drivers/timer.rkt") (require "pretty.rkt") +(require "support/hash.rkt") (provide (except-out (struct-out demand-matcher) demand-matcher) (rename-out [make-demand-matcher demand-matcher]) @@ -179,9 +180,7 @@ start-task on-task-exit actions)) - (values (if new-supervision-state - (hash-set supervision-states captures new-supervision-state) - (hash-remove supervision-states captures)) + (values (hash-set/remove supervision-states captures new-supervision-state) (cons actions new-actions)))) (transition (struct-copy demand-matcher d diff --git a/racket/syndicate/examples/actor/query-set.rkt b/racket/syndicate/examples/actor/query-set.rkt index 807df36..5f27532 100644 --- a/racket/syndicate/examples/actor/query-set.rkt +++ b/racket/syndicate/examples/actor/query-set.rkt @@ -1,45 +1,40 @@ #lang syndicate/actor (require racket/set) +(require syndicate/support/hash) (require (submod syndicate/actor priorities)) (define-syntax-rule (query-set field-name P expr) (let () (field [field-name (set)]) - (on (asserted P) #:priority *query-priority* (field-name (set-add (field-name) expr))) - (on (retracted P) #:priority *query-priority* (field-name (set-remove (field-name) expr))) + (on (asserted P) #:priority *query-priority* + (field-name (set-add (field-name) expr))) + (on (retracted P) #:priority *query-priority* + (field-name (set-remove (field-name) expr))) field-name)) (define-syntax-rule (query-hash field-name P key-expr value-expr) (let () (field [field-name (hash)]) - (on (asserted P) + (on (asserted P) #:priority *query-priority* (let ((key key-expr)) (when (hash-has-key? (field-name) key) (log-warning "query-hash: ~a: overwriting existing entry ~v" 'field-name key)) (field-name (hash-set (field-name) key value-expr)))) - (on (retracted P) (field-name (hash-remove (field-name) key-expr))) + (on (retracted P) #:priority *query-priority* + (field-name (hash-remove (field-name) key-expr))) field-name)) (define-syntax-rule (query-hash-set field-name P key-expr value-expr) (let () (field [field-name (hash)]) - (on (asserted P) - (let ((key key-expr)) - (field-name (hash-set (field-name) - key - (set-add (hash-ref (field-name) key set) - value-expr))))) - (on (retracted P) - (let ((key key-expr)) - (let ((new-entries (set-remove (hash-ref (field-name) key set) - value-expr))) - (field-name (if (set-empty? new-entries) - (hash-remove (field-name) key) - (hash-set (field-name) key new-entries)))))) + (on (asserted P) #:priority *query-priority* + (field-name (hashset-add (field-name) key-expr value-expr))) + (on (retracted P) #:priority + *query-priority* (field-name (hashset-remove (field-name) key-expr value-expr))) field-name)) (define-syntax-rule (define/query-set id P expr) (define id (query-set id P expr))) diff --git a/racket/syndicate/support/hash.rkt b/racket/syndicate/support/hash.rkt new file mode 100644 index 0000000..efca720 --- /dev/null +++ b/racket/syndicate/support/hash.rkt @@ -0,0 +1,25 @@ +#lang racket/base +;; Hash-table utilities that are not (yet) part of Racket + +(provide hash-set/remove + hashset-add + hashset-remove) + +(require racket/set) + +(define (hash-set/remove ht key val [default-val #f] #:compare [compare equal?]) + (if (compare val default-val) + (hash-remove ht key) + (hash-set ht key val))) + +(define (hashset-add ht key val #:set [set set]) + (hash-set ht key (set-add (hash-ref ht key set) val))) + +(define (hashset-remove ht k v) + (define old (hash-ref ht k #f)) + (if old + (let ((new (set-remove old v))) + (if (set-empty? new) + (hash-remove ht k) + (hash-set ht k new))) + ht))