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 79d3e49a254d1b38d1e3823354643dca6a1183fe..6fcefdd2d614e9756bedeac5499c2683eaad4fe4 100644 (file)
--- 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
 \f
 #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",                           \
 }
 \f
 /* Termination codes: the interpreter halts on these */

diff --git a/src/microcode/osscheme.c b/src/microcode/osscheme.c
index 816ee3523427c5738ebb60d5429c87b3b37d29b7..833f05b4a47a9f61e1f8d101c93751b702bd1870 100644 (file)
--- 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 c6121562c2a525d2f8d51629d6132b282118b4f7..706ac3cc7fea34071a7b54fef4f648dfe010418f 100644 (file)
--- 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 f07ea8be46ab7f48fc1fa0cead68d19080f4edcd..c8f7793bf0d3a54248d34b13a257362c9dd14b6f 100644 (file)
--- 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);
 }
 \f
-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 ();
+}
+\f
 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 09677b7fd0c39d7cfad8611282c64bd5ed883322..19176487b47c35f8863541b57c29d6f3ed0ddf9a 100644 (file)
--- 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 53eb7408a2c1bbdcbc6e26cca4a6e9da64156ee9..f0090813629e5252ccd2d038a8e34de8827ae62d 100644 (file)
--- 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)
 \f
 (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 (file)
index 0000000..ddab355
--- /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))
+\f
+(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)))))