Re: port-for-each vs lazy sweep

[Han-Wen Nienhuys]

Kevin Ryde escreveu:
> I've struck, in 1.8, port-for-each passing a freed cell to its iterator
> func.  Eg. "guile -s foo.scm" on


Hi,

Please see the patch attached.  Comments welcome.

-- 
 Han-Wen Nienhuys - address@hidden - http://www.xs4all.nl/~hanwen

diff --git a/libguile/fports.c b/libguile/fports.c
index 010e5dd..a1c6483 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -31,6 +31,7 @@
 #include "libguile/gc.h"
 #include "libguile/posix.h"
 #include "libguile/dynwind.h"
+#include "libguile/hashtab.h"
 
 #include "libguile/fports.h"
 
@@ -220,32 +221,35 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
 /* Move ports with the specified file descriptor to new descriptors,
  * resetting the revealed count to 0.
  */
-
-void
-scm_evict_ports (int fd)
+static SCM
+scm_i_evict_port (SCM handle, void *closure)
 {
-  long i;
-
-  scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+  int fd = * (int*) closure;
+  SCM port = SCM_CDR(handle);
 
-  for (i = 0; i < scm_i_port_table_size; i++)
+  if (SCM_FPORTP (port))
     {
-      SCM port = scm_i_port_table[i]->port;
+      scm_t_fport *fp = SCM_FSTREAM (port);
 
-      if (SCM_FPORTP (port))
+      if (fp->fdes == fd)
        {
-         scm_t_fport *fp = SCM_FSTREAM (port);
-
-         if (fp->fdes == fd)
-           {
-             fp->fdes = dup (fd);
-             if (fp->fdes == -1)
-               scm_syserror ("scm_evict_ports");
-             scm_set_port_revealed_x (port, scm_from_int (0));
-           }
+         fp->fdes = dup (fd);
+         if (fp->fdes == -1)
+           scm_syserror ("scm_evict_ports");
+         scm_set_port_revealed_x (port, scm_from_int (0));
        }
     }
 
+  return handle;
+}
+
+void
+scm_evict_ports (int fd)
+{
+  scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+  scm_internal_hash_for_each_handle (&scm_i_evict_port,
+                                    (void*) &fd,
+                                    scm_i_port_doubly_weak_hash);
   scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
 }
 
diff --git a/libguile/gc-card.c b/libguile/gc-card.c
index 0639230..7fa1c7c 100644
--- a/libguile/gc-card.c
+++ b/libguile/gc-card.c
@@ -206,8 +206,7 @@ scm_i_sweep_card (scm_t_cell *  p, SCM *free_list, 
scm_t_heap_segment*seg)
                }
 
              SCM_SETSTREAM (scmptr, 0);
-             scm_remove_from_port_table (scmptr);
-             scm_gc_ports_collected++;
+             scm_i_remove_port (scmptr);
              SCM_CLR_PORT_OPEN_FLAG (scmptr);
            }
          break;
diff --git a/libguile/gc.c b/libguile/gc.c
index 9150989..12a0b58 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -232,7 +232,6 @@ static unsigned long protected_obj_count = 0;
 /* The following are accessed from `gc-malloc.c' and `gc-card.c'.  */
 int scm_gc_malloc_yield_percentage = 0;
 unsigned long scm_gc_malloc_collected = 0;
-unsigned long scm_gc_ports_collected = 0;
 
 
 SCM_SYMBOL (sym_cells_allocated, "cells-allocated");
@@ -443,7 +442,6 @@ gc_start_stats (const char *what SCM_UNUSED)
   t_before_gc = scm_c_get_internal_run_time ();
 
   scm_gc_malloc_collected = 0;
-  scm_gc_ports_collected = 0;
 }
 
 static void
@@ -971,14 +969,7 @@ scm_init_storage ()
   scm_gc_init_malloc ();
 
   j = SCM_HEAP_SEG_SIZE;
-
   
-  /* Initialise the list of ports.  */
-  scm_i_port_table = (scm_t_port **)
-    malloc (sizeof (scm_t_port *) * scm_i_port_table_room);
-  if (!scm_i_port_table)
-    return 1;
-
 #if 0
   /* We can't have a cleanup handler since we have no thread to run it
      in. */
