Allow garbage collection of revealed file ports.

Reported at <https://bugs.gnu.org/28784>.
Discussed at
<https://lists.gnu.org/archive/html/guile-devel/2017-10/msg00003.html>.

* libguile/fports.c (revealed_ports, revealed_lock): Remove.
(scm_revealed_count): Just return 'SCM_REVEALED (port)'.
(scm_set_port_revealed_x, scm_adjust_port_revealed_x): Remove
REVEALED_PORTS manipulation.
(fport_close): Do nothing when SCM_REVEALED (port) > 0.
* libguile/fports.h (scm_t_fport): Adjust comment; make 'revealed'
unsigned.
* libguile/ports.c (do_close): Call 'close_port' instead of
'scm_close_port'.
(scm_close_port): Rename to...
(close_port): ... this.  Add 'explicit' parameter.  Clear 'revealed'
field when PORT is a file port and EXPLICIT is true.
(scm_close_port): Call 'close_port'.
* test-suite/tests/ports.test ("close-port & revealed port")
("revealed port fdes not closed"): New tests.

libguile/fports.c

@@ -1,6 +1,6 @@
 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
  *   2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013,
- *   2014, 2015 Free Software Foundation, Inc.
+ *   2014, 2015, 2017 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -467,8 +467,6 @@ fport_input_waiting (SCM port)
 
 #define SCM_REVEALED(x) (SCM_FSTREAM(x)->revealed)
 
-static SCM revealed_ports = SCM_EOL;
-static scm_i_pthread_mutex_t revealed_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 
 /* Find a port in the table and return its revealed count.
    Also used by the garbage collector.
@@ -476,13 +474,7 @@ static scm_i_pthread_mutex_t revealed_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 int
 scm_revealed_count (SCM port)
 {
-  int ret;
+  return SCM_REVEALED (port);
-
-  scm_i_pthread_mutex_lock (&revealed_lock);
-  ret = SCM_REVEALED (port);
-  scm_i_pthread_mutex_unlock (&revealed_lock);
-
-  return ret;
 }
 
 SCM_DEFINE (scm_port_revealed, "port-revealed", 1, 0, 0,
@@ -503,25 +495,14 @@ SCM_DEFINE (scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0,
 	    "The return value is unspecified.")
 #define FUNC_NAME s_scm_set_port_revealed_x
 {
-  int r, prev;
+  int r;
 
   port = SCM_COERCE_OUTPORT (port);
   SCM_VALIDATE_OPFPORT (1, port);
 
   r = scm_to_int (rcount);
-
-  scm_i_pthread_mutex_lock (&revealed_lock);
-
-  prev = SCM_REVEALED (port);
   SCM_REVEALED (port) = r;
 
-  if (r && !prev)
-    revealed_ports = scm_cons (port, revealed_ports);
-  else if (prev && !r)
-    revealed_ports = scm_delq_x (port, revealed_ports);
-
-  scm_i_pthread_mutex_unlock (&revealed_lock);
-
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
@@ -539,18 +520,7 @@ SCM_DEFINE (scm_adjust_port_revealed_x, "adjust-port-revealed!", 2, 0, 0,
   SCM_VALIDATE_OPFPORT (1, port);
 
   a = scm_to_int (addend);
-  if (!a)
-    return SCM_UNSPECIFIED;
-
-  scm_i_pthread_mutex_lock (&revealed_lock);
-
   SCM_REVEALED (port) += a;
-  if (SCM_REVEALED (port) == a)
-    revealed_ports = scm_cons (port, revealed_ports);
-  else if (!SCM_REVEALED (port))
-    revealed_ports = scm_delq_x (port, revealed_ports);
-
-  scm_i_pthread_mutex_unlock (&revealed_lock);
 
   return SCM_UNSPECIFIED;
 }
@@ -668,6 +638,11 @@ fport_close (SCM port)
 {
   scm_t_fport *fp = SCM_FSTREAM (port);
 
+  if (SCM_REVEALED (port) > 0)
+    /* The port has a non-zero revealed count, so don't close the
+       underlying file descriptor.  */
+    return;
+
   scm_run_fdes_finalizers (fp->fdes);
   if (close (fp->fdes) != 0)
     /* It's not useful to retry after EINTR, as the file descriptor is

libguile/fports.h

@@ -3,7 +3,8 @@
 #ifndef SCM_FPORTS_H
 #define SCM_FPORTS_H
 
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1995-2001, 2006, 2008, 2009, 2011, 2012,
+ *   2017 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -33,9 +34,8 @@
 typedef struct scm_t_fport {
   /* The file descriptor.  */
   int fdes;
