bug#15683: [critical] ERROR: ... close-pipe: pipe not in table

[Mark H Weaver <mhw@netris.org>]

[-- Attachment #1: Type: text/plain, Size: 436 bytes --]

Mark H Weaver <mhw@netris.org> writes:
> Here's a set of patches that should make (ice-9 popen) thread safe.
> I've also pushed these to the 'wip-thread-safe-popen' branch in git.

There was a minor mistake in one of the patches: the new internal scheme
procedures for accessing the port alist declared their arguments as
optional, but they should have been required.

Here are the patches again, with that problem fixed.

      Mark



[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: [PATCH 1/6] Add mutex locking functions that also block asyncs --]
[-- Type: text/x-patch, Size: 2745 bytes --]

From 9b48be7107f3f98cdf2e756d4c1f4c937ff233d7 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Sun, 17 Nov 2013 04:00:29 -0500
Subject: [PATCH 1/6] Add mutex locking functions that also block asyncs.

* libguile/async.h (scm_i_pthread_mutex_lock_with_asyncs,
  scm_i_pthread_mutex_unlock_with_asyncs): New macros.

* libguile/threads.c (do_unlock_with_asyncs): New static helper.
  (scm_i_dynwind_pthread_mutex_lock_with_asyncs): New function.

* libguile/threads.h (scm_i_dynwind_pthread_mutex_lock_with_asyncs):
  Add prototype.
---
 libguile/async.h   |   12 ++++++++++++
 libguile/threads.c |   16 ++++++++++++++++
 libguile/threads.h |    1 +
 3 files changed, 29 insertions(+), 0 deletions(-)

diff --git a/libguile/async.h b/libguile/async.h
index ceb2b96..6d0460c 100644
--- a/libguile/async.h
+++ b/libguile/async.h
@@ -78,6 +78,18 @@ SCM_API void scm_critical_section_end (void);
     scm_async_click ();						\
   } while (0)
 
+# define scm_i_pthread_mutex_lock_with_asyncs(m)    \
+  do {                                              \
+    SCM_I_CURRENT_THREAD->block_asyncs++;           \
+    scm_i_pthread_mutex_lock(m);                    \
+  } while (0)
+
+# define scm_i_pthread_mutex_unlock_with_asyncs(m)  \
+  do {                                              \
+    scm_i_pthread_mutex_unlock(m);                  \
+    SCM_I_CURRENT_THREAD->block_asyncs--;           \
+  } while (0)
+
 #else /* !BUILDING_LIBGUILE */
 
 # define SCM_CRITICAL_SECTION_START  scm_critical_section_start ()
diff --git a/libguile/threads.c b/libguile/threads.c
index 8cbe1e2..6aeaeb9 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -2010,6 +2010,22 @@ scm_pthread_cond_timedwait (scm_i_pthread_cond_t *cond,
 
 #endif
 
+static void
+do_unlock_with_asyncs (void *data)
+{
+  scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t *)data);
+  SCM_I_CURRENT_THREAD->block_asyncs--;
+}
+
+void
+scm_i_dynwind_pthread_mutex_lock_with_asyncs (scm_i_pthread_mutex_t *mutex)
+{
+  SCM_I_CURRENT_THREAD->block_asyncs++;
+  scm_i_scm_pthread_mutex_lock (mutex);
+  scm_dynwind_unwind_handler (do_unlock_with_asyncs, mutex,
+                              SCM_F_WIND_EXPLICITLY);
+}
+
 unsigned long
 scm_std_usleep (unsigned long usecs)
 {
diff --git a/libguile/threads.h b/libguile/threads.h
index 901c37b..5a2afa2 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -143,6 +143,7 @@ SCM_INTERNAL void scm_init_threads (void);
 SCM_INTERNAL void scm_init_thread_procs (void);
 SCM_INTERNAL void scm_init_threads_default_dynamic_state (void);
 
+SCM_INTERNAL void scm_i_dynwind_pthread_mutex_lock_with_asyncs (scm_i_pthread_mutex_t *mutex);
 
 #define SCM_THREAD_SWITCHING_CODE \
   do { } while (0)
-- 
1.7.5.4


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: [PATCH 2/6] Block system asyncs while 'overrides_lock' is held --]
[-- Type: text/x-patch, Size: 1340 bytes --]

