[PATCH] Add scm_remember_upto_here to functions using a port's fd.

[Maxime Devos <maximedevos@telenet.be>]

[-- Attachment #1.1: Type: text/plain, Size: 111 bytes --]

Oops, I forgot to add myself to THANKS.
Seems rather presumptive of me, but it's
recommended by HACKING ...

[-- Attachment #1.2: 0001-Add-scm_remember_upto_here-to-functions-using-a-port.patch --]
[-- Type: text/x-patch, Size: 14956 bytes --]

From b3fe19e393b88a5227f9f1b9e1f5de09985c4e3d Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Sat, 6 Mar 2021 21:39:52 +0100
Subject: [PATCH] Add scm_remember_upto_here to functions using a port's fd.

This prevents a garbage collection cycle at an inopportune
time from closing a port while its file descriptor is still
required.

* libguile/filesys.c
  (scm_chown, scm_stat, scm_fcntl, scm_fsync, scm_sendfile)
  (scm_chmod): Add a scm_remember_upto_here after the system call
  is done with fhe file descriptor.
* libguile/fports.c
  (fport_input_waiting, fport_read, fport_write, fport_seek)
  (fport_truncate, fport_close, port_random_access_p)
  (fport_get_natural_buffer_sizes): Likewise.
* libguile/ioext.c
  (scm_dup_to_fdes, scm_dup2, scm_isatty_p)
  (scm_primitive_move_to_fdes): Likewise.
* libguile/posix.c
  (scm_ttyname, scm_tcgetpgrp, scm_tcsetpgrp, scm_flock): Likewise.
  (scm_piped_process): Likewise, and introduce the 'error_port',
  'output_port' and 'input_port' variables in order to be able
  to remember these later.
* libguile/rw.c
  (scm_read_string_x_partial, scm_write_string_partial): Likewise,
  and introduce a 'port' variable in order to be able to remember
  it later.
* THANKS: Add patch author.
---
 THANKS             |  1 +
 libguile/filesys.c |  6 ++++++
 libguile/fports.c  | 11 +++++++++++
 libguile/ioext.c   |  7 ++++++-
 libguile/posix.c   | 28 +++++++++++++++++-----------
 libguile/rw.c      | 26 ++++++++++++++++++++------
 libguile/socket.c  | 17 ++++++++++++++---
 7 files changed, 75 insertions(+), 21 deletions(-)

diff --git a/THANKS b/THANKS
index aa4877e95..cdfa9e10d 100644
--- a/THANKS
+++ b/THANKS
@@ -78,6 +78,7 @@ For fixes or providing information which led to a fix:
           Brian Crowder
     Christopher Cramer
            Josh Datko
+         Maxime Devos
           David Diffenbaugh
           Hyper Division
            Erik Dominikus
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 020c9cf7b..60311501e 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -177,6 +177,7 @@ SCM_DEFINE (scm_chown, "chown", 3, 0, 0,
 		  SCM_FPORT_FDES (object) : scm_to_int (object));
 
       SCM_SYSCALL (rv = fchown (fdes, scm_to_int (owner), scm_to_int (group)));
+      scm_remember_upto_here_1 (object);
     }
   else
 #endif
@@ -546,6 +547,7 @@ SCM_DEFINE (scm_stat, "stat", 1, 1, 0,
       SCM_VALIDATE_OPFPORT (1, object);
       fdes = SCM_FPORT_FDES (object);
       SCM_SYSCALL (rv = fstat_or_fstat64 (fdes, &stat_temp));
+      scm_remember_upto_here_1 (object);
     }
 
   if (rv == -1)
@@ -977,6 +979,7 @@ SCM_DEFINE (scm_fcntl, "fcntl", 2, 1, 0,
   SCM_SYSCALL (rv = fcntl (fdes, scm_to_int (cmd), ivalue));
   if (rv == -1)
     SCM_SYSERROR;
+  scm_remember_upto_here_1 (object);
   return scm_from_int (rv);
 }
 #undef FUNC_NAME
@@ -1004,6 +1007,7 @@ SCM_DEFINE (scm_fsync, "fsync", 1, 0, 0,
 
   if (fsync (fdes) == -1)
     SCM_SYSERROR;
+  scm_remember_upto_here_1 (object);
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
@@ -1225,6 +1229,7 @@ SCM_DEFINE (scm_sendfile, "sendfile", 3, 1, 0,
 
   }
 
+  scm_remember_upto_here_2 (in, out);
   return scm_from_size_t (total);
 
 #undef VALIDATE_FD_OR_PORT
@@ -1418,6 +1423,7 @@ SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0,
       else
 	fdes = SCM_FPORT_FDES (object);
       SCM_SYSCALL (rv = fchmod (fdes, scm_to_int (mode)));
+      scm_remember_upto_here_1 (object);
     }
   else
 #endif
diff --git a/libguile/fports.c b/libguile/fports.c
index 4a3c30b88..5c59f0958 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -480,6 +480,7 @@ fport_input_waiting (SCM port)
   if (poll (&pollfd, 1, 0) < 0)
     scm_syserror ("fport_input_waiting");
 
+  scm_remember_upto_here_1 (port);
   return pollfd.revents & POLLIN ? 1 : 0;
 }
 
