From: Taylor R Campbell Date: Mon, 11 Oct 2010 02:47:43 +0000 (+0000) Subject: Refuse to signal a subprocess that has terminated. X-Git-Tag: 20101212-Gtk~45 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=da4e4a0e05d86e197ed8cc248a81bb2713f72662;p=mit-scheme.git Refuse to signal a subprocess that has terminated. Once Scheme has called wait*(2) on a process that has terminated, its pid may be recycled, so attempting to send a signal to it may cause a signal to be sent to some random process! New tests for subprocess support include a regression test for this. --- diff --git a/src/microcode/errors.h b/src/microcode/errors.h index 79d3e49a2..6fcefdd2d 100644 --- a/src/microcode/errors.h +++ b/src/microcode/errors.h @@ -95,10 +95,11 @@ USA. #define ERR_ILLEGAL_CONTINUATION 0x3C #define ERR_STACK_HAS_SLIPPED 0x3D #define ERR_CANNOT_RECURSE 0x3E +#define ERR_PROCESS_TERMINATED 0x3F /* If you add any error codes here, add them to the table below. */ -#define MAX_ERROR 0x3E +#define MAX_ERROR 0x3F #define ERROR_NAME_TABLE \ { \ @@ -164,7 +165,8 @@ USA. /* 0x3b */ "unknown-primitive-continuation", \ /* 0x3c */ "illegal-continuation", \ /* 0x3d */ "stack-has-slipped", \ -/* 0x3e */ "cannot-recurse" \ +/* 0x3e */ "cannot-recurse", \ +/* 0x3f */ "process-terminated", \ } /* Termination codes: the interpreter halts on these */ diff --git a/src/microcode/osscheme.c b/src/microcode/osscheme.c index 816ee3523..833f05b4a 100644 --- a/src/microcode/osscheme.c +++ b/src/microcode/osscheme.c @@ -51,6 +51,12 @@ error_floating_point_exception (void) signal_error_from_primitive (ERR_FLOATING_OVERFLOW); } +void +error_process_terminated (void) +{ + signal_error_from_primitive (ERR_PROCESS_TERMINATED); +} + int executing_scheme_primitive_p (void) { diff --git a/src/microcode/osscheme.h b/src/microcode/osscheme.h index c6121562c..706ac3cc7 100644 --- a/src/microcode/osscheme.h +++ b/src/microcode/osscheme.h @@ -41,6 +41,7 @@ extern void error_out_of_channels (void) NORETURN; extern void error_unimplemented_primitive (void) NORETURN; extern void error_out_of_processes (void) NORETURN; extern void error_floating_point_exception (void) NORETURN; +extern void error_process_terminated (void) NORETURN; #ifdef __OS2__ extern void request_attention_interrupt (void); diff --git a/src/microcode/uxproc.c b/src/microcode/uxproc.c index f07ea8be4..c8f7793bf 100644 --- a/src/microcode/uxproc.c +++ b/src/microcode/uxproc.c @@ -512,8 +512,8 @@ OS_process_any_status_change (void) return (process_tick != sync_tick); } -void -OS_process_send_signal (Tprocess process, int sig) +static void +process_send_signal (Tprocess process, int sig) { STD_VOID_SYSTEM_CALL (syscall_kill, @@ -523,6 +523,41 @@ OS_process_send_signal (Tprocess process, int sig) sig))); } +void +OS_process_send_signal (Tprocess process, int sig) +{ + /* This is hairy because it is not OK to send a signal if the process + has already terminated and we have already called wait(2) -- its + pid will be recycled, and we might send a signal to some innocent + bystander. So we must guarantee that we won't call wait(2), by + blocking SIGCHLD, and check whether the process is in such a state + that we can safely signal it. */ + transaction_begin (); + block_sigchld (); + switch (PROCESS_RAW_STATUS (process)) + { + case process_status_running: + case process_status_stopped: + process_send_signal (process, sig); + break; + + case process_status_exited: + case process_status_signalled: + /* FIXME: This should signal an error with an argument -- namely, + with the process index, so that the runtime can do a reverse + lookup in the subprocess GC finalizer and put the appropriate + subprocess object in the Scheme error it signals. */ + error_process_terminated (); + + /* The remaining cases shouldn't happen unless there is a bug in + the runtime; and if so, this is basically like a system call + error. */ + default: + error_in_system_call (syserr_no_such_process, syscall_kill); + } + transaction_commit (); +} + void OS_process_kill (Tprocess process) { @@ -561,7 +596,7 @@ OS_process_continue_background (Tprocess process) if ((PROCESS_RAW_STATUS (process)) == process_status_stopped) { NEW_RAW_STATUS (process, process_status_running, 0); - OS_process_send_signal (process, SIGCONT); + process_send_signal (process, SIGCONT); } transaction_commit (); } @@ -576,7 +611,7 @@ OS_process_continue_foreground (Tprocess process) if ((PROCESS_RAW_STATUS (process)) == process_status_stopped) { NEW_RAW_STATUS (process, process_status_running, 0); - OS_process_send_signal (process, SIGCONT); + process_send_signal (process, SIGCONT); } process_wait (process); transaction_commit (); diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 09677b7fd..19176487b 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -2639,6 +2639,7 @@ USA. condition-type:out-of-file-handles condition-type:primitive-io-error condition-type:primitive-procedure-error + condition-type:process-terminated-error condition-type:system-call-error condition-type:unimplemented-primitive condition-type:unimplemented-primitive-for-os diff --git a/src/runtime/uerror.scm b/src/runtime/uerror.scm index 53eb7408a..f00908136 100644 --- a/src/runtime/uerror.scm +++ b/src/runtime/uerror.scm @@ -41,6 +41,7 @@ USA. (define condition-type:out-of-file-handles) (define condition-type:primitive-io-error) (define condition-type:primitive-procedure-error) +(define condition-type:process-terminated-error) (define condition-type:system-call-error) (define condition-type:unimplemented-primitive) (define condition-type:unimplemented-primitive-for-os) @@ -724,6 +725,21 @@ USA. (signal-file-operation continuation operator operands 0 "open" "file" "channel table full") (signal continuation operator operands)))))))) + +;++ This should identify the process, but that requires reverse lookup +;++ in the subprocess GC finalizer, and I'm lazy. + +(set! condition-type:process-terminated-error + (make-condition-type 'PROCESS-TERMINATED + condition-type:primitive-procedure-error + '() + (lambda (condition port) + (write-string "The primitive " port) + (write-operator (access-condition condition 'OPERATOR) port) + (write-string " was given a process that has terminated.")))) + +(define-primitive-error 'PROCESS-TERMINATED + condition-type:process-terminated-error) (set! condition-type:system-call-error (make-condition-type 'SYSTEM-CALL-ERROR diff --git a/tests/runtime/test-process.scm b/tests/runtime/test-process.scm new file mode 100644 index 000000000..ddab3551f --- /dev/null +++ b/tests/runtime/test-process.scm @@ -0,0 +1,60 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Tests of low-level subprocess support + +(declare (usual-integrations)) + +(define (shell-subprocess command) + (start-pipe-subprocess "/bin/sh" `#("/bin/sh" "-c" ,command) '#())) + +(define-test 'SIMPLE-SHELL-SUBPROCESS + (lambda () + (assert-true (subprocess? (shell-subprocess ":"))))) + +(define-test 'SUBPROCESS-WAIT:EXIT + (lambda () + (let ((subprocess (shell-subprocess ":"))) + (assert-eqv (subprocess-wait subprocess) 'EXITED)))) + +(define-test 'SUBPROCESS-WAIT:KILL + (lambda () + (let ((subprocess + ;; `read x' is a cheesy way to keep it from exiting on its + ;; own, without busy-waiting or relying on external + ;; executables. + (shell-subprocess "read x"))) + (subprocess-kill subprocess) + (assert-eqv (subprocess-wait subprocess) 'SIGNALLED)))) + +(define-test 'REGRESSION:SUBPROCESS-KILL-ERROR-AFTER-TERMINATION + ;; This is a slightly dangerous test: if we regress, then this might + ;; send SIGKILL a random process on your system! Maybe this will be + ;; an incentive to you to avoid regressing. + (lambda () + (let ((subprocess (shell-subprocess ":"))) + (assert-eqv (subprocess-wait subprocess) 'EXITED) + (assert-error (lambda () (subprocess-kill subprocess)) + (list condition-type:process-terminated-error)))))