diff --git a/libguile/gc.h b/libguile/gc.h
index 78ff024..d3c9959 100644
--- a/libguile/gc.h
+++ b/libguile/gc.h
@@ -278,7 +278,6 @@ SCM_API struct scm_t_cell_type_statistics 
scm_i_master_freelist;
 SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist2;
 
 SCM_API unsigned long scm_gc_malloc_collected;
-SCM_API unsigned long scm_gc_ports_collected;
 SCM_API unsigned long scm_cells_allocated;
 SCM_API int scm_gc_malloc_yield_percentage;
 SCM_API unsigned long scm_mallocated;
diff --git a/libguile/init.c b/libguile/init.c
index ff69ab9..fe7df3a 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -395,6 +395,14 @@ really_cleanup_for_exit (void *unused)
 static void
 cleanup_for_exit ()
 {
+  if (scm_i_pthread_mutex_trylock (&scm_i_init_mutex) == 0)
+    scm_i_pthread_mutex_unlock (&scm_i_init_mutex);
+  else
+    {
+      fprintf(stderr, "Cannot exit gracefully when init is in progress; 
aborting.\n");
+      abort();
+    }
+
   /* This function might be called in non-guile mode, so we need to
      enter it temporarily. 
   */
@@ -472,6 +480,7 @@ scm_i_init_guile (SCM_STACKITEM *base)
   scm_init_backtrace ();       /* Requires fluids */
   scm_init_fports ();
   scm_init_strports ();
+  scm_init_ports ();
   scm_init_gdbint ();           /* Requires strports */
   scm_init_hash ();
   scm_init_hashtab ();
@@ -490,7 +499,6 @@ scm_i_init_guile (SCM_STACKITEM *base)
   scm_init_numbers ();
   scm_init_options ();
   scm_init_pairs ();
-  scm_init_ports ();
 #ifdef HAVE_POSIX
   scm_init_filesys ();
   scm_init_posix ();
diff --git a/libguile/ioext.c b/libguile/ioext.c
index fd232e4..9aaf7ac 100644
--- a/libguile/ioext.c
+++ b/libguile/ioext.c
@@ -26,13 +26,14 @@
 #include <errno.h>
 
 #include "libguile/_scm.h"
-#include "libguile/ioext.h"
-#include "libguile/fports.h"
+#include "libguile/dynwind.h"
 #include "libguile/feature.h"
+#include "libguile/fports.h"
+#include "libguile/hashtab.h"
+#include "libguile/ioext.h"
 #include "libguile/ports.h"
 #include "libguile/strings.h"
 #include "libguile/validate.h"
-#include "libguile/dynwind.h"
 
 #include <fcntl.h>
 
@@ -266,6 +267,19 @@ SCM_DEFINE (scm_primitive_move_to_fdes, 
"primitive-move->fdes", 2, 0, 0,
 }
 #undef FUNC_NAME
 
+static SCM
+get_matching_port (void *closure, SCM key, SCM port, SCM result)
+{
+  int fd = * (int *) closure;
+  scm_t_port *entry = SCM_PTAB_ENTRY (port);
+  
+  if (SCM_OPFPORTP (port)
+      && ((scm_t_fport *) entry->stream)->fdes == fd)
+    result = scm_cons (port, result);
+
+  return result;
+}
+
 /* Return a list of ports using a given file descriptor.  */
 SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0, 
            (SCM fd),
@@ -275,18 +289,12 @@ SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0,
 #define FUNC_NAME s_scm_fdes_to_ports
 {
   SCM result = SCM_EOL;
-  int int_fd;
-  long i;
-
-  int_fd = scm_to_int (fd);
+  int int_fd = scm_to_int (fd);
 
   scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
-  for (i = 0; i < scm_i_port_table_size; i++)
-    {
-      if (SCM_OPFPORTP (scm_i_port_table[i]->port)
-         && ((scm_t_fport *) scm_i_port_table[i]->stream)->fdes == int_fd)
-       result = scm_cons (scm_i_port_table[i]->port, result);
-    }
+  result = scm_internal_hash_fold (get_matching_port,
+                                  (void*) &int_fd, result, 
+                                  scm_i_port_doubly_weak_hash);
   scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
   return result;
 }
diff --git a/libguile/ports.c b/libguile/ports.c
index b1a25aa..5b5f363 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -40,12 +40,14 @@
 #include "libguile/dynwind.h"
 
 #include "libguile/keywords.h"
+#include "libguile/hashtab.h"
 #include "libguile/root.h"
 #include "libguile/strings.h"
 #include "libguile/mallocs.h"
 #include "libguile/validate.h"
 #include "libguile/ports.h"
 #include "libguile/vectors.h"
+#include "libguile/weaks.h"
 #include "libguile/fluids.h"
 
 #ifdef HAVE_STRING_H
@@ -86,7 +88,7 @@
 
 
 /* scm_ptobs scm_numptob
- * implement a dynamicly resized array of ptob records.
+ * implement a dynamically resized array of ptob records.
  * Indexes into this table are used when generating type
  * tags for smobjects (if you know a tag you can get an index and conversely).
  */
@@ -485,10 +487,11 @@ scm_i_dynwind_current_load_port (SCM port)
 
 /* The port table --- an array of pointers to ports.  */
 
-scm_t_port **scm_i_port_table;
-
-long scm_i_port_table_size = 0;        /* Number of ports in scm_i_port_table. 
 */
-long scm_i_port_table_room = 20;       /* Size of the array.  */
+/*
+  We need a global registry of ports to flush them all at exit, and to
+  get all the ports matching a file descriptor.
+ */
+SCM scm_i_port_doubly_weak_hash;
 
 scm_i_pthread_mutex_t scm_i_port_table_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 
@@ -505,29 +508,16 @@ scm_new_port_table_entry (scm_t_bits tag)
   
   SCM z = scm_cons (SCM_EOL, SCM_EOL);
   scm_t_port *entry = (scm_t_port *) scm_gc_calloc (sizeof (scm_t_port), 
"port");
-  if (scm_i_port_table_size == scm_i_port_table_room)
-    {
-      /* initial malloc is in gc.c.  this doesn't use scm_gc_malloc etc.,
-        since it can never be freed during gc.  */
-      void *newt = scm_realloc ((char *) scm_i_port_table,
-                               (size_t) (sizeof (scm_t_port *)
-                                         * scm_i_port_table_room * 2));
-      scm_i_port_table = (scm_t_port **) newt;
-      scm_i_port_table_room *= 2;
-    }
-
-  entry->entry = scm_i_port_table_size;
 
   entry->file_name = SCM_BOOL_F;
   entry->rw_active = SCM_PORT_NEITHER;
-
-  scm_i_port_table[scm_i_port_table_size] = entry;
-  scm_i_port_table_size++;
-
   entry->port = z;
+
   SCM_SET_CELL_TYPE(z, tag);
   SCM_SETPTAB_ENTRY(z, entry);
-  
+
+  scm_hashq_set_x (scm_i_port_doubly_weak_hash, z, z);
+
   return z;
 }
 #undef FUNC_NAME
@@ -542,7 +532,7 @@ scm_add_to_port_table (SCM port)
   pt->port = port;
   SCM_SETCAR(z, SCM_EOL);
   SCM_SETCDR(z, SCM_EOL);
-  SCM_SETPTAB_ENTRY (port, pt);
+  SCM_SETPTAB_ENTRY(port, pt);
   return pt;
 }
 #endif
