From d9ca9cdd01bf1097343a047b51a1392131c7cf58 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 9 Nov 2022 12:52:05 +0100
Subject: gnu: guile-fibers: Add patch fixing FD finalizer memory leak.

Fixes <https://issues.guix.gnu.org/58631>.

* gnu/packages/patches/guile-fibers-fd-finalizer-leak.patch: New file.
* gnu/packages/guile-xyz.scm (guile-fibers-1.1)[source]: Use it.
* gnu/local.mk (dist_patch_DATA): Add it.
---
 gnu/local.mk                                       |  1 +
 gnu/packages/guile-xyz.scm                         |  3 +-
 .../patches/guile-fibers-fd-finalizer-leak.patch   | 54 ++++++++++++++++++++++
 3 files changed, 57 insertions(+), 1 deletion(-)
 create mode 100644 gnu/packages/patches/guile-fibers-fd-finalizer-leak.patch

diff --git a/gnu/local.mk b/gnu/local.mk
index 9e5c6bfe9d..27b31ea27f 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -1278,6 +1278,7 @@ dist_patch_DATA =						\
   %D%/packages/patches/guile-cross-compilation.patch		\
   %D%/packages/patches/guile-fibers-destroy-peer-schedulers.patch \
   %D%/packages/patches/guile-fibers-epoll-instance-is-dead.patch \
+  %D%/packages/patches/guile-fibers-fd-finalizer-leak.patch	\
   %D%/packages/patches/guile-fibers-wait-for-io-readiness.patch \
   %D%/packages/patches/guile-gdbm-ffi-support-gdbm-1.14.patch	\
   %D%/packages/patches/guile-git-adjust-for-libgit2-1.2.0.patch \
diff --git a/gnu/packages/guile-xyz.scm b/gnu/packages/guile-xyz.scm
index 71bbba7fbe..c9f1257380 100644
--- a/gnu/packages/guile-xyz.scm
+++ b/gnu/packages/guile-xyz.scm
@@ -661,7 +661,8 @@ Unix-style DSV format and RFC 4180 format.")
                 "0ll63d7202clapg1k4bilbnlmfa4qvpjnsd7chbkka4kxf5klilc"))
               (patches
                (search-patches "guile-fibers-wait-for-io-readiness.patch"
-                               "guile-fibers-epoll-instance-is-dead.patch"))))
+                               "guile-fibers-epoll-instance-is-dead.patch"
+                               "guile-fibers-fd-finalizer-leak.patch"))))
     (build-system gnu-build-system)
     (arguments
      (list #:make-flags
diff --git a/gnu/packages/patches/guile-fibers-fd-finalizer-leak.patch b/gnu/packages/patches/guile-fibers-fd-finalizer-leak.patch
new file mode 100644
index 0000000000..2d8f9c2cf5
--- /dev/null
+++ b/gnu/packages/patches/guile-fibers-fd-finalizer-leak.patch
@@ -0,0 +1,54 @@
+Upstream fix for a memory leak introduced in Fibers 1.1.0 that would manifest
+in shepherd:
+
+  https://github.com/wingo/fibers/issues/65
+  https://issues.guix.gnu.org/58631
+
+diff --git a/fibers/scheduler.scm b/fibers/scheduler.scm
+index 2b03941..760b037 100644
+--- a/fibers/scheduler.scm
++++ b/fibers/scheduler.scm
+@@ -182,8 +182,10 @@ remote kernel thread."
+     (#f (warn "scheduler for unknown fd" fd))
+     ((and events+waiters (active-events . waiters))
+      ;; First, clear the active status, as the EPOLLONESHOT has
+-     ;; deactivated our entry in the epoll set.
+-     (set-car! events+waiters #f)
++     ;; deactivated our entry in the epoll set.  Set the car to 0, not #f, so
++     ;; that 'schedule-tasks-for-active-fd' doesn't end up re-adding a
++     ;; finalizer on FD.
++     (set-car! events+waiters 0)
+      (set-cdr! events+waiters '())
+      (unless (zero? (logand revents (logior EPOLLHUP EPOLLERR)))
+        (hashv-remove! (scheduler-fd-waiters sched) fd))
+@@ -336,21 +338,19 @@ expressed as an epoll bitfield."
+ 
+   (let ((fd-waiters (hashv-ref (scheduler-fd-waiters sched) fd)))
+     (match fd-waiters
+-      ((active-events . waiters)
+-       (set-cdr! fd-waiters (acons events task waiters))
+-       (unless (and active-events
+-                    (= (logand events active-events) events))
+-         (let ((active-events (logior events (or active-events 0))))
+-           (set-car! fd-waiters active-events)
+-           (add-fdes-finalizer! fd (fd-finalizer fd-waiters))
+-           (epoll-add*! (scheduler-epfd sched) fd
+-                        (logior active-events EPOLLONESHOT)))))
+-      (#f
++      ((or #f (#f))                               ;FD is new or was finalized
+        (let ((fd-waiters (list events (cons events task))))
+          (hashv-set! (scheduler-fd-waiters sched) fd fd-waiters)
+          (add-fdes-finalizer! fd (fd-finalizer fd-waiters))
+          (epoll-add*! (scheduler-epfd sched) fd
+-                      (logior events EPOLLONESHOT)))))))
++                      (logior events EPOLLONESHOT))))
++      ((active-events . waiters)
++       (set-cdr! fd-waiters (acons events task waiters))
++       (unless (= (logand events active-events) events)
++         (let ((active-events (logior events active-events)))
++           (set-car! fd-waiters active-events)
++           (epoll-add*! (scheduler-epfd sched) fd
++                        (logior active-events EPOLLONESHOT))))))))
+ 
+ (define (schedule-task-when-fd-readable sched fd task)
+   "Arrange to schedule @var{task} on @var{sched} when the file
-- 
cgit v1.2.3