Skip to content

remove define-message-dispatch, match aether#64 #89

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
ecpeterson wants to merge 2 commits into
base: main
Choose a base branch
from
Open

remove define-message-dispatch, match aether#64 #89

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
c602e81
remove define-message-dispatch, match aether#64
ecpeterson Mar 28, 2026
dcf4768
fix log parser breakage
ecpeterson Mar 29, 2026
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
30 changes: 6 additions & 24 deletions src/dryad.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -63,8 +63,7 @@
;;; passive DRYAD message handlers
;;;

(define-message-handler handler-message-sow
((dryad dryad) (message message-sow))
(define-message-handler ((dryad dryad) (message message-sow))
"Adjoin a new node to the problem graph.

NOTE: In the basic implementation, these messages must be waiting for the DRYAD on launch."
Expand All @@ -84,8 +83,7 @@ NOTE: In the basic implementation, these messages must be waiting for the DRYAD
(gethash node-address (dryad-sprouted? dryad)) nil)
node-address))

(define-message-handler handler-message-discover
((dryad dryad) (message message-discover))
(define-message-handler ((dryad dryad) (message message-discover))
"Handles a DISCOVER message, sent by a BLOSSOM-NODE which expects a list of other BLOSSOM-NODE addresses to which it should send PINGs."
(let ((channels
(loop :for address :being :the :hash-keys :of (dryad-ids dryad)
Expand All @@ -98,8 +96,7 @@ NOTE: In the basic implementation, these messages must be waiting for the DRYAD
:channels-to-try channels
:id (message-discover-id message)))))

(define-message-handler handler-message-sprout
((dryad dryad) (message message-sprout))
(define-message-handler ((dryad dryad) (message message-sprout))
"Handles a SPROUT message, indicating that a BLOSSOM-NODE has been matched (for the first time)."
(with-slots (address) message
(a:when-let ((id (gethash address (dryad-ids dryad))))
Expand All @@ -108,39 +105,24 @@ NOTE: In the basic implementation, these messages must be waiting for the DRYAD
:id id)
(setf (gethash address (dryad-sprouted? dryad)) t))))

(define-rpc-handler handler-message-wilting
((dryad dryad) (message message-wilting))
(define-rpc-handler ((dryad dryad) (message message-wilting))
"Handles a wilting message, indicating that a BLOSSOM-NODE is dying."
(with-slots (address) message
(let ((id (gethash address (dryad-ids dryad))))
(remhash address (dryad-ids dryad))
(remhash address (dryad-sprouted? dryad))
id)))

(define-rpc-handler handler-message-add-macrovertex
((dryad dryad) (message message-add-macrovertex))
(define-rpc-handler ((dryad dryad) (message message-add-macrovertex))
"Handles an add-macrovertex message by keeping track of the provided address."
(with-slots (address) message
(setf (gethash address (dryad-macrovertices dryad)) t)))

(define-rpc-handler handler-message-remove-macrovertex
((dryad dryad) (message message-remove-macrovertex))
(define-rpc-handler ((dryad dryad) (message message-remove-macrovertex))
"Handles a remove-macrovertex message by forgetting about the provided address."
(with-slots (address) message
(remhash address (dryad-macrovertices dryad))))

;;;
;;; install the handlers into the dispatch table
;;;

(define-message-dispatch dryad
(message-sow 'handler-message-sow)
(message-sprout 'handler-message-sprout)
(message-discover 'handler-message-discover)
(message-wilting 'handler-message-wilting)
(message-add-macrovertex 'handler-message-add-macrovertex)
(message-remove-macrovertex 'handler-message-remove-macrovertex))

;;;
;;; DRYAD command definitions
;;;
Expand Down
3 changes: 1 addition & 2 deletions src/lock.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -25,8 +25,7 @@
;;; blossom-node handlers
;;;

(define-message-handler handle-message-lock
((node blossom-node) (message message-lock))
(define-message-handler ((node blossom-node) (message message-lock))
"Prepares a BLOSSOM-NODE to be locked."
(when (blossom-node-wilting node)
(send-message (message-reply-channel message)
Expand Down
90 changes: 9 additions & 81 deletions src/node.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -297,8 +297,7 @@ evalutes to
(:method ((x string) (y string))
(if (string< x y) x y)))

(define-message-subordinate handle-message-id-query
((node blossom-node) (message message-id-query))
(define-message-subordinate ((node blossom-node) (message message-id-query))
"Replies with the minimum ID at this macrovertex."
(cond
((null (blossom-node-petals node))
Expand Down Expand Up @@ -329,8 +328,7 @@ evalutes to
;; We enable this by changing the tree's pingability, and thus permitting the
;; tree to respond to a safe subset (or to all) of PING requests.

(define-broadcast-handler handle-message-broadcast-pingability
((node blossom-node) (message message-broadcast-pingability))
(define-broadcast-handler ((node blossom-node) (message message-broadcast-pingability))
"Changes the pingability of `NODE' (and children / petals) to `PING-TYPE'."
(with-slots (ping-type) message
(log-entry :entry-type ':changing-pingability
Expand All @@ -348,24 +346,21 @@ evalutes to
;; NOTE GH-140: these are probably pretty easy to abuse. perhaps it would be
;; better to implement the micromessages after all.

(define-rpc-handler handle-message-set
((node blossom-node) (message message-set))
(define-rpc-handler ((node blossom-node) (message message-set))
"Handles a remote SETF request."
(with-slots (slots values) message
(loop :for slot :in slots
:for value :in values
:do (setf (slot-value node slot) value))
(values)))

(define-rpc-handler handle-message-push
((node blossom-node) (message message-push))
(define-rpc-handler ((node blossom-node) (message message-push))
"Handles a remote PUSH request."
(with-slots (slot value) message
(push value (slot-value node slot))
(values)))

(define-rpc-handler handle-message-values
((node blossom-node) (message message-values))
(define-rpc-handler ((node blossom-node) (message message-values))
"Handles a remote request for data."
(with-slots (values) message
(loop :for value :in values
Expand All @@ -378,8 +373,7 @@ evalutes to
;; in the ability to inform a blossom that it's been removed from participating
;; and should halt its process.

(define-message-handler handle-message-sprout-on-blossom
((node blossom-node) (message message-sprout))
(define-message-handler ((node blossom-node) (message message-sprout))
"Handles a request that a root node (perhaps not a vertex) alert the DRYAD that it has sprouted."
(cond
((blossom-node-petals node)
Expand All @@ -390,8 +384,7 @@ evalutes to
(send-message (blossom-node-dryad node)
(make-message-sprout :address (process-public-address node))))))

(define-message-handler handle-message-wilt
((node blossom-node) (message message-wilt))
(define-message-handler ((node blossom-node) (message message-wilt))
;; sanity check: are we actually allowed to wilt?
(when (or (blossom-node-parent node)
(blossom-node-pistil node)
Expand All @@ -404,8 +397,7 @@ evalutes to
:address (process-public-address node)))
(setf (blossom-node-wilting node) t))

(define-rpc-handler handle-message-claim-root
((node blossom-node) (message message-claim-root))
(define-rpc-handler ((node blossom-node) (message message-claim-root))
"If node is already claimed, return NIL. Otherwise, set claimed? to T and return our public address."
(with-slots (claimed?) node
(cond
Expand All @@ -415,77 +407,13 @@ evalutes to
(setf claimed? t)
(process-public-address node)))))

(define-rpc-handler handle-message-release-root
((node blossom-node) (message message-release-root))
(define-rpc-handler ((node blossom-node) (message message-release-root))
"Set claimed? to NIL."
(with-slots (claimed?) node
(assert claimed? () "Trying to release an unclaimed root!")
(setf claimed? nil)
t))

;;;
;;; blossom message dispatch table
;;;

;; NOTE: the ordering of this table _mostly_ doesn't matter. its only really
;; important feature is that LOCK-REQUEST gets handled with high priority.
(define-message-dispatch blossom-node
(message-soft-adjoin-root 'handle-message-adjoin-root
(typep (blossom-node-pistil blossom-node)
'(or null address)))
(message-adjoin-root 'handle-message-adjoin-root
(and (eql ':ALL (blossom-node-pingable blossom-node))
(typep (blossom-node-pistil blossom-node)
'(or null address))))

(message-lock 'handle-message-lock)

(message-broadcast-reweight 'handle-message-broadcast-reweight
(process-lockable-locked? blossom-node))

(message-percolate 'handle-message-percolate)

(message-soft-scan 'handle-message-scan
(not (eql ':NONE (blossom-node-pingable blossom-node))))
(message-scan 'handle-message-scan
(eql ':ALL (blossom-node-pingable blossom-node)))

(message-broadcast-pingability 'handle-message-broadcast-pingability)

(message-convergecast-collect-roots 'handle-message-convergecast-collect-roots)

(message-set 'handle-message-set)
(message-push 'handle-message-push)
(message-values 'handle-message-values)

(message-root-path 'handle-message-root-path)
(message-attach-parent 'handle-message-attach-parent)
(message-convert-child-to-petal 'handle-message-convert-child-to-petal)
(message-reattach-cycle-child 'handle-message-reattach-cycle-child)
(message-set-up-blossom 'handle-message-set-up-blossom)

(message-expand 'handle-message-expand)
(message-blossom-parent 'handle-message-blossom-parent
(typep (blossom-node-pistil blossom-node)
'(or null address)))
(message-replace-child 'handle-message-replace-child)

(message-soft-ping 'handle-message-ping
(not (eql ':NONE (blossom-node-pingable blossom-node))))

(message-ping 'handle-message-ping
(eql ':ALL (blossom-node-pingable blossom-node)))

(message-wilt 'handle-message-wilt)

(message-sprout 'handle-message-sprout-on-blossom)

(message-id-query 'handle-message-id-query)
(message-claim-root 'handle-message-claim-root)
(message-release-root 'handle-message-release-root)
(message-broadcast-stash-weight 'handle-message-broadcast-stash-weight)
(message-broadcast-unstash-weight 'handle-message-broadcast-unstash-weight))

;;;
;;; basic command definitions for BLOSSOM-NODE
;;;
Expand Down
3 changes: 1 addition & 2 deletions src/operations/augment.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -82,8 +82,7 @@
;;; message handlers
;;;

(define-message-handler handle-message-percolate
((node blossom-node) (message message-percolate))
(define-message-handler ((node blossom-node) (message message-percolate))
"Performs a step in the path augmentation process."
(with-slots (traversal-edge reply-channel) message
;; does the previous node expect me to link to it?
Expand Down
15 changes: 5 additions & 10 deletions src/operations/contract.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -312,8 +312,7 @@ If we have a non-null peduncle edge (F -> C above), then we need to tell its sou
;;; message handlers
;;;

(define-message-handler handle-message-root-path
((node blossom-node) (message message-root-path))
(define-message-handler ((node blossom-node) (message message-root-path))
"Calculates the path from a blossom through to the tree root (consisting only of toplevel blossoms)."
(with-slots (path reply-channel) message
(cond
Expand All @@ -329,8 +328,7 @@ If we have a non-null peduncle edge (F -> C above), then we need to tell its sou
(send-message reply-channel
(make-message-rpc-done :result path))))))

(define-rpc-handler handle-message-attach-parent
((node blossom-node) (message message-attach-parent))
(define-rpc-handler ((node blossom-node) (message message-attach-parent))
"Attaches a fresh blossom to an existing parent."
(with-slots (peduncle-edge reply-channel fresh-blossom) message
(assert (not (null peduncle-edge)))
Expand All @@ -348,8 +346,7 @@ If we have a non-null peduncle edge (F -> C above), then we need to tell its sou
fresh-blossom)
nil))

(define-rpc-handler handle-message-convert-child-to-petal
((node blossom-node) (message message-convert-child-to-petal))
(define-rpc-handler ((node blossom-node) (message message-convert-child-to-petal))
"Attaches an old child to a new blossom as a petal."
(with-slots (reply-channel fresh-blossom) message
(prog1 (blossom-node-children node)
Expand All @@ -359,8 +356,7 @@ If we have a non-null peduncle edge (F -> C above), then we need to tell its sou
(blossom-node-match-edge node) nil
(blossom-node-children node) nil))))

(define-rpc-handler handle-message-reattach-cycle-child
((node blossom-node) (message message-reattach-cycle-child))
(define-rpc-handler ((node blossom-node) (message message-reattach-cycle-child))
"Attaches an old child to a new blossom as a (non-blossom-)child."
(with-slots (reply-channel fresh-blossom) message
(setf (blossom-edge-target-node (blossom-node-parent node))
Expand All @@ -370,8 +366,7 @@ If we have a non-null peduncle edge (F -> C above), then we need to tell its sou
;; NOTE: this message is really hefty. you could cut it down somewhat by making
;; the fresh blossom responsible for setting _itself_ up. this would also
;; alleviate the obnoxious problem with locking/spawning timing.
(define-rpc-handler handle-message-set-up-blossom
((node blossom-node) (message message-set-up-blossom))
(define-rpc-handler ((node blossom-node) (message message-set-up-blossom))
"Sets up a new contracting blossom's slots."
(with-slots (peduncle-edge petals petal-children dryad reply-channel) message
(loop :for petal-child :in petal-children
Expand Down
11 changes: 5 additions & 6 deletions src/operations/expand.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -105,8 +105,7 @@
;;; message handlers
;;;

(define-message-handler handle-message-expand
((node blossom-node) (message message-expand))
(define-message-handler ((node blossom-node) (message message-expand))
"Starts the procedure for popping a contracting blossom."
(cond
((blossom-node-pistil node)
Expand All @@ -121,8 +120,9 @@
:match-edge (blossom-node-match-edge node))
(process-continuation node `(EXPAND-BLOSSOM ,(message-reply-channel message))))))

(define-message-handler handle-message-blossom-parent
((node blossom-node) (message message-blossom-parent))
(define-message-handler ((node blossom-node) (message message-blossom-parent)
:guard (typep (blossom-node-pistil node)
'(or null address)))
"Calculates the topmost blossom which contains NODE, subject to the possible limitation that we not exceed STOP-BEFORE."
(with-slots (reply-channel stop-before) message
(cond
Expand All @@ -141,8 +141,7 @@
(t
(send-message (blossom-node-pistil node) message)))))

(define-rpc-handler handle-message-replace-child
((node blossom-node) (message message-replace-child))
(define-rpc-handler ((node blossom-node) (message message-replace-child))
"Replaces a child edge targeting a given node by an edge targeting another node."
(with-slots (reply-channel old-child new-child) message
(dolist (child-edge (blossom-node-children node))
Expand Down
3 changes: 1 addition & 2 deletions src/operations/multireweight.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -278,8 +278,7 @@ After collecting the `hold-cluster', we then `CHECK-PRIORITY' to determine if we
;;; message handlers
;;;

(define-convergecast-subordinate handle-message-convergecast-collect-roots
((node blossom-node) (message message-convergecast-collect-roots))
(define-convergecast-subordinate ((node blossom-node) (message message-convergecast-collect-roots))
"Check to see if we're held. If not, `RETURN-FROM-CAST' and send back up a NIL. If we are held, add ourselves to the `HOLD-CLUSTER'. Additionally, if we are held by `NEW-ROOTS' that aren't currently in the cluster, forward this message along to them to continue gathering roots. Finally, send the aggregated cluster back to the sender."
(with-slots (hold-cluster reply-channel) message
;; If we're not held, abort the convergecast.
Expand Down
10 changes: 4 additions & 6 deletions src/operations/reweight.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -321,8 +321,7 @@
;;; message handlers
;;;

(define-broadcast-handler handle-message-broadcast-stash-weight
((node blossom-node) (message message-broadcast-stash-weight))
(define-broadcast-handler ((node blossom-node) (message message-broadcast-stash-weight))
"If the node is negative, sets the `STASHED-WEIGHT' of `NODE' to equal its `INTERNAL-WEIGHT', and regardless instructs `NODE's children to do the same."
(with-slots (internal-weight positive? stashed-weight) node
(unless positive?
Expand All @@ -332,8 +331,8 @@
(push-broadcast-frame :targets (mapcar #'blossom-edge-target-node
(blossom-node-children node)))))

(define-broadcast-handler handle-message-broadcast-reweight
((node blossom-node) (message message-broadcast-reweight))
(define-broadcast-handler ((node blossom-node) (message message-broadcast-reweight)
:guard (process-lockable-locked? node))
"Increments the `INTERNAL-WEIGHT' of `NODE' by the `WEIGHT' of the `MESSAGE', and then instructs `NODE's children to reweight themselves by the additive inverse of `WEIGHT'."
(with-slots (weight) message
(with-slots (internal-weight) node
Expand All @@ -348,8 +347,7 @@
(push-broadcast-frame :targets (mapcar #'blossom-edge-target-node
(blossom-node-children node))))))

(define-broadcast-handler handle-message-broadcast-unstash-weight
((node blossom-node) (message message-broadcast-unstash-weight))
(define-broadcast-handler ((node blossom-node) (message message-broadcast-unstash-weight))
"If the node is negative, sets the `STASHED-WEIGHT' of `NODE' to NIL, and regardless instructs `NODE's children to do the same."
(with-slots (internal-weight positive? stashed-weight) node
(unless positive?
Expand Down
Loading
Loading