@@ -551,33 +541,21 @@ scm_add_to_port_table (SCM port)
 /* Remove a port from the table and destroy it.  */
 
 /* This function is not and should not be thread safe. */
-
 void
-scm_remove_from_port_table (SCM port)
-#define FUNC_NAME "scm_remove_from_port_table"
+scm_i_remove_port (SCM port)
+#define FUNC_NAME "scm_remove_port"
 {
   scm_t_port *p = SCM_PTAB_ENTRY (port);
-  long i = p->entry;
-
-  if (i >= scm_i_port_table_size)
-    SCM_MISC_ERROR ("Port not in table: ~S", scm_list_1 (port));
   if (p->putback_buf)
     scm_gc_free (p->putback_buf, p->putback_buf_size, "putback buffer");
   scm_gc_free (p, sizeof (scm_t_port), "port");
-  /* Since we have just freed slot i we can shrink the table by moving
-     the last entry to that slot... */
-  if (i < scm_i_port_table_size - 1)
-    {
-      scm_i_port_table[i] = scm_i_port_table[scm_i_port_table_size - 1];
-      scm_i_port_table[i]->entry = i;
-    }
+
   SCM_SETPTAB_ENTRY (port, 0);
-  scm_i_port_table_size--;
+  scm_hashq_remove_x (scm_i_port_doubly_weak_hash, port);
 }
 #undef FUNC_NAME
 
 
