diff options
author | Maxime Devos <maximedevos@telenet.be> | 2021-05-24 18:07:44 +0200 |
---|---|---|
committer | Maxime Devos <maximedevos@telenet.be> | 2021-09-21 12:08:41 +0200 |
commit | 08d98c025e7f50d1c6bafd94dfadd2c384fe8260 (patch) | |
tree | f3b9053612de1b17d0c7f192c2a8d1ba4e5137ea /gnu/gnunet | |
parent | 8f041a1762721dd25dcf1959d04816b8f8d3974a (diff) | |
download | gnunet-scheme-08d98c025e7f50d1c6bafd94dfadd2c384fe8260.tar.gz gnunet-scheme-08d98c025e7f50d1c6bafd94dfadd2c384fe8260.zip |
mq: Define envelope data type, again.
The new envelope data type can be used without
fibers or multi-threading.
* Makefile.am (modules): Remove replaced
gnu/gnunet/message/envelope.scm.
(%.go: %.scm): Do not unset GUILE_LOAD_COMPILED_PATH as that
would interfere with guile-pfds.
* README.org (Modules): Remove the obsolete
gnu/gnunet/message/envelope.scm.
(Message queues): Document new envelope module. Adjust
message queue blurb for the future.
* gnu/gnunet/mq/envelope.scm: Define new envelope module.
* gnu/gnunet/message/envelope.scm: Delete.
* tests/envelope.scm: Test the new envelope module.
Diffstat (limited to 'gnu/gnunet')
-rw-r--r-- | gnu/gnunet/message/envelope.scm | 139 | ||||
-rw-r--r-- | gnu/gnunet/mq/envelope.scm | 195 |
2 files changed, 195 insertions, 139 deletions
diff --git a/gnu/gnunet/message/envelope.scm b/gnu/gnunet/message/envelope.scm deleted file mode 100644 index 2849787..0000000 --- a/gnu/gnunet/message/envelope.scm +++ /dev/null | |||
@@ -1,139 +0,0 @@ | |||
1 | ;; This file is part of scheme-GNUnet. | ||
2 | ;; Copyright (C) 2012-2019 GNUnet e.V. | ||
3 | ;; Copyright (C) 2021 Maxime Devos | ||
4 | ;; | ||
5 | ;; scheme-GNUnet is free software: you can redistribute it and/or modify it | ||
6 | ;; under the terms of the GNU Affero General Public License as published | ||
7 | ;; by the Free Software Foundation, either version 3 of the License, | ||
8 | ;; or (at your option) any later version. | ||
9 | ;; | ||
10 | ;; scheme-GNUnet is distributed in the hope that it will be useful, but | ||
11 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | ||
13 | ;; Affero General Public License for more details. | ||
14 | ;; | ||
15 | ;; You should have received a copy of the GNU Affero General Public License | ||
16 | ;; along with this program. If not, see <http://www.gnu.org/licenses/>. | ||
17 | ;; | ||
18 | ;; SPDX-License-Identifier: AGPL3.0-or-later | ||
19 | |||
20 | ;; Upstream GNUnet: | ||
21 | ;; @author Florian Dold | ||
22 | ;; @file util/mq.c | ||
23 | ;; @brief general purpose request queue | ||
24 | ;; | ||
25 | ;; Scheme-GNUnet: | ||
26 | ;; @author Maxime Devos | ||
27 | ;; @file gnu/gnunet/message/envelope.scm | ||
28 | |||
29 | (define-library (gnu gnunet message envelope) | ||
30 | (export <envelope> make-envelope envelope? | ||
31 | <envelope/dll> make-envelope/dll envelope/dll? | ||
32 | envelope-message-slice envelope-priority | ||
33 | notify-sent! wait-sent-operation | ||
34 | envelope-dll-check envelope-dll | ||
35 | &double-notify-sent make-double-notify-sent | ||
36 | double-notify-sent?) | ||
37 | (import (gnu gnunet utils bv-slice) | ||
38 | (srfi srfi-26) | ||
39 | (rnrs base) | ||
40 | (ice-9 optargs) | ||
41 | (rnrs records syntactic) | ||
42 | (only (rnrs exceptions) | ||
43 | raise) | ||
44 | (only (fibers conditions) | ||
45 | make-condition | ||
46 | signal-condition! | ||
47 | wait-operation) | ||
48 | (only (rnrs conditions) | ||
49 | condition &violation | ||
50 | make-who-condition | ||
51 | make-message-condition | ||
52 | define-condition-type)) | ||
53 | (begin | ||
54 | (define-record-type (<envelope> make-envelope envelope?) | ||
55 | (fields (immutable message-slice envelope-message-slice) | ||
56 | (immutable message-prio envelope-priority) | ||
57 | ;; Signalled when the message has been sent. | ||
58 | (immutable message-sent envelope-message-sent-condition)) | ||
59 | (protocol | ||
60 | (lambda (%make) | ||
61 | (lambda* (mh #:key (priority 0)) | ||
62 | "Make a fresh message envelope for the message @var{mh} | ||
63 | (a readable bytevector slice) and priority @var{priority} | ||
64 | (a numeric value from @code{gnu gnunet util mq-enum})." | ||
65 | ;; FIXME also check if @var{mh} is large enough? | ||
66 | (assert (slice-readable? mh)) | ||
67 | (assert (and (integer? priority) | ||
68 | (exact? priority) | ||
69 | (<= 0 priority) | ||
70 | ;; XXX magic number | ||
71 | (< priority 512))) | ||
72 | (%make mh priority (make-condition))))) | ||
73 | (sealed #f) | ||
74 | (opaque #t)) | ||
75 | |||
76 | (define-condition-type &double-notify-sent &violation | ||
77 | make-double-notify-sent double-notify-sent?) | ||
78 | |||
79 | ;; See notify-sent!. | ||
80 | (define (notify-sent-condition) | ||
81 | (condition (make-double-notify-sent) | ||
82 | (make-who-condition 'notify-sent!) | ||
83 | (make-message-condition | ||
84 | "notify-sent! was called twice on same envelope"))) | ||
85 | |||
86 | (define (notify-sent! ev) | ||
87 | "Mark the envelope @var{ev} as sent. | ||
88 | |||
89 | This is the responsibility of the transport. | ||
90 | |||
91 | Conceptually, this should only be available to the message | ||
92 | transport, but the only other potential user would be | ||
93 | the message sender, so this shouldn't matter. | ||
94 | |||
95 | It is an error to call more than one. Currently, | ||
96 | an appropriate @code{&double-notify-sent} is raised." | ||
97 | (if (signal-condition! (envelope-message-sent-condition ev)) | ||
98 | (values) | ||
99 | (raise (notify-sent-condition)))) | ||
100 | |||
101 | (define (wait-sent-operation ev) | ||
102 | "Return an operation for waiting until the envelope | ||
103 | @var{ev} has been sent. If the message has already been sent, | ||
104 | this operation returns immediately." | ||
105 | (wait-operation (envelope-message-sent-condition ev))) | ||
106 | |||
107 | ;; XXX I doubt this will see any use. | ||
108 | (define-record-type (<envelope/dll> make-envelope/dll envelope/dll?) | ||
109 | (fields (immutable capability %envelope/dll-capability) | ||
110 | (mutable left %envelope/dll-previous | ||
111 | %set-envelope/dll-previous!) | ||
112 | (mutable right %envelope/dll-next | ||
113 | %set-envelope/dll-next!)) | ||
114 | (protocol | ||
115 | (lambda (%make) | ||
116 | (lambda (cap . args) | ||
117 | "A variant of @code{make-envelope}, that organises envelopes | ||
118 | in a linked list. The capability @var{cap} will be required for accessing | ||
119 | and modifying this list." | ||
120 | ((apply %make args) cap #f #f)))) | ||
121 | (parent <envelope>) | ||
122 | (sealed #f) | ||
123 | (opaque #t)) | ||
124 | |||
125 | (define (envelope-dll-check ev/dll cap) | ||
126 | "Verify whether the capability @var{cap} can be used | ||
127 | for accessing the underlying DLL of the envelope @var{ev}. | ||
128 | If not, raise an exception. Otherwise, return truth." | ||
129 | ;; FIXME &bad-capability exception? | ||
130 | (assert (eq? (%envelope/dll-capability ev/dll) cap))) | ||
131 | |||
132 | (define (envelope-dll ev/dll cap) | ||
133 | "Return the DLL procedures of the DLL envelope @var{ev/dll}, | ||
134 | using the capability @var{cap}." | ||
135 | (envelope-dll-check ev/dll cap) | ||
136 | (values (cute %envelope/dll-previous ev/dll) | ||
137 | (cute %set-envelope/dll-previous! ev/dll <>) | ||
138 | (cute %envelope/dll-next ev/dll) | ||
139 | (cute %set-envelope/dll-next! ev/dll <>))))) | ||
diff --git a/gnu/gnunet/mq/envelope.scm b/gnu/gnunet/mq/envelope.scm new file mode 100644 index 0000000..e0c94a2 --- /dev/null +++ b/gnu/gnunet/mq/envelope.scm | |||
@@ -0,0 +1,195 @@ | |||
1 | ;; This file is part of GNUnet. | ||
2 | ;; Copyright (C) 2012-2019 GNUnet e.V. | ||
3 | ;; Copyright (C) 2021 Maxime Devos (<maximedevos@telenet.be>) | ||
4 | ;; | ||
5 | ;; GNUnet is free software: you can redistribute it and/or modify it | ||
6 | ;; under the terms of the GNU Affero General Public License as published | ||
7 | ;; by the Free Software Foundation, either version 3 of the License, | ||
8 | ;; or (at your option) any later version. | ||
9 | ;; | ||
10 | ;; GNUnet is distributed in the hope that it will be useful, but | ||
11 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | ||
13 | ;; Affero General Public License for more details. | ||
14 | ;; | ||
15 | ;; You should have received a copy of the GNU Affero General Public License | ||
16 | ;; along with this program. If not, see <http://www.gnu.org/licenses/>. | ||
17 | ;; | ||
18 | ;; SPDX-License-Identifier: AGPL3.0-or-later | ||
19 | |||
20 | ;; Author: Florian Dold | ||
21 | ;; Author: Maxime Devos | ||
22 | ;; C file: util/mq.c | ||
23 | ;; Scheme module: (gnu gnunet mq envelope) | ||
24 | ;; | ||
25 | ;; Limitation: the format of messages is still in flux, | ||
26 | ;; so no type checks there. | ||
27 | (define-library (gnu gnunet mq envelope) | ||
28 | (export <envelope> make-envelope envelope? | ||
29 | attempt-cancel! attempt-irrevocable-sent!) | ||
30 | (import (gnu gnunet utils hat-let) | ||
31 | (only (guile) define* lambda* exact-integer?) | ||
32 | (only (ice-9 match) match) | ||
33 | (only (ice-9 atomic) | ||
34 | make-atomic-box atomic-box-ref | ||
35 | atomic-box-compare-and-swap!) | ||
36 | (only (rnrs base) | ||
37 | lambda assert letrec let begin define | ||
38 | syntax-rules let-syntax define-syntax | ||
39 | procedure? eq? >= = <= < if quote ... | ||
40 | identifier-syntax values and let* | ||
41 | vector vector-ref vector? vector-length) | ||
42 | (only (rnrs records syntactic) define-record-type)) | ||
43 | (begin | ||
44 | (define-record-type (<envelope> make-envelope envelope?) | ||
45 | ;; Atomic box: | ||
46 | ;; #t: cancelled | ||
47 | ;; #f: to late to cancel, message has been irrevocabily sent! | ||
48 | ;; | ||
49 | ;; (Unless you play tricks like pulling out the Ethernet | ||
50 | ;; cable before the message is received by the router) | ||
51 | ;; #(message prio notify-sent! cancel!) | ||
52 | (fields (immutable state %cancellation-state)) | ||
53 | (protocol | ||
54 | (lambda (%make) | ||
55 | (lambda* (cancel! message #:key (priority 0) (notify-sent! values)) | ||
56 | "Make a message envelope; i.e., a record containing the message | ||
57 | (@var{message}, @var{priority}) and information on how to cancel the sending | ||
58 | of the message (@var{cancel!}) and who should be notified when the message | ||
59 | cannot be unsent anymore (@var{notify-sent!}). | ||
60 | |||
61 | Once marked as cancelled or irrevocabily sent, the record drops its | ||
62 | references to @var{message}, @var{cancel!} and @var{notify-sent!}. | ||
63 | When being marked as cancelled, the thunk @var{cancel!} is called." | ||
64 | (assert (and (procedure? cancel!) (procedure? notify-sent!) | ||
65 | (exact-integer? priority) | ||
66 | (<= 0 priority 511))) | ||
67 | (%make (make-atomic-box | ||
68 | (vector message priority notify-sent! cancel!))))))) | ||
69 | |||
70 | (define (%attempt-irrevocable-sent! envelope already-sent go cancelled) | ||
71 | (bind-atomic-boxen | ||
72 | ((state (%cancellation-state envelope) swap!)) | ||
73 | (let spin ((old state)) | ||
74 | (match old | ||
75 | ;; See comment at %attempt-cancel! for | ||
76 | ;; why we don't do #(message prio notify-sent! cancel!) | ||
77 | ((? vector?) | ||
78 | (if (eq? old (swap! old #f)) | ||
79 | (let^ ((!! (= (vector-length old) 4)) | ||
80 | (! message (vector-ref old 0)) | ||
81 | (! prio (vector-ref old 1)) | ||
82 | (! notify-sent! (vector-ref old 2))) | ||
83 | (notify-sent!) | ||
84 | (go message prio)) | ||
85 | (spin state))) | ||
86 | (#t (cancelled)) | ||
87 | (#f (already-sent)))))) | ||
88 | |||
89 | (define-syntax attempt-irrevocable-sent! | ||
90 | (syntax-rules (go cancelled already-sent) | ||
91 | "If @var{envelope} is not cancelled and has not yet been sent, | ||
92 | mark the message as irrevocably sent, call the notify-sent callback and | ||
93 | evaluate @var{exp/go} in an environment where the message @var{message} | ||
94 | and its priority @var{priority} are bound. | ||
95 | |||
96 | If the message has already been marked as irrevocabily sent, | ||
97 | evaluate @var{exp/already-sent} instead. If the message is cancelled, | ||
98 | evaluate @var{exp/cancelled} instead. | ||
99 | |||
100 | Even if this operation (and perhaps @code{attempt-cancel!}) is used concurrently | ||
101 | on the same @var{envelope}, whether by multi-threading, asynchronicities | ||
102 | (via @code{system-async-mark}) or by recursion, the following properties hold: | ||
103 | |||
104 | @begin itemize | ||
105 | @item the notify-sent callback of @var{envelope} is called at most once | ||
106 | @item the notify-sent callback is never called if @var{envelope} is cancelled | ||
107 | at any point in time | ||
108 | @item likewise, the code in @var{exp/go} is at most evaluated once | ||
109 | @end itemize" | ||
110 | ((_ envelope | ||
111 | ((go message priority) . exp/go) | ||
112 | ((cancelled) . exp/cancelled) | ||
113 | ((already-sent) . exp/already-sent)) | ||
114 | (%attempt-irrevocable-sent! envelope | ||
115 | (lambda () . exp/already-sent) | ||
116 | (lambda (message priority) . exp/go) | ||
117 | (lambda () . exp/cancelled))))) | ||
118 | |||
119 | (define (%attempt-cancel! envelope now-cancelled already-cancelled | ||
120 | already-sent) | ||
121 | (bind-atomic-boxen | ||
122 | ((state (%cancellation-state envelope) swap!)) | ||
123 | (let spin ((old state)) | ||
124 | (match old | ||
125 | ;; Do _not_ use #(message prio notify-sent! cancel!) | ||
126 | ;; here! Instead, delay the bounds check and accessing | ||
127 | ;; the elements of the vector after the swap!. That way: | ||
128 | ;; | ||
129 | ;; Premature optimisation. | ||
130 | ;; We save a little time in case two threads try to concurrently | ||
131 | ;; @var{state}. | ||
132 | ;; | ||
133 | ;; Meager excuse: self-healing (in case of memory corruption). | ||
134 | ;; Suppose a cosmic ray flipped a few bits and now | ||
135 | ;; @var{state} contains another vector, of different length. | ||
136 | ;; Then by performing the swap before the bounds check, | ||
137 | ;; the envelope is brought into a valid state. (And an | ||
138 | ;; exception will still result.) | ||
139 | ((? vector?) | ||
140 | (if (eq? old (swap! old #t)) | ||
141 | (let^ ((!! (= (vector-length old) 4)) | ||
142 | (! cancel! (vector-ref old 3))) | ||
143 | (cancel!) | ||
144 | (now-cancelled)) | ||
145 | (spin state))) | ||
146 | (#t (already-cancelled)) | ||
147 | ;; XXX maybe make the meager excuse less meager | ||
148 | ;; and add a 'default' case where @var{state} is | ||
149 | ;; set to #f when bad (and an exception is raised)? | ||
150 | ;; Seems like some dedicated exception types for | ||
151 | ;; memory corruption are required then ... | ||
152 | ;; And tests. | ||
153 | (#f (already-sent)))))) | ||
154 | |||
155 | (define-syntax attempt-cancel! | ||
156 | (syntax-rules (now-cancelled already-cancelled already-sent) | ||
157 | "If @var{envelope} is not yet marked as cancelled or sent, | ||
158 | mark it as cancelled, call the corresponding cancellation callback | ||
159 | and evaluate @var{exp/now-cancelled}. | ||
160 | |||
161 | If @var{envelope} is already marked as cancelled, do not mutate | ||
162 | anything or call any callback and evaluate @var{exp/already-cancelled}. | ||
163 | Likewise, if @var{envelope} is marked as irrevocably sent, evaluate | ||
164 | @var{exp/already-sent} instead. | ||
165 | |||
166 | If this operation is interrupted before @var{exp/now-cancelled} is | ||
167 | evaluated, the envelope may be marked as cancelled even if the | ||
168 | cancellation callback has not yet been called or has not yet returned. | ||
169 | |||
170 | However, by tolerating this limitation, it can be (and is) guaranteed | ||
171 | that the cancellation callback is called at most once. Likewise, the | ||
172 | code in @var{exp/now-cancelled} is only be called at most once. | ||
173 | Also, the cancellation callback and is never called (and @var{exp/now-cancelled} | ||
174 | never evaluated) if @var{envelope} is marked as sent at any point in time." | ||
175 | ((_ envelope | ||
176 | ((now-cancelled) . exp/now-cancelled) | ||
177 | ((already-cancelled) . exp/already-cancelled) | ||
178 | ((already-sent) . exp/already-sent)) | ||
179 | (%attempt-cancel! envelope | ||
180 | (lambda () . exp/now-cancelled) | ||
181 | (lambda () . exp/already-cancelled) | ||
182 | (lambda () . exp/already-sent))))) | ||
183 | |||
184 | (define-syntax bind-atomic-boxen | ||
185 | (syntax-rules () | ||
186 | ((_ () exp exp* ...) | ||
187 | (let () exp exp* ...)) | ||
188 | ((_ ((variable box swap!) . etc) exp exp* ...) | ||
189 | (let ((stashed-box box)) | ||
190 | (let-syntax ((variable (identifier-syntax | ||
191 | (atomic-box-ref box)))) | ||
192 | (let ((swap! (lambda (expected desired) | ||
193 | (atomic-box-compare-and-swap! box expected | ||
194 | desired)))) | ||
195 | (bind-atomic-boxen etc exp exp* ...))))))))) | ||