From f68f42d2014bb3dfb8a0d7c502f9d3d9593ee458 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Sun, 17 Nov 2013 03:19:32 -0500
Subject: [PATCH 2/6] Block system asyncs while 'overrides_lock' is held.

* libguile/procprop.c (scm_set_procedure_property_x): Block system
  asyncs while overrides_lock is held.  Use dynwind block in case
  an exception is thrown.
---
 libguile/procprop.c |    5 +++--
 1 files changed, 3 insertions(+), 2 deletions(-)

diff --git a/libguile/procprop.c b/libguile/procprop.c
index 36228d3..dae3ea7 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -229,7 +229,8 @@ SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
     SCM_MISC_ERROR ("arity is a deprecated read-only property", SCM_EOL);
 #endif
 
-  scm_i_pthread_mutex_lock (&overrides_lock);
+  scm_dynwind_begin (0);
+  scm_i_dynwind_pthread_mutex_lock_with_asyncs (&overrides_lock);
   props = scm_hashq_ref (overrides, proc, SCM_BOOL_F);
   if (scm_is_false (props))
     {
@@ -239,7 +240,7 @@ SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
         props = SCM_EOL;
     }
   scm_hashq_set_x (overrides, proc, scm_assq_set_x (props, key, val));
-  scm_i_pthread_mutex_unlock (&overrides_lock);
+  scm_dynwind_end ();
 
   return SCM_UNSPECIFIED;
 }
-- 
1.7.5.4


[-- Attachment #4: [PATCH 3/6] Make guardians thread-safe --]
[-- Type: text/x-patch, Size: 2921 bytes --]

From 467e1d4c0438d24e310a45bc7370bd19b0e8c659 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Sun, 17 Nov 2013 03:35:09 -0500
Subject: [PATCH 3/6] Make guardians thread-safe.

* libguile/guardians.c (t_guardian): Add mutex.
  (finalize_guarded, scm_i_guard, scm_i_get_one_zombie): Lock mutex and
  block system asyncs during critical sections.
  (scm_make_guardian): Initialize mutex.
---
 libguile/guardians.c |   18 ++++++++++++++++--
 1 files changed, 16 insertions(+), 2 deletions(-)

diff --git a/libguile/guardians.c b/libguile/guardians.c
index 6ba8c0b..e59e1bb 100644
--- a/libguile/guardians.c
+++ b/libguile/guardians.c
@@ -40,7 +40,6 @@
  * monsters we had...
  *
  * Rewritten for the Boehm-Demers-Weiser GC by Ludovic Courtès.
- * FIXME: This is currently not thread-safe.
  */
 
 /* Uncomment the following line to debug guardian finalization.  */
@@ -72,6 +71,7 @@ static scm_t_bits tc16_guardian;
 
 typedef struct t_guardian
 {
+  scm_i_pthread_mutex_t mutex;
   unsigned long live;
   SCM zombies;
   struct t_guardian *next;
@@ -144,6 +144,9 @@ finalize_guarded (void *ptr, void *finalizer_data)
 	}
 
       g = GUARDIAN_DATA (SCM_CAR (guardian_list));
+
+      scm_i_pthread_mutex_lock_with_asyncs (&g->mutex);
+
       if (g->live == 0)
 	abort ();
 
@@ -157,7 +160,8 @@ finalize_guarded (void *ptr, void *finalizer_data)
       g->zombies = zombies;
 
       g->live--;
-      g->zombies = zombies;
+
+      scm_i_pthread_mutex_unlock_with_asyncs (&g->mutex);
     }
 
   if (scm_is_true (proxied_finalizer))
@@ -208,6 +212,8 @@ scm_i_guard (SCM guardian, SCM obj)
       void *prev_data;
       SCM guardians_for_obj, finalizer_data;
 