-  /* Revealed count; 0 indicates not revealed, > 1 revealed. Revealed
+  /* Revealed count; 0 indicates not revealed, > 1 revealed.  */
-     ports do not get garbage-collected.  */
+  unsigned int revealed;
-  int revealed;
   /* Set of scm_fport_option flags.  */
   unsigned options;
 } scm_t_fport;

libguile/ports.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 1995-2001, 2003-2004, 2006-2016
+/* Copyright (C) 1995-2001, 2003-2004, 2006-2017
  * Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
@@ -680,10 +680,12 @@ SCM scm_i_port_weak_set;
 
 /* Port finalization.  */
 
+static SCM close_port (SCM, int);
+
 static SCM
 do_close (void *data)
 {
-  return scm_close_port (SCM_PACK_POINTER (data));
+  return close_port (SCM_PACK_POINTER (data), 0);
 }
 
 /* Finalize the object (a port) pointed to by PTR.  */
@@ -859,6 +861,33 @@ SCM_DEFINE (scm_eof_object_p, "eof-object?", 1, 0, 0,
 
 /* Closing ports.  */
 
+/* Close PORT.  If EXPLICIT is true, then we are explicitly closing PORT
+   with 'close-port'; otherwise PORT is just being GC'd.  */
+static SCM
+close_port (SCM port, int explicit)
+{
+  if (SCM_CLOSEDP (port))
+    return SCM_BOOL_F;
+
+  /* May throw an exception.  */
+  if (SCM_OUTPUT_PORT_P (port))
+    scm_flush (port);
+
+  if (explicit && SCM_FPORTP (port))
+    /* We're closing PORT explicitly so clear its revealed count so that
+       it really gets closed.  */
+    SCM_FSTREAM (port)->revealed = 0;
+
+  SCM_CLR_PORT_OPEN_FLAG (port);
+
+  if (SCM_PORT_TYPE (port)->flags & SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC)
+    scm_weak_set_remove_x (scm_i_port_weak_set, port);
+
+  release_port (port);
+
+  return SCM_BOOL_T;
+}
+
 SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0,
            (SCM port),
 	    "Close the specified port object.  Return @code{#t} if it\n"
@@ -872,21 +901,7 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0,
   port = SCM_COERCE_OUTPORT (port);
   SCM_VALIDATE_PORT (1, port);
 
-  if (SCM_CLOSEDP (port))
+  return close_port (port, 1);
-    return SCM_BOOL_F;
-
-  /* May throw an exception.  */
-  if (SCM_OUTPUT_PORT_P (port))
-    scm_flush (port);
-
-  SCM_CLR_PORT_OPEN_FLAG (port);
-
-  if (SCM_PORT_TYPE (port)->flags & SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC)
-    scm_weak_set_remove_x (scm_i_port_weak_set, port);
-
-  release_port (port);
-
-  return SCM_BOOL_T;
 }
 #undef FUNC_NAME
 

test-suite/tests/ports.test

@@ -602,6 +602,34 @@
                           (pass-if "unread residue"
                                    (string=? (read-line) "moon"))))
 
+(pass-if-equal "close-port & revealed port"
+    EBADF
+  (let* ((port (open-file "/dev/null" "r0"))
+         (fdes (port->fdes port)))    ;increments revealed count of PORT
+    (close-port port)                 ;closes FDES as a side-effect
+    (catch 'system-error
+      (lambda ()
+        (seek fdes 0 SEEK_CUR)
+        #f)
+      (lambda args
+        (system-error-errno args)))))
+
+(pass-if "revealed port fdes not closed"
+  (let* ((port (open-file "/dev/null" "r0"))
+         (fdes (port->fdes port))     ;increments revealed count of PORT
+         (guardian (make-guardian)))
+    (guardian port)
+    (set! port #f)
+    (gc)
+    (if (port? (guardian))
+        (and (zero? (seek fdes 0 SEEK_CUR))
+             (begin
+               (close-fdes fdes)
+               #t))
+        (begin
+          (close-fdes fdes)
+          (throw 'unresolved)))))
+
 (when (provided? 'threads)
   (let* ((p (pipe))
          (r (car p))