@@ -606,6 +607,7 @@ fport_read (SCM port, SCM dst, size_t start, size_t count)
         return -1;
       scm_syserror ("fport_read");
     }
+  scm_remember_upto_here_1 (port);
   return ret;
 }
 
@@ -630,6 +632,7 @@ fport_write (SCM port, SCM src, size_t start, size_t count)
       scm_syserror ("fport_write");
     }
 
+  scm_remember_upto_here_1 (port);
   return ret;
 }
 
@@ -640,6 +643,7 @@ fport_seek (SCM port, scm_t_off offset, int whence)
   scm_t_off result;
 
   result = lseek (fp->fdes, offset, whence);
+  scm_remember_upto_here_1 (port);
 
   if (result == -1)
     scm_syserror ("fport_seek");
@@ -654,6 +658,8 @@ fport_truncate (SCM port, scm_t_off length)
 
   if (ftruncate (fp->fdes, length) == -1)
     scm_syserror ("ftruncate");
+
+  scm_remember_upto_here_1 (port);
 }
 
 static void
@@ -673,6 +679,8 @@ fport_close (SCM port)
        Instead just throw an error if close fails, trusting that the fd
        was cleaned up.  */
     scm_syserror ("fport_close");
+
+  scm_remember_upto_here_1 (port);
 }
 
 static int
@@ -686,6 +694,7 @@ fport_random_access_p (SCM port)
   if (lseek (fp->fdes, 0, SEEK_CUR) == -1)
     return 0;
 
+  scm_remember_upto_here_1 (port);
   return 1;
 }
 
@@ -705,6 +714,8 @@ fport_get_natural_buffer_sizes (SCM port, size_t *read_size, size_t *write_size)
 
   if (fstat (fp->fdes, &st) == 0)
     *read_size = *write_size = st.st_blksize;
+
+  scm_remember_upto_here_1 (port);
 #endif
 }
 
