From 925196c4533113df25a3cbae95b79ca36fdf5e8f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 23 Mar 2017 15:43:59 +0100 Subject: [PATCH] signals: remove sigchld handling It caused races with waitpid previously masked by fast code in unixsys.d. --- src/c/unixint.d | 5 -- src/lsp/process.lsp | 95 ++++++-------------------- src/tests/normal-tests/run-program.lsp | 19 ------ 3 files changed, 21 insertions(+), 98 deletions(-) diff --git a/src/c/unixint.d b/src/c/unixint.d index a35db62a3..ced8a31da 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -851,11 +851,6 @@ do_catch_signal(int code, cl_object action, cl_object process) else if (code == SIGILL) { mysignal(SIGILL, evil_signal_handler); } -#endif -#ifdef SIGCHLD - else if (code == SIGCHLD) { - mysignal(SIGCHLD, evil_signal_handler); - } #endif else { mysignal(code, non_evil_signal_handler); diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index f4f45fa59..46d787b84 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -7,43 +7,18 @@ (in-package "EXT") -(defvar *active-processes* nil - "List of process structures for all active processes.") - -(defvar *active-processes-lock* - (mp:make-lock :recursive t :name "Lock for active processes.")) - -;;; *ACTIVE-PROCESSES* can be accessed from multiple threads so a -;;; mutex is needed. More importantly the sigchld signal handler also -;;; accesses it, that's why we need without-interrupts. -(defmacro with-active-processes-lock (&body body) - `(mp:without-interrupts - (mp:with-lock (*active-processes-lock*) - ,@body))) - -(defun sigchld-handler (&key process) - (declare (ignore process)) - (let (changed) - (with-active-processes-lock - (mapc (lambda (process) - (when (external-process-wait process nil) - (push process changed))) - ;; `external-process-wait' may modify `*active-processes*'. - (copy-list *active-processes*))) - (dolist (proc changed) - (let ((hook (external-process-status-hook proc))) - (when hook (funcall hook proc)))))) - - +(defmacro with-process-lock ((process) &body body) + `(mp:with-lock ((external-process-%lock process)) + ,@body)) (defstruct (external-process (:constructor make-external-process ())) pid input output error-stream - status-hook (%status :running) - (%code nil)) + (%code nil) + (%lock (mp:make-lock))) (defun external-process-status (external-process) (let ((status (external-process-%status external-process))) @@ -60,32 +35,24 @@ ;;; running :: (values (member :stopped :resumed :running) code pid) ;;; --------------------------------------------------------------------- (defun external-process-wait (process &optional wait) - (let ((pid (external-process-pid process))) - (when pid - (multiple-value-bind (status code pid) (si:waitpid pid wait) - (ecase status - ((:exited :signaled :abort :error) - (with-active-processes-lock - (setf *active-processes* (delete process *active-processes*) - (external-process-pid process) nil + (with-process-lock (process) + (let ((pid (external-process-pid process))) + (when pid + (multiple-value-bind (status code pid) (si:waitpid pid wait) + (ecase status + ((:exited :signaled :abort :error) + (setf (external-process-pid process) nil (external-process-%status process) status - (external-process-%code process) code))) - ((:stopped :resumed :running) - (setf (external-process-%status process) status - (external-process-%code process) code)) - ((nil) #| wait was nil and process didn't change |#))))) + (external-process-%code process) code)) + ((:stopped :resumed :running) + (setf (external-process-%status process) status + (external-process-%code process) code)) + ((nil) #| wait was nil and process didn't change |#)))))) (values (external-process-%status process) (external-process-%code process))) -;;; This function isn't overly safe. Assuming `external-process-wait' -;;; is called after getting PID but before function sends signal, -;;; zombie may be already removed and we are shooting the -;;; air. Reasonable expectation here would be putting the burden on -;;; the user, that he can't call both functions in racy manner. We are -;;; protected from sigchld-handler here thanks to the global lock -;;; active processes. (defun terminate-process (process &optional force) - (with-active-processes-lock + (with-process-lock (process) (let ((pid (external-process-pid process))) (when pid #+windows @@ -130,20 +97,9 @@ (if-input-does-not-exist nil) (if-output-exists :error) (if-error-exists :error) - status-hook (external-format :default) #+windows (escape-arguments t)) - ;; XXX: we should install handler during loading of external-process - ;; module. Problem lies in fact, that handlers can't be installed - ;; before cl_boot finishes, so this form can't be top level in case - ;; when moudle is built-in. Good solution to that problem would be - ;; providing hook mechanism for functions to call after cl_boot. - ;; This way many modules may be easily untied from the core. - #-msvc - (unless (ext:get-signal-handler ext:+sigchld+) - (ext:set-signal-handler ext:+sigchld+ #'sigchld-handler)) - (labels ((process-stream (which default &rest args) (cond ((eql which t) default) @@ -192,16 +148,8 @@ (process (make-external-process)) pid parent-write parent-read parent-error) - (unless wait - (with-active-processes-lock (push process *active-processes*))) - - (handler-case (multiple-value-setq (pid parent-write parent-read parent-error) - (si:spawn-subprocess progname args environ input output error)) - (t (c) - (unless wait - (with-active-processes-lock - (setf *active-processes* (delete process *active-processes*)))) - (signal c))) + (multiple-value-setq (pid parent-write parent-read parent-error) + (si:spawn-subprocess progname args environ input output error)) (let ((stream-write (when (< 0 parent-write) @@ -215,8 +163,7 @@ (setf (external-process-pid process) pid (external-process-input process) (or stream-write (null-stream :output)) (external-process-output process) (or stream-read (null-stream :input)) - (external-process-error-stream process) (or stream-error (null-stream :input)) - (external-process-status-hook process) status-hook) + (external-process-error-stream process) (or stream-error (null-stream :input))) (values (make-two-way-stream (external-process-output process) (external-process-input process)) diff --git a/src/tests/normal-tests/run-program.lsp b/src/tests/normal-tests/run-program.lsp index 5ddd1570c..f92ddf661 100644 --- a/src/tests/normal-tests/run-program.lsp +++ b/src/tests/normal-tests/run-program.lsp @@ -135,22 +135,3 @@ (is-not (zerop (length (get-output-stream-string error-stream)))) (mapc #'close (list output-stream error-stream)))) - -#-windows -(test sigchld-handler - (let ((x 0)) - (flet ((status-hook (process) - (incf x))) - (with-run-program (heartbeat nil :status-hook #'status-hook) - (si:killpid (ext:external-process-pid process) ext:+sigstop+) - (sleep 1) - (si:killpid (ext:external-process-pid process) ext:+sigcont+) - (sleep 1) - (ext:terminate-process process) - (sleep 1)) - #-cygwin - (is (= x 3) "X is ~s, should be 3." x) - ;; XXX: cygwin quirk: sigchld isn't called for suspend/resume on - ;; cygwin (but they work - process is suspended/resumed) - #+cygwin - (is (= x 1) "X is ~s, should be 1." x))))