[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.9-112-ge7bd2
|
From: |
Mark H Weaver |
|
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.9-112-ge7bd20f |
|
Date: |
Sat, 23 Nov 2013 23:03:42 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=e7bd20f7d9b2110fdc0fa25db5a2bfe6b2214923
The branch, stable-2.0 has been updated
via e7bd20f7d9b2110fdc0fa25db5a2bfe6b2214923 (commit)
via 17330398d50524058c2ef488bd21ac5ec9c8b6e8 (commit)
via a38024baaa32d1a6d91fdc81388c88bbb926c3ae (commit)
via 2437c7b2e8b4ab7786847ee1ce0b59e446a70fe2 (commit)
via 8571dbde639e0ee9885bad49c9e180474bd23646 (commit)
via e676a4c34211efc8a7558afb0f8572b88a89c683 (commit)
from 1e42832af07ea6ac68ecbe4f6a3376ff509a2a51 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit e7bd20f7d9b2110fdc0fa25db5a2bfe6b2214923
Author: Mark H Weaver <address@hidden>
Date: Sun Nov 17 02:54:31 2013 -0500
Make (ice-9 popen) thread-safe.
Fixes <http://bugs.gnu.org/15683>.
Reported by David Pirotte <address@hidden>.
* module/ice-9/popen.scm: Import (ice-9 threads) and (srfi srfi-9).
(<pipe-info>): New record type.
(port/pid-table): Mark as deprecated in comment.
(port/pid-table-mutex): New variable.
(open-pipe*): Store the pid in the pipe-info record, and store the
pipe-info as a port property. Guard the pipe-info instead of the
port. Lock 'port/pid-table-mutex' while mutating 'port/pid-table'.
(fetch-pid): Removed.
(fetch-pipe-info): New procedure.
(close-process-quietly): Removed.
(close-pipe): Use 'fetch-pipe-info' instead of 'fetch-pid'. Clear
the pid from the pipe-info. Improve error messages.
(reap-pipes): Adapt to the fact that the pipe-info is now guarded
instead of the port. Incorporate the 'waitpid' code that was
previously in 'close-process-quietly', but let the port finalizer
close the port. Clear the pid from the pipe-info.
commit 17330398d50524058c2ef488bd21ac5ec9c8b6e8
Author: Mark H Weaver <address@hidden>
Date: Sun Nov 17 02:46:08 2013 -0500
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.
commit a38024baaa32d1a6d91fdc81388c88bbb926c3ae
Author: Mark H Weaver <address@hidden>
Date: Sun Nov 17 01:11:57 2013 -0500
Make port properties accessible from Scheme.
* libguile/ports.c (scm_i_port_alist, scm_i_set_port_alist_x): Removed.
(scm_i_port_property, scm_i_set_port_property_x): New procedures,
available from Scheme as '%port-property' and '%set-port-property!'.
* libguile/ports.h (scm_i_port_alist, scm_i_set_port_alist_x): Removed.
(scm_i_port_property, scm_i_set_port_property_x): New prototypes.
* libguile/read.c (set_port_read_option, init_read_options): Adapt to
use scm_i_port_property and scm_i_set_port_property_x.
commit 2437c7b2e8b4ab7786847ee1ce0b59e446a70fe2
Author: Mark H Weaver <address@hidden>
Date: Sun Nov 17 03:35:09 2013 -0500
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.
commit 8571dbde639e0ee9885bad49c9e180474bd23646
Author: Mark H Weaver <address@hidden>
Date: Sun Nov 17 03:19:32 2013 -0500
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.
commit e676a4c34211efc8a7558afb0f8572b88a89c683
Author: Mark H Weaver <address@hidden>
Date: Sun Nov 17 04:00:29 2013 -0500
Add mutex locking functions that also block asyncs.
* libguile/async.h (scm_i_pthread_mutex_lock_block_asyncs,
scm_i_pthread_mutex_unlock_unblock_asyncs): New macros.
* libguile/threads.c (do_unlock_with_asyncs): New static helper.
(scm_i_dynwind_pthread_mutex_lock_block_asyncs): New function.
* libguile/threads.h (scm_i_dynwind_pthread_mutex_lock_block_asyncs):
Add prototype.
-----------------------------------------------------------------------
Summary of changes:
libguile/async.h | 16 +++++++
libguile/guardians.c | 18 +++++++-
libguile/ports.c | 25 +++++++++---
libguile/ports.h | 4 +-
libguile/procprop.c | 10 ++++-
libguile/read.c | 23 +++++------
libguile/threads.c | 16 +++++++
libguile/threads.h | 1 +
module/ice-9/popen.scm | 105 +++++++++++++++++++++++++++--------------------
9 files changed, 148 insertions(+), 70 deletions(-)
diff --git a/libguile/async.h b/libguile/async.h
index ceb2b96..b3503de 100644
--- a/libguile/async.h
+++ b/libguile/async.h
@@ -78,6 +78,22 @@ SCM_API void scm_critical_section_end (void);
scm_async_click (); \
} while (0)
+# define scm_i_pthread_mutex_lock_block_asyncs(m) \
+ do \
+ { \
+ SCM_I_CURRENT_THREAD->block_asyncs++; \
+ scm_i_pthread_mutex_lock (m); \
+ } \
+ while (0)
+
+# define scm_i_pthread_mutex_unlock_unblock_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/guardians.c b/libguile/guardians.c
index 6ba8c0b..2bf07a8 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_block_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_unblock_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_block_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_unblock_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_block_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_unblock_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;
diff --git a/libguile/ports.c b/libguile/ports.c
index 6f219d6..4516160 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -61,6 +61,7 @@
#include "libguile/weaks.h"
#include "libguile/fluids.h"
#include "libguile/eq.h"
+#include "libguile/alist.h"
#ifdef HAVE_STRING_H
#include <string.h>
@@ -254,17 +255,29 @@ 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_property, "%port-property", 2, 0, 0,
+ (SCM port, SCM key),
+ "Return the property of @var{port} associated with @var{key}.")
+#define FUNC_NAME s_scm_i_port_property
{
- return SCM_PORT_GET_INTERNAL (port)->alist;
+ SCM_VALIDATE_OPPORT (1, port);
+ return scm_assq_ref (SCM_PORT_GET_INTERNAL (port)->alist, key);
}
+#undef FUNC_NAME
-void
-scm_i_set_port_alist_x (SCM port, SCM alist)
+SCM_DEFINE (scm_i_set_port_property_x, "%set-port-property!", 3, 0, 0,
+ (SCM port, SCM key, SCM value),
+ "Set the property of @var{port} associated with @var{key} to
@var{value}.")
+#define FUNC_NAME s_scm_i_set_port_property_x
{
- SCM_PORT_GET_INTERNAL (port)->alist = alist;
+ scm_t_port_internal *pti;
+
+ SCM_VALIDATE_OPPORT (1, port);
+ pti = SCM_PORT_GET_INTERNAL (port);
+ pti->alist = scm_assq_set_x (pti->alist, key, value);
+ return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
diff --git a/libguile/ports.h b/libguile/ports.h
index 39317f8..4affb4d 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -317,8 +317,8 @@ SCM_API SCM scm_port_column (SCM port);
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_port_property (SCM port, SCM key);
+SCM_INTERNAL SCM scm_i_set_port_property_x (SCM port, SCM key, SCM value);
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);
diff --git a/libguile/procprop.c b/libguile/procprop.c
index 36228d3..be57b6b 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -229,7 +229,13 @@ 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);
+ /* Here we must block asyncs while overrides_lock is held, to avoid
+ deadlocks which can happen as follows: scm_i_program_properties
+ calls out to the VM, which will run asyncs. Asyncs are permitted
+ to run VM code, which sometimes checks procedure properties, which
+ locks overrides_lock. */
+ scm_i_dynwind_pthread_mutex_lock_block_asyncs (&overrides_lock);
props = scm_hashq_ref (overrides, proc, SCM_BOOL_F);
if (scm_is_false (props))
{
@@ -239,7 +245,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;
}
diff --git a/libguile/read.c b/libguile/read.c
index e2e2e4a..299ab70 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -2133,10 +2133,10 @@ SCM_DEFINE (scm_file_encoding, "file-encoding", 1, 0, 0,
/* Per-port read options.
- We store per-port read options in the 'port-read-options' key of the
- port's alist, which is stored in the internal port structure. The
- value stored in the alist is a single integer that contains a two-bit
- field for each read option.
+ We store per-port read options in the 'port-read-options' port
+ property, which is stored in the internal port structure. The value
+ stored is a single integer that contains a two-bit field for each
+ read option.
If a bit field contains READ_OPTION_INHERIT (3), that indicates that
the applicable value should be inherited from the corresponding
@@ -2146,7 +2146,7 @@ SCM_DEFINE (scm_file_encoding, "file-encoding", 1, 0, 0,
read option has been set per-port, its possible values are those in
'enum t_keyword_style'. */
-/* Key to read options in per-port alists. */
+/* Key to read options in port properties. */
SCM_SYMBOL (sym_port_read_options, "port-read-options");
/* Offsets of bit fields for each per-port override */
@@ -2171,12 +2171,11 @@ SCM_SYMBOL (sym_port_read_options, "port-read-options");
static void
set_port_read_option (SCM port, int option, int new_value)
{
- SCM alist, scm_read_options;
+ SCM scm_read_options;
unsigned int read_options;
new_value &= READ_OPTION_MASK;
- alist = scm_i_port_alist (port);
- scm_read_options = scm_assq_ref (alist, sym_port_read_options);
+ scm_read_options = scm_i_port_property (port, sym_port_read_options);
if (scm_is_unsigned_integer (scm_read_options, 0, READ_OPTIONS_MAX_VALUE))
read_options = scm_to_uint (scm_read_options);
else
@@ -2184,8 +2183,7 @@ set_port_read_option (SCM port, int option, int new_value)
read_options &= ~(READ_OPTION_MASK << option);
read_options |= new_value << option;
scm_read_options = scm_from_uint (read_options);
- alist = scm_assq_set_x (alist, sym_port_read_options, scm_read_options);
- scm_i_set_port_alist_x (port, alist);
+ scm_i_set_port_property_x (port, sym_port_read_options, scm_read_options);
}
/* Set OPTS and PORT's case-insensitivity according to VALUE. */
@@ -2220,11 +2218,10 @@ set_port_curly_infix_p (SCM port, scm_t_read_opts
*opts, int value)
static void
init_read_options (SCM port, scm_t_read_opts *opts)
{
- SCM alist, val, scm_read_options;
+ SCM val, scm_read_options;
unsigned int read_options, x;
- alist = scm_i_port_alist (port);
- scm_read_options = scm_assq_ref (alist, sym_port_read_options);
+ scm_read_options = scm_i_port_property (port, sym_port_read_options);
if (scm_is_unsigned_integer (scm_read_options, 0, READ_OPTIONS_MAX_VALUE))
read_options = scm_to_uint (scm_read_options);
diff --git a/libguile/threads.c b/libguile/threads.c
index 8cbe1e2..b84ddbd 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_block_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..5398218 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_block_asyncs
(scm_i_pthread_mutex_t *mutex);
#define SCM_THREAD_SWITCHING_CODE \
do { } while (0)
diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm
index 7d0549e..48a52e6 100644
--- a/module/ice-9/popen.scm
+++ b/module/ice-9/popen.scm
@@ -1,6 +1,7 @@
;; popen emulation, for non-stdio based ports.
-;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006, 2010, 2011, 2012, 2013
Free Software Foundation, Inc.
+;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006, 2010, 2011, 2012,
+;;;; 2013 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
@@ -18,6 +19,8 @@
;;;;
(define-module (ice-9 popen)
+ :use-module (ice-9 threads)
+ :use-module (srfi srfi-9)
:export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe
open-output-pipe open-input-output-pipe))
@@ -25,6 +28,11 @@
(load-extension (string-append "libguile-" (effective-version))
"scm_init_popen"))
+(define-record-type <pipe-info>
+ (make-pipe-info pid)
+ pipe-info?
+ (pid pipe-info-pid set-pipe-info-pid!))
+
(define (make-rw-port read-port write-port)
(make-soft-port
(vector
@@ -40,7 +48,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 +67,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)))
+ (pipe-info (make-pipe-info pid)))
+
+ ;; Guard the pipe-info instead of the port, so that we can still
+ ;; call 'waitpid' even if 'close-port' is called (which clears
+ ;; the port entry).
+ (pipe-guardian pipe-info)
+ (%set-port-property! port 'popen-pipe-info pipe-info)
+
+ ;; 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,52 +90,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 (close-process port/pid)
- (close-port (car port/pid))
- (cdr (waitpid (cdr port/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 (car port/pid)))
- (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))))))
- (lambda args #f)))
+(define (fetch-pipe-info port)
+ (%port-property port 'popen-pipe-info))
+
+(define (close-process port pid)
+ (close-port port)
+ (cdr (waitpid pid)))
(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)))
- (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)))))))
+ (let ((pipe-info (fetch-pipe-info p)))
+ (unless pipe-info
+ (error "close-pipe: port not created by (ice-9 popen)"))
+ (let ((pid (pipe-info-pid pipe-info)))
+ (unless pid
+ (error "close-pipe: pid has already been cleared"))
+ ;; clear the pid to avoid repeated calls to 'waitpid'.
+ (set-pipe-info-pid! pipe-info #f)
+ (close-process p pid))))
+
+(define (reap-pipes)
+ (let loop ()
+ (let ((pipe-info (pipe-guardian)))
+ (when pipe-info
+ (let ((pid (pipe-info-pid pipe-info)))
+ ;; 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 pipe-info) ; not ready for collection
+ (set-pipe-info-pid! pipe-info #f))))
+ (lambda args #f))))
+ (loop)))))
(add-hook! after-gc-hook reap-pipes)
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.9-112-ge7bd20f,
Mark H Weaver <=