-#ifdef GUILE_DEBUG
 /* Functions for debugging.  */
 
 SCM_DEFINE (scm_pt_size, "pt-size", 0, 0, 0,
@@ -586,26 +564,10 @@ SCM_DEFINE (scm_pt_size, "pt-size", 0, 0, 0,
            "is only included in @code{--enable-guile-debug} builds.")
 #define FUNC_NAME s_scm_pt_size
 {
-  return scm_from_int (scm_i_port_table_size);
+  return scm_from_int (SCM_HASHTABLE_N_ITEMS (scm_i_port_doubly_weak_hash));
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_pt_member, "pt-member", 1, 0, 0,
-            (SCM index),
-           "Return the port at @var{index} in the port table.\n"
-           "@code{pt-member} is only included in\n"
-           "@code{--enable-guile-debug} builds.")
-#define FUNC_NAME s_scm_pt_member
-{
-  size_t i = scm_to_size_t (index);
-  if (i >= scm_i_port_table_size)
-    return SCM_BOOL_F;
-  else
-    return scm_i_port_table[i]->port;
-}
-#undef FUNC_NAME
-#endif
-
 void
 scm_port_non_buffer (scm_t_port *pt)
 {
@@ -762,7 +724,7 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0,
   else
     rv = 0;
   scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
-  scm_remove_from_port_table (port);
+  scm_i_remove_port (port);
   scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
   SCM_CLR_PORT_OPEN_FLAG (port);
   return scm_from_bool (rv >= 0);
@@ -800,10 +762,20 @@ SCM_DEFINE (scm_close_output_port, "close-output-port", 
1, 0, 0,
 }
 #undef FUNC_NAME
 
+static SCM
+scm_i_collect_values_in_vector (void *closure, SCM key, SCM value, SCM result)
+{
+  int *i = (int*) closure;
+  scm_c_vector_set_x (result, *i, value);
+  (*i)++;
+
+  return result;
+}
+
 void
 scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data)
 {
-  long i;
+  int i = 0;
   size_t n;
   SCM ports;
 
@@ -813,20 +785,20 @@ scm_c_port_for_each (void (*proc)(void *data, SCM p), 
void *data)
      collect the ports into a vector. -mvo */
 
   scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
-  n = scm_i_port_table_size;
+  n = SCM_HASHTABLE_N_ITEMS (scm_i_port_doubly_weak_hash);
   scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
-
   ports = scm_c_make_vector (n, SCM_BOOL_F);
 
-  scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
-  if (n > scm_i_port_table_size)
-    n = scm_i_port_table_size;
-  for (i = 0; i < n; i++)
-    SCM_SIMPLE_VECTOR_SET (ports, i, scm_i_port_table[i]->port);
+  scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
+  ports = scm_internal_hash_fold (scm_i_collect_values_in_vector, &i,
+                                 ports, scm_i_port_doubly_weak_hash);
   scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
 
-  for (i = 0; i < n; i++)
-    proc (data, SCM_SIMPLE_VECTOR_REF (ports, i));
+  for (i = 0; i < n; i++) {
+    SCM p = SCM_SIMPLE_VECTOR_REF (ports, i);
+    if (SCM_PORTP(p))
+      proc (data, p);
+  }
 
   scm_remember_upto_here_1 (ports);
 }
@@ -929,21 +901,22 @@ SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0,
 }
 #undef FUNC_NAME
 
+
+static void
+flush_output_port (void *closure, SCM handle)
+{
+  SCM port = SCM_CDR(handle);
+  if (SCM_OPOUTPORTP (port))
+    scm_flush (port);
+}
+
 SCM_DEFINE (scm_flush_all_ports, "flush-all-ports", 0, 0, 0,
             (),
            "Equivalent to calling @code{force-output} on\n"
            "all open output ports.  The return value is unspecified.")
 #define FUNC_NAME s_scm_flush_all_ports
 {
-  size_t i;
-
-  scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
-  for (i = 0; i < scm_i_port_table_size; i++)
-    {
-      if (SCM_OPOUTPORTP (scm_i_port_table[i]->port))
-       scm_flush (scm_i_port_table[i]->port);
-    }
-  scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+  scm_c_port_for_each (&flush_output_port, NULL);
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
@@ -1725,6 +1698,8 @@ scm_init_ports ()
   cur_errport_fluid = scm_permanent_object (scm_make_fluid ());
   cur_loadport_fluid = scm_permanent_object (scm_make_fluid ());
 
+  scm_i_port_doubly_weak_hash = scm_permanent_object 
(scm_make_doubly_weak_hash_table(SCM_I_MAKINUM(31)));
+  
 #include "libguile/ports.x"
 }
 
