Package: guile;
Reported by: David Pirotte <david <at> altosw.be>
Date: Tue, 22 Oct 2013 16:26:02 UTC
Severity: important
Done: Mark H Weaver <mhw <at> netris.org>
Bug is archived. No further changes may be made.
View this message in rfc822 format
From: Mark H Weaver <mhw <at> netris.org> To: David Pirotte <david <at> altosw.be> Cc: 15683 <at> debbugs.gnu.org Subject: bug#15683: [critical] ERROR: ... close-pipe: pipe not in table Date: Sun, 17 Nov 2013 04:46:37 -0500
[Message part 1 (text/plain, inline)]
Hi David, 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. Please let us know if they fix your problem. Regards, Mark
[0001-Add-mutex-locking-functions-that-also-block-asyncs.patch (text/x-patch, inline)]
From 9b48be7107f3f98cdf2e756d4c1f4c937ff233d7 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw <at> 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
[0002-Block-system-asyncs-while-overrides_lock-is-held.patch (text/x-patch, inline)]
From f68f42d2014bb3dfb8a0d7c502f9d3d9593ee458 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw <at> 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
[0003-Make-guardians-thread-safe.patch (text/x-patch, inline)]
From 467e1d4c0438d24e310a45bc7370bd19b0e8c659 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw <at> 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
[0004-Make-port-alists-accessible-from-Scheme.patch (text/x-patch, inline)]
From 527a2938b55fb29b29091b96c5f803238adf42a7 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw <at> 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..a20a820 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", 0, 1, 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!", 0, 2, 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
[0005-Stylistic-improvements-for-ice-9-popen.patch (text/x-patch, inline)]
From 0e9c87402bf309323ebff4def7049572cb11562a Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw <at> 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
[0006-Make-ice-9-popen-thread-safe.patch (text/x-patch, inline)]
From 40676067383d8fef9cc1690154011708c7e8e256 Mon Sep 17 00:00:00 2001 From: Mark H Weaver <mhw <at> 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
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.