+      scm_i_pthread_mutex_lock_with_asyncs (&g->mutex);
+
       g->live++;
 
       /* Note: GUARDIANS_FOR_OBJ is a weak list so that a guardian can be
@@ -249,6 +255,8 @@ scm_i_guard (SCM guardian, SCM obj)
 					PTR2SCM (prev_data));
 	  SCM_SETCAR (finalizer_data, proxied_finalizer);
 	}
+
+      scm_i_pthread_mutex_unlock_with_asyncs (&g->mutex);
     }
 }
 
@@ -258,6 +266,8 @@ scm_i_get_one_zombie (SCM guardian)
   t_guardian *g = GUARDIAN_DATA (guardian);
   SCM res = SCM_BOOL_F;
 
+  scm_i_pthread_mutex_lock_with_asyncs (&g->mutex);
+
   if (!scm_is_null (g->zombies))
     {
       /* Note: We return zombies in reverse order.  */
@@ -265,6 +275,8 @@ scm_i_get_one_zombie (SCM guardian)
       g->zombies = SCM_CDR (g->zombies);
     }
 
+  scm_i_pthread_mutex_unlock_with_asyncs (&g->mutex);
+
   return res;
 }
 
@@ -335,6 +347,8 @@ SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 0, 0,
   t_guardian *g = scm_gc_malloc (sizeof (t_guardian), "guardian");
   SCM z;
 
+  scm_i_pthread_mutex_init (&g->mutex, NULL);
+
   /* A tconc starts out with one tail pair. */
   g->live = 0;
   g->zombies = SCM_EOL;
-- 
1.7.5.4


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #5: [PATCH 4/6] Make port alists accessible from Scheme --]
[-- Type: text/x-patch, Size: 2258 bytes --]

From 5eb377ad8db716457b5750b54daa28b249006acd Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Sun, 17 Nov 2013 01:11:57 -0500
Subject: [PATCH 4/6] Make port alists accessible from Scheme.

* libguile/ports.c (scm_i_port_alist, scm_i_set_port_alist_x): Make
  these available from Scheme, as '%port-alist' and '%set-port-alist!'.
  Validate port argument.

* libguile/ports.h (scm_i_set_port_alist_x): Change return type from
  'void' to 'SCM'.
---
 libguile/ports.c |   17 +++++++++++++----
 libguile/ports.h |    2 +-
 2 files changed, 14 insertions(+), 5 deletions(-)

diff --git a/libguile/ports.c b/libguile/ports.c
index 6f219d6..030090c 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -254,17 +254,26 @@ scm_i_clear_pending_eof (SCM port)
   SCM_PORT_GET_INTERNAL (port)->pending_eof = 0;
 }
 
-SCM
-scm_i_port_alist (SCM port)
+SCM_DEFINE (scm_i_port_alist, "%port-alist", 1, 0, 0,
+            (SCM port),
+            "Return the alist associated with @var{port}.")
+#define FUNC_NAME s_scm_i_port_alist
 {
+  SCM_VALIDATE_OPPORT (1, port);
   return SCM_PORT_GET_INTERNAL (port)->alist;
 }
+#undef FUNC_NAME
 
-void
-scm_i_set_port_alist_x (SCM port, SCM alist)
+SCM_DEFINE (scm_i_set_port_alist_x, "%set-port-alist!", 2, 0, 0,
+            (SCM port, SCM alist),
+            "Set the alist associated with @var{port} to @var{alist}.")
+#define FUNC_NAME s_scm_i_set_port_alist_x
 {
+  SCM_VALIDATE_OPPORT (1, port);
   SCM_PORT_GET_INTERNAL (port)->alist = alist;
+  return SCM_UNSPECIFIED;
 }
+#undef FUNC_NAME
 
 \f
 
diff --git a/libguile/ports.h b/libguile/ports.h
index 39317f8..c8d08df 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -318,7 +318,7 @@ SCM_API SCM scm_set_port_column_x (SCM port, SCM line);
 SCM_API SCM scm_port_filename (SCM port);
 SCM_API SCM scm_set_port_filename_x (SCM port, SCM filename);
 SCM_INTERNAL SCM scm_i_port_alist (SCM port);