diff --git a/libguile/ports.h b/libguile/ports.h
index ab04490..ecc4d81 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -47,7 +47,6 @@ typedef enum scm_t_port_rw_active {
 typedef struct 
 {
   SCM port;                    /* Link back to the port object.  */
-  long entry;                  /* Index in port table. */
   int revealed;                        /* 0 not revealed, > 1 revealed.
                                 * Revealed ports do not get GC'd.
                                 */
@@ -109,9 +108,10 @@ typedef struct
   size_t putback_buf_size;        /* allocated size of putback_buf.  */
 } scm_t_port;
 
-SCM_API scm_t_port **scm_i_port_table;
-SCM_API long scm_i_port_table_size; /* Number of ports in scm_i_port_table.  */
+
 SCM_API scm_i_pthread_mutex_t scm_i_port_table_mutex;
+SCM_API SCM scm_i_port_doubly_weak_hash;
+
 
 #define SCM_READ_BUFFER_EMPTY_P(c_port) (c_port->read_pos >= c_port->read_end)
 
@@ -241,7 +241,7 @@ SCM_API void scm_dynwind_current_input_port (SCM port);
 SCM_API void scm_dynwind_current_output_port (SCM port);
 SCM_API void scm_dynwind_current_error_port (SCM port);
 SCM_API SCM scm_new_port_table_entry (scm_t_bits tag);
-SCM_API void scm_remove_from_port_table (SCM port);
+SCM_API void scm_i_remove_port (SCM port);
 SCM_API void scm_grow_port_cbuf (SCM port, size_t requested);
 SCM_API SCM scm_pt_size (void);
 SCM_API SCM scm_pt_member (SCM member);
diff --git a/libguile/weaks.h b/libguile/weaks.h
index ec9e7b4..bf854d5 100644
--- a/libguile/weaks.h
+++ b/libguile/weaks.h
@@ -70,6 +70,7 @@ SCM_API void scm_i_mark_weak_vector (SCM w);
 SCM_API int scm_i_mark_weak_vectors_non_weaks (void);
 SCM_API void scm_i_remove_weaks_from_weak_vectors (void);
 
+
 #endif  /* SCM_WEAKS_H */
 
 /*
diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4
index d921e67..2395b4c 100644
--- a/m4/gnulib-cache.m4
+++ b/m4/gnulib-cache.m4
@@ -23,6 +23,7 @@ gl_MODULES([alloca strcase])
 gl_AVOID([])
 gl_SOURCE_BASE([lib])
 gl_M4_BASE([m4])
+gl_PO_BASE([])
 gl_DOC_BASE([doc])
 gl_TESTS_BASE([tests])
 gl_LIB([libgnu])
@@ -30,3 +31,4 @@ gl_LGPL
 gl_MAKEFILE_NAME([])
 gl_LIBTOOL
 gl_MACRO_PREFIX([gl])
+gl_PO_DOMAIN([])
diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test
index 54eb727..f1ba80b 100644
--- a/test-suite/tests/ports.test
+++ b/test-suite/tests/ports.test
@@ -561,7 +561,6 @@
   ;; table (scm_i_port_table).  Provoking those gc conditions is a little
   ;; tricky, but the following code made it happen in 1.8.2.
   (pass-if "passing freed cell"
-    (throw 'unresolved)
     (let ((lst '()))
       ;; clear out the heap
       (gc) (gc) (gc)
@@ -581,6 +580,13 @@
       ;; freed cells, which give #f from `port?'
       (not (memq #f (map port? lst))))))
 
+(with-test-prefix
+ "fdes->port"
+ (pass-if "fdes->ports finds port"
+         (let ((port (open-file (test-file) "w")))
+
+           (not (not (memq port (fdes->ports (port->fdes port))))))))
+
 ;;;
 ;;; seek
 ;;;