From 9242988f8076ed0f8368aa1b8576e0180db5ea4e Mon Sep 17 00:00:00 2001 From: Peter Karalekas Date: Sun, 3 Dec 2023 12:11:06 -0800 Subject: [PATCH] Put inner multireweight script in `CONVERGECAST-COLLECT-ROOTS` (#52) * Remove START-INNER-MULTIREWEIGHT; put script in CONVERGECAST-COLLECT-ROOTS * Make sure to use loose address equality in blossom-let * Fix a bug in one of the MRW tests * Need bleeding edge aether now for tests to pass --- .github/workflows/main.yml | 10 ++++- src/operations/multireweight.lisp | 62 ++++++++++++++--------------- tests/node.lisp | 7 ++-- tests/operations/multireweight.lisp | 4 +- 4 files changed, 44 insertions(+), 39 deletions(-) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 22b2c76..9e4595b 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -10,13 +10,21 @@ jobs: test: runs-on: ubuntu-latest steps: + # need bleeding edge aether now + - name: Check out aether + uses: actions/checkout@v4 + with: + repository: dtqec/aether + path: aether - name: Check out anatevka - uses: actions/checkout@v2 + uses: actions/checkout@v4 with: path: anatevka - name: Initialize Lisp run: | sudo apt install sbcl + mkdir -p ${HOME}/quicklisp/local-projects + cp -R aether ${HOME}/quicklisp/local-projects/aether curl -o /tmp/quicklisp.lisp "http://beta.quicklisp.org/quicklisp.lisp" sbcl --noinform --non-interactive \ --load /tmp/quicklisp.lisp \ diff --git a/src/operations/multireweight.lisp b/src/operations/multireweight.lisp index 816232e..20fd474 100644 --- a/src/operations/multireweight.lisp +++ b/src/operations/multireweight.lisp @@ -65,7 +65,22 @@ (define-process-upkeep ((supervisor supervisor) now) (CONVERGECAST-COLLECT-ROOTS source-root root-bucket) - "Recursively collects the `HELD-BY-ROOTS' values of `ROOT-BUCKET' to determine the set of roots that are participating in this `HOLD' cluster (meaning that they are mutually held by each other), starting with a base `cluster' of just the `SOURCE-ROOT'. If any replies are NIL, we abort." + "Recursively collects the `HELD-BY-ROOTS' values of `ROOT-BUCKET' to determine the set of roots that are participating in this `HOLD' cluster (meaning that they are mutually held by each other), starting with a base `cluster' of just the `SOURCE-ROOT'. If any replies are NIL, we abort. + +After collecting the `HOLD-CLUSTER', we then `CHECK-PRIORITY' to determine if we should proceed or abort. + +Then, we reach the \"critical segment\", where it becomes impossible to rewind partway through the modifications we're about to make: + +1. Lock the `HOLD-CLUSTER'. +2. Check that each root in the `HOLD-CLUSTER' is still a root. +3. Change the pingability of the cluster to `:SOFT'. +4. Scan the `HOLD-CLUSTER' for the best external rec to use for reweighting. +5. Change the pingability of the cluster to `:NONE'. +6. Reweight the `HOLD-CLUSTER' according to the recommendation. +7. Change the pingability of the cluster to `:SOFT'. +8. Check to see if the `HOLD-CLUSTER' should be rewound, and do so if need be. +9. Unlock the targets and tear down transient state. +" (let ((cluster (list source-root))) (with-slots (hold-cluster) (peek (process-data-stack supervisor)) (flet ((payload-constructor () @@ -90,7 +105,15 @@ ;; otherwise, push the next set of commands onto the stack (process-continuation supervisor `(CHECK-PRIORITY ,source-root ,hold-cluster) - `(START-INNER-MULTIREWEIGHT))))))) + `(BROADCAST-LOCK ,hold-cluster) + `(CHECK-ROOTS ,hold-cluster) + `(BROADCAST-PINGABILITY ,hold-cluster :SOFT) + `(MULTIREWEIGHT-BROADCAST-SCAN ,hold-cluster) + `(BROADCAST-PINGABILITY ,hold-cluster :NONE) + `(MULTIREWEIGHT-BROADCAST-REWEIGHT ,hold-cluster) + `(BROADCAST-PINGABILITY ,hold-cluster :SOFT) + `(MULTIREWEIGHT-CHECK-REWINDING ,hold-cluster) + `(BROADCAST-UNLOCK))))))) (define-process-upkeep ((supervisor supervisor) now) (CHECK-PRIORITY source-root target-roots) @@ -101,39 +124,12 @@ (send-message-batch #'make-message-id-query hold-cluster) (let ((cluster-id (reduce #'min-id replies))) (unless (equalp source-id (min-id source-id cluster-id)) + (log-entry :entry-type 'aborting-multireweight + :reason 'dont-have-priority + :source-root source-root + :hold-cluster hold-cluster) (setf (process-lockable-aborting? supervisor) t))))))) -(define-process-upkeep ((supervisor supervisor) now) (START-INNER-MULTIREWEIGHT) - "This is the start of the \"critical segment\", where it begins to be impossible to rewind partway through the modifications we're about to make. - -1. Lock the `HOLD-CLUSTER'. -2. Check that each root in the `HOLD-CLUSTER' is still a root. -3. Change the pingability of the cluster to `:SOFT'. -4. Scan the `HOLD-CLUSTER' for the best external rec to use for reweighting. -5. Change the pingability of the cluster to `:NONE'. -6. Reweight the `HOLD-CLUSTER' according to the recommendation. -7. Change the pingability of the cluster to `:SOFT'. -8. Check to see if the `HOLD-CLUSTER' should be rewound, and do so if need be. -9. Unlock the targets and tear down transient state." - (with-slots (hold-cluster) (peek (process-data-stack supervisor)) - (cond - ((not (process-lockable-aborting? supervisor)) - (process-continuation supervisor - `(BROADCAST-LOCK ,hold-cluster) - `(CHECK-ROOTS ,hold-cluster) - `(BROADCAST-PINGABILITY ,hold-cluster :SOFT) - `(MULTIREWEIGHT-BROADCAST-SCAN ,hold-cluster) - `(BROADCAST-PINGABILITY ,hold-cluster :NONE) - `(MULTIREWEIGHT-BROADCAST-REWEIGHT ,hold-cluster) - `(BROADCAST-PINGABILITY ,hold-cluster :SOFT) - `(MULTIREWEIGHT-CHECK-REWINDING ,hold-cluster) - `(BROADCAST-UNLOCK))) ; don't destroy trees - (t - (log-entry :entry-type 'aborting-multireweight - :reason 'previously-aborted - :hold-cluster hold-cluster) - nil)))) - (define-process-upkeep ((supervisor supervisor) now) (MULTIREWEIGHT-BROADCAST-SCAN roots) "Now that we know the full `HOLD-CLUSTER', we `SCAN' each, and aggregate the results in order to make a reweighting decision." diff --git a/tests/node.lisp b/tests/node.lisp index 6d8d5ec..0236215 100644 --- a/tests/node.lisp +++ b/tests/node.lisp @@ -244,6 +244,8 @@ Finally, all of the nodes constructed by this BLOSSOM-LET are stashed in the pla (mapcar (lambda (f) (gethash (funcall f l) dictionary)) accessors) (mapcar (lambda (f) (funcall f r)) accessors)))) + (address-equalp (l r) + (address= (gethash l dictionary l) r)) (test (left-value right-value) (typecase left-value (list @@ -253,13 +255,12 @@ Finally, all of the nodes constructed by this BLOSSOM-LET are stashed in the pla (and (typep (first left-value) 'anatevka::blossom-edge) (every #'translated-edge= left-value right-value)) (and (typep (first left-value) 'aether::address) - (every #'address= left-value right-value))))) + (every #'address-equalp left-value right-value))))) (anatevka::blossom-edge (and (typep right-value 'anatevka::blossom-edge) (translated-edge= left-value right-value))) (anatevka::address - (address= (gethash left-value dictionary left-value) - right-value)) + (address-equalp left-value right-value)) (otherwise (equalp left-value right-value)))) (blossom-slots (value) diff --git a/tests/operations/multireweight.lisp b/tests/operations/multireweight.lisp index 82c88cf..983fc68 100644 --- a/tests/operations/multireweight.lisp +++ b/tests/operations/multireweight.lisp @@ -1261,7 +1261,7 @@ it declines to take action because C has priority. :positive? nil) (CC :id (id 6 0) :children (list (vv-edge CC BB)) - :held-by-roots (list (process-public-address F))) + :held-by-roots (list FF)) (DD :id (id 4 2) :match-edge (vv-edge DD EE) :parent (vv-edge DD EE)) @@ -1273,5 +1273,5 @@ it declines to take action because C has priority. :positive? nil) (FF :id (id 10 0) :children (list (vv-edge FF EE)) - :held-by-roots (list (process-public-address C)))) + :held-by-roots (list CC))) (is (tree-equalp original-tree target-tree))))))))