-SCM_INTERNAL void scm_i_set_port_alist_x (SCM port, SCM alist);
+SCM_INTERNAL SCM scm_i_set_port_alist_x (SCM port, SCM alist);
 SCM_INTERNAL const char *scm_i_default_port_encoding (void);
 SCM_INTERNAL void scm_i_set_default_port_encoding (const char *);
 SCM_INTERNAL void scm_i_set_port_encoding_x (SCM port, const char *str);
-- 
1.7.5.4


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #6: [PATCH 5/6] Stylistic improvements for (ice-9 popen) --]
[-- Type: text/x-patch, Size: 2997 bytes --]

From aa2d1143a05b82692ca965a2aa7d07e12c92e8c6 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Sun, 17 Nov 2013 02:46:08 -0500
Subject: [PATCH 5/6] Stylistic improvements for (ice-9 popen).

* module/ice-9/popen.scm (close-process, close-process-quietly): Accept
  'port' and 'pid' as separate arguments.  Improve style.
  (close-pipe, read-pipes): Improve style.
---
 module/ice-9/popen.scm |   45 +++++++++++++++++++++------------------------
 1 files changed, 21 insertions(+), 24 deletions(-)

diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm
index 7d0549e..f8668cd 100644
--- a/module/ice-9/popen.scm
+++ b/module/ice-9/popen.scm
@@ -74,27 +74,26 @@ port to the process is created: it should be the value of
     (hashq-remove! port/pid-table port)
     pid))
 
-(define (close-process port/pid)
-  (close-port (car port/pid))
-  (cdr (waitpid (cdr port/pid))))
+(define (close-process port pid)
+  (close-port port)
+  (cdr (waitpid pid)))
 
 ;; for the background cleanup handler: just clean up without reporting
 ;; errors.  also avoids blocking the process: if the child isn't ready
 ;; to be collected, puts it back into the guardian's live list so it
 ;; can be tried again the next time the cleanup runs.
-(define (close-process-quietly port/pid)
+(define (close-process-quietly port pid)
   (catch 'system-error
 	 (lambda ()
-	   (close-port (car port/pid)))
+	   (close-port port))
 	 (lambda args #f))
   (catch 'system-error
 	 (lambda ()
-	   (let ((pid/status (waitpid (cdr port/pid) WNOHANG)))
-	     (cond ((= (car pid/status) 0)
-		    ;; not ready for collection
-		    (pipe-guardian (car port/pid))
-		    (hashq-set! port/pid-table
-				(car port/pid) (cdr port/pid))))))
+	   (let ((pid/status (waitpid pid WNOHANG)))
+             (when (zero? (car pid/status))
+               ;; not ready for collection
+               (pipe-guardian port)
+               (hashq-set! port/pid-table port pid))))
 	 (lambda args #f)))
 
 (define (close-pipe p)
@@ -102,19 +101,17 @@ port to the process is created: it should be the value of
 to terminate and returns its status value, @xref{Processes, waitpid}, for
 information on how to interpret this value."
   (let ((pid (fetch-pid p)))
-    (if (not pid)
-        (error "close-pipe: pipe not in table"))
-    (close-process (cons p pid))))
-
-(define reap-pipes
-  (lambda ()
-    (let loop ((p (pipe-guardian)))
-      (cond (p 
-	     ;; maybe removed already by close-pipe.
-	     (let ((pid (fetch-pid p)))
-	       (if pid
-		   (close-process-quietly (cons p pid))))
-	     (loop (pipe-guardian)))))))
+    (unless pid (error "close-pipe: pipe not in table"))
+    (close-process p pid)))
+
+(define (reap-pipes)
+  (let loop ()
+    (let ((p (pipe-guardian)))
+      (when p
+        ;; maybe removed already by close-pipe.
+        (let ((pid (fetch-pid p)))
+          (when pid (close-process-quietly p pid)))
+        (loop)))))
 
 (add-hook! after-gc-hook reap-pipes)
 
-- 
1.7.5.4


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #7: [PATCH 6/6] Make (ice-9 popen) thread-safe --]
[-- Type: text/x-patch, Size: 3833 bytes --]

From 7feebb721114e0a20a19ec152bfceaf27b7bb57d Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Sun, 17 Nov 2013 02:54:31 -0500
Subject: [PATCH 6/6] Make (ice-9 popen) thread-safe.

* module/ice-9/popen.scm: Import (ice-9 threads).
  (port/pid-table): Mark as deprecated in comment.
  (port/pid-table-mutex): New variable.
  (open-pipe*): Stash the pid in the port's alist.  Lock
  'port/pid-table-mutex' while mutating 'port/pid-table'.
  (fetch-pid): Fetch the pid from the port's alist.  Don't touch
  'port/pid-table'.
  (close-process-quietly): Don't add the port to 'port/pid-table-mutex',
  since it was never removed.
  (close-pipe): Improve error message.
  (reap-pipes): Check to see if the port is already closed.
---
 module/ice-9/popen.scm |   27 +++++++++++++++++----------
 1 files changed, 17 insertions(+), 10 deletions(-)

diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm
index f8668cd..0e896d7 100644
--- a/module/ice-9/popen.scm
+++ b/module/ice-9/popen.scm
@@ -18,6 +18,7 @@
 ;;;; 
 
 (define-module (ice-9 popen)
+  :use-module (ice-9 threads)
   :export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe
 	   open-output-pipe open-input-output-pipe))
 
@@ -40,7 +41,10 @@
 (define pipe-guardian (make-guardian))
 
 ;; a weak hash-table to store the process ids.
+;; XXX use of this table is deprecated.  It is no longer used, and is
+;; populated only for backward compatibility (since it is exported).
 (define port/pid-table (make-weak-key-hash-table 31))
+(define port/pid-table-mutex (make-mutex))
 
 (define (open-pipe* mode command . args)
   "Executes the program @var{command} with optional arguments
@@ -57,8 +61,13 @@ port to the process is created: it should be the value of
                       read-port
                       write-port
                       (%make-void-port mode))))
