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

From: Mark H Weaver <[email-masked]>
Date: Sun, 17 Nov 2013 10:59:16 -0500

Sorry, I discovered that the reaper wasn't working properly, and that
slightly more radical changes were necessary.  I've attached a new
version of the patch set.  The only patch that changed here is the last
one, but I include all of them again for simplicity.

I deleted the old 'wip-thread-safe-popen' branch and pushed a new one
called 'thread-safe-popen', because I believe this one finally does the
entire job correctly.

      Mark

>From 9b48be7107f3f98cdf2e756d4c1f4c937ff233d7 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <[email-masked]>
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

>From f68f42d2014bb3dfb8a0d7c502f9d3d9593ee458 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <[email-masked]>
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

>From 467e1d4c0438d24e310a45bc7370bd19b0e8c659 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <[email-masked]>
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

>From 5eb377ad8db716457b5750b54daa28b249006acd Mon Sep 17 00:00:00 2001
From: Mark H Weaver <[email-masked]>
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
 
 
 
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

>From aa2d1143a05b82692ca965a2aa7d07e12c92e8c6 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <[email-masked]>
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

>From 7bc28986ebdacbe77a43c52f36645c20b2bdf442 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <[email-masked]>
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*): Store the pid in the port's alist.  Guard the alist
  entry instead of the port.  Lock 'port/pid-table-mutex' while mutating
  'port/pid-table'.
  (fetch-pid): Removed.
  (fetch-alist-entry): New procedure.
  (close-process-quietly): Removed.
  (close-pipe): Use 'fetch-alist-entry' instead of 'fetch-pid'.  Clear
  the cdr of the alist entry.  Improve error messages.
  (reap-pipes): Adapt to the fact that the alist entries are now guarded
  instead of the ports.  Incorporate the 'waitpid' code that was
  previously in 'close-process-quietly', but let the port finalizer
  close the port.  Clear the cdr of the alist entry.
---
 module/ice-9/popen.scm |   76 +++++++++++++++++++++++++++--------------------
 1 files changed, 44 insertions(+), 32 deletions(-)

diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm
index f8668cd..8e43112 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 here, and
+;; is populated for backward compatibility only (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
@@ -56,9 +60,19 @@ port to the process is created: it should be the value of
                            (make-rw-port read-port write-port))
                       read-port
                       write-port
-                      (%make-void-port mode))))
-        (pipe-guardian port)
-        (hashq-set! port/pid-table port pid)
+                      (%make-void-port mode)))
+            (alist-entry (cons 'popen-pid pid)))
+
+        ;; Store the alist-entry in the guardian instead of the port,
+        ;; so that we can still call 'waitpid' even if 'close-port'
+        ;; is called (which clears the port entry).
+        (pipe-guardian alist-entry)
+        (%set-port-alist! port (cons alist-entry (%port-alist port)))
+
+        ;; 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)
@@ -69,48 +83,46 @@ port to the process is created: it should be the value of
 @code{OPEN_READ}, @code{OPEN_WRITE} or @code{OPEN_BOTH}."
   (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))
+(define (fetch-alist-entry port)
+  (assq 'popen-pid (%port-alist port)))
 
 (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)
-  (catch 'system-error
-	 (lambda ()
-	   (close-port port))
-	 (lambda args #f))
-  (catch 'system-error
-	 (lambda ()
-	   (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)
   "Closes the pipe created by @code{open-pipe}, then waits for the process
 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"))
+  (let* ((alist-entry (fetch-alist-entry p))
+         (pid (cdr alist-entry)))
+    ;; set the cdr to #f so that the reaper won't wait on this pid
+    ;; again, and to detect repeated calls to 'close-pipe'.
+    (set-cdr! alist-entry #f)
+    (unless alist-entry
+      (error "close-pipe: port not created by (ice-9 popen)"))
+    (unless pid
+      (error "close-pipe: pid has already been cleared"))
     (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)))
+    (let ((alist-entry (pipe-guardian)))
+      (when alist-entry
+        (let ((pid (cdr alist-entry)))
+          ;; maybe 'close-pipe' was already called.
+          (when pid
+            ;; 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.
+            (catch 'system-error
+              (lambda ()
+                (let ((pid/status (waitpid pid WNOHANG)))
+                  (if (zero? (car pid/status))
+                      (pipe-guardian alist-entry)  ; not ready for collection
+                      (set-cdr! alist-entry #f)))) ; avoid calling waitpid again
+              (lambda args #f))))
         (loop)))))
 
 (add-hook! after-gc-hook reap-pipes)
-- 
1.7.5.4