diff --git a/libguile/ioext.c b/libguile/ioext.c
index d08b68df3..9dc1980dd 100644
--- a/libguile/ioext.c
+++ b/libguile/ioext.c
@@ -140,6 +140,7 @@ SCM_DEFINE (scm_dup_to_fdes, "dup->fdes", 1, 1, 0,
   if (SCM_UNBNDP (fd))
     {
       newfd = dup (oldfd);
+      scm_remember_upto_here_1 (fd_or_port);
       if (newfd == -1)
 	SCM_SYSERROR;
       fd = scm_from_int (newfd);
@@ -151,6 +152,7 @@ SCM_DEFINE (scm_dup_to_fdes, "dup->fdes", 1, 1, 0,
 	{
 	  scm_evict_ports (newfd);	/* see scsh manual.  */
 	  rv = dup2 (oldfd, newfd);
+	  scm_remember_upto_here_1 (fd_or_port);
 	  if (rv == -1)
 	    SCM_SYSERROR;
 	}
@@ -179,6 +181,7 @@ SCM_DEFINE (scm_dup2, "dup2", 2, 0, 0,
   c_oldfd = scm_to_int (oldfd);
   c_newfd = scm_to_int (newfd);
   rv = dup2 (c_oldfd, c_newfd);
+  scm_remember_upto_here_2 (oldfd, newfd);
   if (rv == -1)
     SCM_SYSERROR;
   return SCM_UNSPECIFIED;
@@ -219,7 +222,8 @@ SCM_DEFINE (scm_isatty_p, "isatty?", 1, 0, 0,
     return SCM_BOOL_F;
   
   rv = isatty (SCM_FPORT_FDES (port));
-  return  scm_from_bool(rv);
+  scm_remember_upto_here_1 (port);
+  return scm_from_bool(rv);
 }
 #undef FUNC_NAME
 
@@ -278,6 +282,7 @@ SCM_DEFINE (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0,
   stream->fdes = new_fd;
   scm_run_fdes_finalizers (old_fd);
   SCM_SYSCALL (close (old_fd));  
+  scm_remember_upto_here_1 (port);
   return SCM_BOOL_T;
 }
 #undef FUNC_NAME
diff --git a/libguile/posix.c b/libguile/posix.c
index 47769003a..f76722a43 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -1029,6 +1029,7 @@ SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0,
 
   SCM_SYSCALL (result = ttyname (fd));
   err = errno;
+  scm_remember_upto_here_1 (port);
   if (result != NULL)
     result = strdup (result);
 
@@ -1093,6 +1094,7 @@ SCM_DEFINE (scm_tcgetpgrp, "tcgetpgrp", 1, 0, 0,
   fd = SCM_FPORT_FDES (port);
   if ((pgid = tcgetpgrp (fd)) == -1)
     SCM_SYSERROR;
+  scm_remember_upto_here_1 (port);
   return scm_from_int (pgid);
 }
 #undef FUNC_NAME    
@@ -1116,6 +1118,7 @@ SCM_DEFINE (scm_tcsetpgrp, "tcsetpgrp", 2, 0, 0,
   fd = SCM_FPORT_FDES (port);
   if (tcsetpgrp (fd, scm_to_int (pgid)) == -1)
     SCM_SYSERROR;
+  scm_remember_upto_here_1 (port);
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
@@ -1404,19 +1407,21 @@ scm_piped_process (SCM prog, SCM args, SCM from, SCM to)
     }
 
   {
-    SCM port;
-
-    if (SCM_OPOUTFPORTP ((port = scm_current_error_port ())))
-      err = SCM_FPORT_FDES (port);
-    if (out == -1 && SCM_OPOUTFPORTP ((port = scm_current_output_port ())))
-      out = SCM_FPORT_FDES (port);
-    if (in == -1 && SCM_OPINFPORTP ((port = scm_current_input_port ())))
-      in = SCM_FPORT_FDES (port);
+    SCM error_port, output_port = SCM_UNDEFINED, input_port = SCM_UNDEFINED;
+
+    if (SCM_OPOUTFPORTP ((error_port = scm_current_error_port ())))
+      err = SCM_FPORT_FDES (error_port);
+    if (out == -1 && SCM_OPOUTFPORTP ((output_port = scm_current_output_port ())))
+      out = SCM_FPORT_FDES (output_port);
+    if (in == -1 && SCM_OPINFPORTP ((input_port = scm_current_input_port ())))
+      in = SCM_FPORT_FDES (input_port);
+
+    pid = start_child (exec_file, exec_argv, reading, c2p, writing, p2c,
+                       in, out, err);
+    scm_remember_upto_here_2 (input_port, output_port);
+    scm_remember_upto_here (error_port);
   }
 
-  pid = start_child (exec_file, exec_argv, reading, c2p, writing, p2c,
-                     in, out, err);
-
   if (pid == -1)
     {
       int errno_save = errno;
@@ -2241,6 +2246,7 @@ SCM_DEFINE (scm_flock, "flock", 2, 0, 0,
     }
   if (flock (fdes, scm_to_int (operation)) == -1)
     SCM_SYSERROR;
+  scm_remember_upto_here_1 (file);
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
diff --git a/libguile/rw.c b/libguile/rw.c
index 7afae1c63..ff1b2f7d1 100644
--- a/libguile/rw.c
+++ b/libguile/rw.c
@@ -109,6 +109,7 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0,
   size_t offset;
   long read_len;
   long chars_read = 0;
+  SCM port = SCM_UNDEFINED;
   int fdes;
 
   {
@@ -124,8 +125,8 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0,
     fdes = scm_to_int (port_or_fdes);
   else
     {
-      SCM port = (SCM_UNBNDP (port_or_fdes)?
-		  scm_current_input_port () : port_or_fdes);
+      port = (SCM_UNBNDP (port_or_fdes)?
+              scm_current_input_port () : port_or_fdes);
 
       SCM_VALIDATE_OPFPORT (2, port);
       SCM_VALIDATE_INPUT_PORT (2, port);
@@ -162,7 +163,13 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0,
 	}
     }
 
-  scm_remember_upto_here_1 (str);
+  /* We need to remember 'port' here; 'port_or_fdes' won't suffice
+     as '(current-input-port)' can be assigned to 'port'
+     and the '(current-input-port)' can be changed by an asynchronuous
+     interrupt, potentially allowing the old input port to be garbage
+     collected and closed, even though the system call still requires
+     its file descriptor. */
+  scm_remember_upto_here_2 (port, str);
   return scm_from_long (chars_read);
 }
 #undef FUNC_NAME
@@ -214,6 +221,7 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0,
   const char *src;
   scm_t_off write_len;
   int fdes;
+  SCM port = SCM_UNDEFINED;
 
   {
     size_t offset;
@@ -234,8 +242,8 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0,
     fdes = scm_to_int (port_or_fdes);
   else
     {
-      SCM port = (SCM_UNBNDP (port_or_fdes)?
-		  scm_current_output_port () : port_or_fdes);
+      port = (SCM_UNBNDP (port_or_fdes)?
+              scm_current_output_port () : port_or_fdes);
       SCM write_buf;
       size_t end;
 
@@ -266,7 +274,13 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0,
 	  SCM_SYSERROR;
       }
 
-    scm_remember_upto_here_1 (str);
+    /* We need to rememember 'port'; remembering 'port_or_fdes' won't
+       suffice as '(current-output-port)' can be assigned to 'port'
+       and the '(current-output-port)' can be changed by an asynchronuous
+       interrupt, potentially allowing the old output port to be garbage
+       collected and closed even though the 'write' system call still
+       requires the file descriptor. */
+    scm_remember_upto_here_2 (str, port);
     return scm_from_long (rv);
   }
 }
diff --git a/libguile/socket.c b/libguile/socket.c
index 8af6f57bf..8b9e64a8b 100644
--- a/libguile/socket.c
+++ b/libguile/socket.c
@@ -503,6 +503,7 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0,
   if (getsockopt (fd, ilevel, ioptname, (void *) &optval, &optlen) == -1)
     SCM_SYSERROR;
 
+  scm_remember_upto_here_1 (sock);
   if (ilevel == SOL_SOCKET)
     {
 #ifdef SO_LINGER
@@ -673,6 +674,8 @@ SCM_DEFINE (scm_setsockopt, "setsockopt", 4, 0, 0,
 
   if (setsockopt (fd, ilevel, ioptname, optval, optlen) == -1)
     SCM_SYSERROR;
+
+  scm_remember_upto_here_1 (sock);
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
@@ -707,6 +710,7 @@ SCM_DEFINE (scm_shutdown, "shutdown", 2, 0, 0,
   fd = SCM_FPORT_FDES (sock);
   if (shutdown (fd, scm_to_signed_integer (how, 0, 2)) == -1)
     SCM_SYSERROR;
+  scm_remember_upto_here_1 (sock);
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
@@ -876,6 +880,7 @@ SCM_DEFINE (scm_connect, "connect", 2, 1, 1,
       SCM_SYSERROR;
     }
   free (soka);
+  scm_remember_upto_here_1 (sock);
   return SCM_BOOL_T;
 }
 #undef FUNC_NAME
@@ -946,6 +951,7 @@ SCM_DEFINE (scm_bind, "bind", 2, 1, 1,
     SCM_SYSERROR;
   }
   free (soka);
+  scm_remember_upto_here_1 (sock);
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
@@ -967,6 +973,7 @@ SCM_DEFINE (scm_listen, "listen", 2, 0, 0,
   fd = SCM_FPORT_FDES (sock);
   if (listen (fd, scm_to_int (backlog)) == -1)
     SCM_SYSERROR;
+  scm_remember_upto_here_1 (sock);
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
@@ -1284,6 +1291,7 @@ SCM_DEFINE (scm_accept4, "accept", 1, 1, 0,
         return SCM_BOOL_F;
       SCM_SYSERROR;
     }
+  scm_remember_upto_here_1 (sock);
   newsock = scm_socket_fd_to_port (newfd);
   address = _scm_from_sockaddr (&addr, addr_size, FUNC_NAME);
 
@@ -1314,6 +1322,7 @@ SCM_DEFINE (scm_getsockname, "getsockname", 1, 0, 0,
   if (getsockname (fd, (struct sockaddr *) &addr, &addr_size) == -1)
     SCM_SYSERROR;
 
+  scm_remember_upto_here_1 (sock);
   return _scm_from_sockaddr (&addr, addr_size, FUNC_NAME);
 }
 #undef FUNC_NAME
@@ -1336,6 +1345,7 @@ SCM_DEFINE (scm_getpeername, "getpeername", 1, 0, 0,
   if (getpeername (fd, (struct sockaddr *) &addr, &addr_size) == -1)
     SCM_SYSERROR;
 
+  scm_remember_upto_here_1 (sock);
   return _scm_from_sockaddr (&addr, addr_size, FUNC_NAME);
 }
 #undef FUNC_NAME
@@ -1381,7 +1391,7 @@ SCM_DEFINE (scm_recv, "recv!", 2, 1, 0,
   if (SCM_UNLIKELY (rv == -1))
     SCM_SYSERROR;
 
-  scm_remember_upto_here (buf);
+  scm_remember_upto_here_2 (sock, buf);
   return scm_from_int (rv);
 }
 #undef FUNC_NAME
@@ -1426,7 +1436,7 @@ SCM_DEFINE (scm_send, "send", 2, 1, 0,
   if (rv == -1)
     SCM_SYSERROR;
 
-  scm_remember_upto_here_1 (message);
+  scm_remember_upto_here_2 (sock, message);
   return scm_from_int (rv);
 }
 #undef FUNC_NAME
@@ -1504,6 +1514,7 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0,
   if (rv == -1)
     SCM_SYSERROR;
 
+  scm_remember_upto_here_1 (sock);
   /* `recvfrom' does not necessarily return an address.  Usually nothing
      is returned for stream sockets.  */
   if (((struct sockaddr *) &addr)->sa_family != AF_UNSPEC)
@@ -1586,7 +1597,7 @@ SCM_DEFINE (scm_sendto, "sendto", 3, 1, 1,
     }
   free (soka);
 
-  scm_remember_upto_here_1 (message);
+  scm_remember_upto_here_2 (sock, message);
   return scm_from_int (rv);
 }
 #undef FUNC_NAME
-- 
2.30.1


[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]