+        (%set-port-alist! port (acons 'popen-pid pid (%port-alist port)))
         (pipe-guardian port)
-        (hashq-set! port/pid-table port pid)
+
+        ;; XXX populate port/pid-table for backward compatibility.
+        (with-mutex port/pid-table-mutex
+          (hashq-set! port/pid-table port pid))
+
         port))))
 
 (define (open-pipe command mode)
@@ -70,9 +79,7 @@ port to the process is created: it should be the value of
   (open-pipe* mode "/bin/sh" "-c" command))
 
 (define (fetch-pid port)
-  (let ((pid (hashq-ref port/pid-table port)))
-    (hashq-remove! port/pid-table port)
-    pid))
+  (assq-ref (%port-alist port) 'popen-pid))
 
 (define (close-process port pid)
   (close-port port)
@@ -92,8 +99,7 @@ port to the process is created: it should be the value of
 	   (let ((pid/status (waitpid pid WNOHANG)))
              (when (zero? (car pid/status))
                ;; not ready for collection
-               (pipe-guardian port)
-               (hashq-set! port/pid-table port pid))))
+               (pipe-guardian port))))
 	 (lambda args #f)))
 
 (define (close-pipe p)
@@ -101,16 +107,17 @@ port to the process is created: it should be the value of
 to terminate and returns its status value, @xref{Processes, waitpid}, for
 information on how to interpret this value."
   (let ((pid (fetch-pid p)))
-    (unless pid (error "close-pipe: pipe not in table"))
+    (unless pid (error "close-pipe: pipe not created by (ice-9 popen)"))
     (close-process p pid)))
 
 (define (reap-pipes)
   (let loop ()
     (let ((p (pipe-guardian)))
       (when p
-        ;; maybe removed already by close-pipe.
-        (let ((pid (fetch-pid p)))
-          (when pid (close-process-quietly p pid)))
+        ;; maybe closed already.
+        (unless (port-closed? p)
+          (let ((pid (fetch-pid p)))
+            (when pid (close-process-quietly p pid))))
         (loop)))))
 
 (add-hook! after-gc-hook reap-pipes)
-- 
1.7.5.4