Add file descriptor finalizers

* doc/ref/posix.texi (Ports and File Descriptors): Document new
  interfaces.
* libguile/filesys.c (scm_close, scm_close_fdes)
* libguile/fports.c (fport_close):
* libguile/ioext.c (scm_primitive_move_to_fdes): Call
  scm_run_fdes_finalizers.
* module/ice-9/fdes-finalizers.scm:
* test-suite/tests/fdes-finalizers.test:
* libguile/fdes-finalizers.h:
* libguile/fdes-finalizers.c: New files.
* module/Makefile.am:
* test-suite/Makefile.am:
* libguile/Makefile.am:
* libguile.h:
* libguile/init.c: Wire up new files.

13 files changed, 314 insertions, 0 deletions

diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index da14b83ae..a78617dc2 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -559,6 +559,51 @@ Duplicates in the input vectors appear only once in output.
 An additional @code{select!} interface is provided.
 @end deffn
 
+While it is sometimes necessary to operate at the level of file
+descriptors, this is an operation whose correctness can only be
+considered as part of a whole program.  So for example while the effects
+of @code{(string-set! x 34 #\y)} are limited to the bits of code that
+can access @var{x}, @code{(close-fdes 34)} mutates the state of the
+entire process.  In particular if another thread is using file
+descriptor 34 then their state might be corrupted; and another thread
+which opens a file might cause file descriptor 34 to be re-used, so that
+corruption could manifest itself in a strange way.
+
+@cindex fdes finalizers
+@cindex file descriptor finalizers
+@cindex finalizers, file descriptor
+However when working with file descriptors, it's common to want to
+associate information with the file descriptor, perhaps in a side table.
+To support this use case and to allow user code to remove an association
+when a file descriptor is closed, Guile offers @dfn{fdes finalizers}.
+
+As the name indicates, fdes finalizers are finalizers -- they can run in
+response to garbage collection, and they can also run in response to
+explicit calls to @code{close-port}, @code{close-fdes}, or the like.  As
+such they inherit many of the pitfalls of finalizers: they may be
+invoked from concurrent threads, or not at all.  @xref{Foreign Object
+Memory Management}, for more on finalizers.
+
+To use fdes finalizers, import their module;
+
+@example
+(use-modules (ice-9 fdes-finalizers))
+@end example
+
+@deffn {Scheme Procedure} add-fdes-finalizer! fdes finalizer
+@deffnx {Scheme Procedure} remove-fdes-finalizer! fdes finalizer
+Add or remove a finalizer for @var{fdes}.  A finalizer is a procedure
+that is called by Guile when a file descriptor is closed.  The file
+descriptor being closed is passed as the one argument to the finalizer.
+If a finalizer has been added multiple times to a file descriptor, to
+remove it would require that number of calls to
+@code{remove-fdes-finalizer!}.
+
+The finalizers added to a file descriptor are called by Guile in an
+unspecified order, and their return values are ignored.
+@end deffn
+
+
 @node File System
 @subsection File System
 @cindex file system
diff --git a/libguile.h b/libguile.h
index 4904d6980..d2030eb86 100644
--- a/libguile.h
+++ b/libguile.h
@@ -47,6 +47,7 @@ extern "C" {
 #include "libguile/eval.h"
 #include "libguile/evalext.h"
 #include "libguile/extensions.h"
+#include "libguile/fdes-finalizers.h"
 #include "libguile/feature.h"
 #include "libguile/filesys.h"
 #include "libguile/finalizers.h"
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index dab09e1a3..8161ade4e 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -143,6 +143,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES =				\
 	evalext.c				\
 	expand.c				\
 	extensions.c				\
+	fdes-finalizers.c			\
 	feature.c				\
 	filesys.c				\
 	finalizers.c				\
@@ -252,6 +253,7 @@ DOT_X_FILES =					\
 	evalext.x				\
 	expand.x				\
 	extensions.x				\
+	fdes-finalizers.x			\
 	feature.x				\
 	filesys.x				\
 	fluids.x				\
@@ -358,6 +360,7 @@ DOT_DOC_FILES = 				\
 	evalext.doc				\
 	expand.doc				\
 	extensions.doc				\
+	fdes-finalizers.doc			\
 	feature.doc				\
 	filesys.doc 				\
 	fluids.doc				\
@@ -586,6 +589,7 @@ modinclude_HEADERS =				\
 	evalext.h				\
 	expand.h				\
 	extensions.h				\
+	fdes-finalizers.h			\
 	feature.h				\
 	finalizers.h				\
 	filesys.h				\
diff --git a/libguile/fdes-finalizers.c b/libguile/fdes-finalizers.c
new file mode 100644
index 000000000..fd4689e13
--- /dev/null
+++ b/libguile/fdes-finalizers.c
@@ -0,0 +1,129 @@
+/* Copyright (C) 2016  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
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library 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
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/hashtab.h"
+#include "libguile/numbers.h"
+#include "libguile/fdes-finalizers.h"
+
+
+
+/* Table of fdes finalizers and associated lock.  */
+static scm_i_pthread_mutex_t fdes_finalizers_lock =
+  SCM_I_PTHREAD_MUTEX_INITIALIZER;
+static SCM fdes_finalizers;
+
+SCM_DEFINE (scm_add_fdes_finalizer_x, "add-fdes-finalizer!", 2, 0, 0,
+            (SCM fd, SCM finalizer),
+	    "Add a finalizer that will be called when @var{fd} is closed.")
+#define FUNC_NAME s_scm_add_fdes_finalizer_x
+{
+  SCM h;
+
+  /* Check type.  */
+  scm_to_uint (fd);
+
+  scm_i_pthread_mutex_lock (&fdes_finalizers_lock);
+  h = scm_hashv_create_handle_x (fdes_finalizers, fd, SCM_EOL);
+  scm_set_cdr_x (h, scm_cons (finalizer, scm_cdr (h)));
+  scm_i_pthread_mutex_unlock (&fdes_finalizers_lock);
+
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_remove_fdes_finalizer_x, "remove-fdes-finalizer!", 2, 0, 0,
+            (SCM fd, SCM finalizer),
+	    "Remove a finalizer that was previously added to the file\n"
+            "descriptor @var{fd}.")
+#define FUNC_NAME s_scm_remove_fdes_finalizer_x
+{
+  SCM h;
+
+  /* Check type.  */
+  scm_to_uint (fd);
+
+  scm_i_pthread_mutex_lock (&fdes_finalizers_lock);
+  h = scm_hashv_get_handle (fdes_finalizers, fd);
+  if (scm_is_true (h))
+    scm_set_cdr_x (h, scm_delq1_x (finalizer, scm_cdr (h)));
+  scm_i_pthread_mutex_unlock (&fdes_finalizers_lock);
+
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+struct fdes_finalizer_data
+{
+  SCM finalizer;
+  SCM fd;
+};
+
+static SCM
+do_run_finalizer (void *data)
+{
+  struct fdes_finalizer_data *fdata = data;
+  return scm_call_1 (fdata->finalizer, fdata->fd);
+}
+
+void
+scm_run_fdes_finalizers (int fd)
+{
+  SCM finalizers;
+  struct fdes_finalizer_data data;
+
+  data.fd = scm_from_int (fd);
+
+  scm_i_pthread_mutex_lock (&fdes_finalizers_lock);
+  finalizers = scm_hashv_ref (fdes_finalizers, data.fd, SCM_EOL);
+  if (!scm_is_null (finalizers))
+    scm_hashv_remove_x (fdes_finalizers, data.fd);
+  scm_i_pthread_mutex_unlock (&fdes_finalizers_lock);
+
+  for (; !scm_is_null (finalizers); finalizers = scm_cdr (finalizers))
+    {
+      data.finalizer = scm_car (finalizers);
+      scm_internal_catch (SCM_BOOL_T, do_run_finalizer, &data,
+                          scm_handle_by_message_noexit, NULL);
+    }
+}
+
+
+
+
+static void
+scm_init_fdes_finalizers (void)
+{
+#include "libguile/fdes-finalizers.x"
+}
+
+void
+scm_register_fdes_finalizers ()
+{
+  fdes_finalizers = scm_c_make_hash_table (0);
+
+  scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+                            "scm_init_fdes_finalizers",
+                            (scm_t_extension_init_func) scm_init_fdes_finalizers,
+                            NULL);
+}
diff --git a/libguile/fdes-finalizers.h b/libguile/fdes-finalizers.h
new file mode 100644
index 000000000..cadbb0404
--- /dev/null
+++ b/libguile/fdes-finalizers.h
@@ -0,0 +1,34 @@
+#ifndef SCM_FDES_FINALIZERS_H
+#define SCM_FDES_FINALIZERS_H
+
+/* Copyright (C) 2016  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
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library 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
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+
+#include "libguile/__scm.h"
+
+
+
+SCM_INTERNAL SCM scm_add_fdes_finalizer_x (SCM fd, SCM finalizer);
+SCM_INTERNAL SCM scm_remove_fdes_finalizer_x (SCM fd, SCM finalizer);
+SCM_INTERNAL void scm_run_fdes_finalizers (int fd);
+
+SCM_INTERNAL void scm_register_fdes_finalizers (void);
+
+#endif  /* SCM_FDES_FINALIZERS_H */
diff --git a/libguile/filesys.c b/libguile/filesys.c
index c4f2653c2..0bc366953 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -43,6 +43,7 @@
 
 #include "libguile/_scm.h"
 #include "libguile/smob.h"
+#include "libguile/fdes-finalizers.h"
 #include "libguile/feature.h"
 #include "libguile/fports.h"
 #include "libguile/strings.h"
@@ -290,6 +291,7 @@ SCM_DEFINE (scm_close, "close", 1, 0, 0,
     return scm_close_port (fd_or_port);
   fd = scm_to_int (fd_or_port);
   scm_evict_ports (fd);		/* see scsh manual.  */
+  scm_run_fdes_finalizers (fd);
   SCM_SYSCALL (rv = close (fd));
   /* following scsh, closing an already closed file descriptor is
      not an error.  */
@@ -312,6 +314,7 @@ SCM_DEFINE (scm_close_fdes, "close-fdes", 1, 0, 0,
   int rv;
 
   c_fd = scm_to_int (fd);
+  scm_run_fdes_finalizers (c_fd);
   SCM_SYSCALL (rv = close (c_fd));
   if (rv < 0)
     SCM_SYSERROR;
diff --git a/libguile/fports.c b/libguile/fports.c
index f535f8a25..5886f628d 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -49,6 +49,7 @@
 #include <full-write.h>
 
 #include "libguile/_scm.h"
+#include "libguile/fdes-finalizers.h"
 #include "libguile/strings.h"
 #include "libguile/validate.h"
 #include "libguile/gc.h"
@@ -656,6 +657,7 @@ fport_close (SCM port)
 {
   scm_t_fport *fp = SCM_FSTREAM (port);
 
+  scm_run_fdes_finalizers (fp->fdes);
   if (close (fp->fdes) != 0)
     /* It's not useful to retry after EINTR, as the file descriptor is
        in an undefined state.  See http://lwn.net/Articles/365294/.
diff --git a/libguile/init.c b/libguile/init.c
index 7e0c30d9c..1e4889c97 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -56,6 +56,7 @@
 #include "libguile/eval.h"
 #include "libguile/evalext.h"
 #include "libguile/expand.h"
+#include "libguile/fdes-finalizers.h"
 #include "libguile/feature.h"
 #include "libguile/filesys.h"
 #include "libguile/finalizers.h"
@@ -398,6 +399,7 @@ scm_i_init_guile (void *base)
   scm_bootstrap_programs ();
   scm_bootstrap_vm ();
   scm_register_r6rs_ports ();
+  scm_register_fdes_finalizers ();
   scm_register_foreign ();
   scm_register_foreign_object ();
   scm_register_srfi_1 ();
diff --git a/libguile/ioext.c b/libguile/ioext.c
index 58a6219f3..43c915a09 100644
--- a/libguile/ioext.c
+++ b/libguile/ioext.c
@@ -29,6 +29,7 @@
 
 #include "libguile/_scm.h"
 #include "libguile/dynwind.h"
+#include "libguile/fdes-finalizers.h"
 #include "libguile/feature.h"
 #include "libguile/fports.h"
 #include "libguile/hashtab.h"
@@ -266,6 +267,7 @@ SCM_DEFINE (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0,
   if (rv == -1)
     SCM_SYSERROR;
   stream->fdes = new_fd;
+  scm_run_fdes_finalizers (old_fd);
   SCM_SYSCALL (close (old_fd));  
   return SCM_BOOL_T;
 }
diff --git a/module/Makefile.am b/module/Makefile.am
index f590fb96d..00c394738 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -59,6 +59,7 @@ SOURCES =					\
   ice-9/eval-string.scm				\
   ice-9/eval.scm				\
   ice-9/expect.scm				\
+  ice-9/fdes-finalizers.scm			\
   ice-9/format.scm				\
   ice-9/ftw.scm					\
   ice-9/futures.scm				\
diff --git a/module/ice-9/fdes-finalizers.scm b/module/ice-9/fdes-finalizers.scm
new file mode 100644
index 000000000..acb2ed1c3
--- /dev/null
+++ b/module/ice-9/fdes-finalizers.scm
@@ -0,0 +1,25 @@
+;;;; 	Copyright (C) 2016 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
+;;;; as published by the Free Software Foundation; either version 3 of
+;;;; the License, or (at your option) any later version.
+;;;;
+;;;; This library 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
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+
+(define-module (ice-9 fdes-finalizers)
+  #:export (add-fdes-finalizer!
+            remove-fdes-finalizer!))
+
+(eval-when (expand load eval)
+  (load-extension (string-append "libguile-" (effective-version))
+                  "scm_init_fdes_finalizers"))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 473501ee2..3c88405cb 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -54,6 +54,7 @@ SCM_TESTS = tests/00-initial-env.test		\
 	    tests/eval.test			\
 	    tests/eval-string.test		\
 	    tests/exceptions.test		\
+	    tests/fdes-finalizers.test		\
 	    tests/filesys.test			\
 	    tests/fluids.test			\
 	    tests/foreign.test			\
diff --git a/test-suite/tests/fdes-finalizers.test b/test-suite/tests/fdes-finalizers.test
new file mode 100644
index 000000000..6d48fa918
--- /dev/null
+++ b/test-suite/tests/fdes-finalizers.test
@@ -0,0 +1,65 @@
+;;;; 	Copyright (C) 2016 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 as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library 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
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-fdes-finalizers)
+  #:use-module (test-suite lib)
+  #:use-module (test-suite guile-test)
+  #:use-module (ice-9 fdes-finalizers))
+
+(define (test-file suffix)
+  (data-file-name (string-append "ports-test.tmp" suffix)))
+
+(close-port (open-output-file (test-file ".1")))
+(close-port (open-output-file (test-file ".2")))
+
+(with-test-prefix "simple"
+  (let* ((call-count 0)
+         (f (lambda (fdes) (set! call-count (1+ call-count))))
+         (p (open-input-file (test-file ".1")))
+         (q (open-input-file (test-file ".2"))))
+    (pass-if-equal 0 call-count)
+    (add-fdes-finalizer! (fileno p) f)
+    (pass-if-equal 0 call-count)
+    (close-port q)
+    (pass-if-equal 0 call-count)
+    (close-port p)
+    (pass-if-equal 1 call-count)))
+
+(with-test-prefix "multiple"
+  (let* ((call-count 0)
+         (f (lambda (fdes) (set! call-count (1+ call-count))))
+         (p (open-input-file (test-file ".1"))))
+    (pass-if-equal 0 call-count)
+    (add-fdes-finalizer! (fileno p) f)
+    (add-fdes-finalizer! (fileno p) f)
+    (pass-if-equal 0 call-count)
+    (close-port p)
+    (pass-if-equal 2 call-count)))
+
+(with-test-prefix "with removal"
+  (let* ((call-count 0)
+         (f (lambda (fdes) (set! call-count (1+ call-count))))
+         (p (open-input-file (test-file ".1"))))
+    (pass-if-equal 0 call-count)
+    (add-fdes-finalizer! (fileno p) f)
+    (add-fdes-finalizer! (fileno p) f)
+    (remove-fdes-finalizer! (fileno p) f)
+    (pass-if-equal 0 call-count)
+    (close-port p)
+    (pass-if-equal 1 call-count)))
+
+(delete-file (test-file ".1"))
+(delete-file (test-file ".2"))