blob: 34bf62c55cbc698a089a4d47956a4452ddd918e8 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
|
;; This file is part of scheme-GNUnet.
;; Copyright (C) 2021 GNUnet e.V.
;;
;; scheme-GNUnet is free software: you can redistribute it and/or modify it
;; under the terms of the GNU Affero General Public License as published
;; by the Free Software Foundation, either version 3 of the License,
;; or (at your option) any later version.
;;
;; scheme-GNUnet is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;
;; SPDX-License-Identifier: AGPL3.0-or-later
;; I'm not sure how to document this.
(define-library (gnu gnunet concurrency repeated-condition)
(export make-repeated-condition repeated-condition?
prepare-await-trigger! await-trigger! trigger-condition!)
(import (only (rnrs records syntactic)
define-record-type)
(only (guile) pk quote)
(only (rnrs base)
begin lambda define eq? not values)
(only (gnu gnunet utils hat-let)
let^)
(prefix (only (fibers conditions)
make-condition signal-condition! wait-operation)
#{cvar:}#)
(only (fibers operations)
choice-operation perform-operation)
(only (ice-9 atomic)
make-atomic-box atomic-box-ref
atomic-box-compare-and-swap!))
(begin
;; TODO: is this ‘edge-triggered’? Does this behave like
;; POSIX condition variables?
(define-record-type
(<repeated-condition> make-repeated-condition repeated-condition?)
(fields (immutable cvar-box rcvar-cvar-box))
(protocol
(lambda (%make)
(lambda ()
"Make a fresh ‘repeated condition’.
Repeated conditions are a variant of fiber's conditions.
They can be signalled and waited upon like regular conditions.
However, the semantics of waiting multiple times are different.
Each wait creates a ‘waiting event’. TODO study the literature
for some proper and clear vocabulary."
(%make (make-atomic-box (cvar:make-condition)))))))
;; Concurrent 'await-trigger!' are not supported!
;; Likewise, this procedure should not be interrupted.
;; (system-async-mark and fibers scheduling are fine though.)
;;
;; Each time, a new operation must be made with this procedure.
;; Old operations may not be re-used. The previous operation
;; must be performed before creating the next one.
(define (prepare-await-trigger! rcvar)
(let^ ((! cvar-box (rcvar-cvar-box rcvar))
(! next (cvar:make-condition))
(! previous (atomic-box-ref cvar-box))
(! operation
(choice-operation
(cvar:wait-operation previous)
;; Include 'next'. Otherwise, ???.
(cvar:wait-operation next)))
;; Tell 'trigger-condition!' about the new
;; condition.
(! next-previous
(atomic-box-compare-and-swap! cvar-box previous next))
;; await-trigger! may not be used concurrently,
;; so this assert should succeed.
(!! (eq? previous next-previous)))
operation))
(define (await-trigger! rcvar)
(perform-operation (prepare-await-trigger! rcvar)))
(define (trigger-condition! rcvar)
(let^ ((! cvar-box (rcvar-cvar-box rcvar))
(/o/ spin (cvar (atomic-box-ref cvar-box)))
(<-- (_) (cvar:signal-condition! cvar))
;; Verify the condition hasn't changed.
(! next-old
(atomic-box-compare-and-swap! cvar-box cvar cvar))
;; If it did change, we notified the wrong condition,
;; so retry!
(? (not next-old) (spin next-old)))
(values)))))
|
