branch: main
commit 073f1a794b86227b71fcdbdec4a28b06acba14b0
Author: Romain GARBAGE <romain.garb...@inria.fr>
AuthorDate: Mon Feb 24 15:38:07 2025 +0100
utils: Add ring buffer implementation.
* src/cuirass/utils.scm (<ring-buffer>): New record type.
(ring-buffer, ring-buffer-insert, ring-buffer->list): New variables.
* tests/utils.scm: Add tests.
Signed-off-by: Ludovic Courtès <l...@gnu.org>
---
src/cuirass/utils.scm | 67 ++++++++++++++++++++++++++++++++++++++++++++++++++-
tests/utils.scm | 17 +++++++++++++
2 files changed, 83 insertions(+), 1 deletion(-)
diff --git a/src/cuirass/utils.scm b/src/cuirass/utils.scm
index c406a84..b06f451 100644
--- a/src/cuirass/utils.scm
+++ b/src/cuirass/utils.scm
@@ -28,6 +28,7 @@
#:use-module (rnrs bytevectors)
#:use-module (system foreign)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-71)
#:autoload (guix build utils) (mkdir-p)
@@ -60,7 +61,15 @@
open-unix-listening-socket
atomic-box-fetch-and-increment!
- atomic-box-fetch-and-decrement!))
+ atomic-box-fetch-and-decrement!
+
+ ring-buffer
+ ring-buffer-head
+ ring-buffer-head-length
+ ring-buffer-limit
+ ring-buffer-rear
+ ring-buffer-insert
+ ring-buffer->list))
(define-exception-type &cuirass-assertion-failure &assertion-failure
make-cuirass-assertion-failure
@@ -347,3 +356,59 @@ and store the result inside the BOX."
(define (atomic-box-fetch-and-decrement! box)
"Atomically decrement the value of the integer stored inside the given BOX."
(atomic-box-fetch-and-update! box 1-))
+
+;;;
+;;; Ring buffer implementation. Copied from GNU Shepherd.
+;;;
+
+;; Helper function needed by ring-buffer->list.
+(define (at-most max-length lst)
+ "If @var{lst} is shorter than @var{max-length}, return it and the empty list;
+otherwise return its @var{max-length} first elements and its tail."
+ (let loop ((len 0)
+ (lst lst)
+ (result '()))
+ (match lst
+ (()
+ (values (reverse result) '()))
+ ((head . tail)
+ (if (>= len max-length)
+ (values (reverse result) lst)
+ (loop (+ 1 len) tail (cons head result)))))))
+
+;; The poor developer's persistent "ring buffer": it holds between N and 2N
+;; elements, but has O(1) insertion.
+(define-record-type <ring-buffer>
+ (%ring-buffer limit front-length front rear)
+ ring-buffer?
+ (limit ring-buffer-limit)
+ (front-length ring-buffer-front-length)
+ (front ring-buffer-front)
+ (rear ring-buffer-rear))
+
+(define (ring-buffer size)
+ "Return an ring buffer that can hold @var{size} elements."
+ (%ring-buffer size 0 '() '()))
+
+(define-inlinable (ring-buffer-insert element buffer)
+ "Insert @var{element} to the front of @var{buffer}. If @var{buffer} is
+already full, its oldest element is removed."
+ (match buffer
+ (($ <ring-buffer> limit front-length front rear)
+ (if (< front-length limit)
+ (let ((front-length (+ 1 front-length)))
+ (%ring-buffer limit front-length
+ (cons element front)
+ (if (= limit front-length)
+ '()
+ rear)))
+ (%ring-buffer limit 1
+ (list element) front)))))
+
+(define (ring-buffer->list buffer)
+ "Convert @var{buffer} into a list."
+ (match buffer
+ (($ <ring-buffer> limit front-length front rear)
+ (if (= limit front-length)
+ front
+ (append front (at-most (- limit front-length) rear))))))
diff --git a/tests/utils.scm b/tests/utils.scm
index e1ac1b8..4a3b48f 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -83,4 +83,21 @@
(const 42)))))
#:to 'value))
+(test-equal "ring-buffer->list 1 element"
+ '(el)
+ (let ((buffer (ring-buffer 5)))
+ (ring-buffer->list (ring-buffer-insert 'el buffer))))
+
+(test-equal "ring-buffer->list empty buffer"
+ '()
+ (ring-buffer->list (ring-buffer 5)))
+
+(test-equal "ring-buffer->list full"
+ '(9 8 7 6 5)
+ (ring-buffer->list (fold
+ (lambda (e r)
+ (pk 'r (ring-buffer-insert e r)))
+ (ring-buffer 5)
+ (iota 10))))
+
(test-end)
