From 3c3e66b85d294fc5ded6f6660a0efe00ed6519b9 Mon Sep 17 00:00:00 2001 From: Mark H Weaver 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 | 80 +++++++++++++++++++++++++++-------------------- 1 files changed, 46 insertions(+), 34 deletions(-) diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm index f8668cd..2a9f566 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,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 +42,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 +61,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))) + + ;; Guard the alist-entry 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 +84,45 @@ 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")) - (close-process p pid))) + (let ((alist-entry (fetch-alist-entry p))) + (unless alist-entry + (error "close-pipe: port not created by (ice-9 popen)")) + (let ((pid (cdr alist-entry))) + ;; set the cdr to #f to avoid repeated calls to 'waitpid'. + (unless pid + (error "close-pipe: pid has already been cleared")) + (set-cdr! alist-entry #f) + (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