From f7e224b84e0b6cc13a56fe5ac71c6050a20676f0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 18 Feb 2017 15:04:10 +0100 Subject: [PATCH 01/77] external-process: remove interface ties from the core We are stopping to handle sigchld for time being because it was too tightly coupled with core. Internal interface wait-for-all-processes is removed as well as eager update of process state. --- src/c/main.d | 3 - src/c/symbols_list.h | 1 - src/c/symbols_list2.h | 1 - src/c/unixint.d | 16 +---- src/c/unixsys.d | 161 ++++++++---------------------------------- src/h/external.h | 4 -- src/h/internal.h | 1 - 7 files changed, 29 insertions(+), 158 deletions(-) diff --git a/src/c/main.d b/src/c/main.d index 8e5e43ac..0b754a19 100755 --- a/src/c/main.d +++ b/src/c/main.d @@ -83,7 +83,6 @@ cl_fixnum ecl_option_values[ECL_OPT_LIMIT+1] = { 1, /* ECL_OPT_TRAP_SIGILL */ 1, /* ECL_OPT_TRAP_SIGBUS */ 1, /* ECL_OPT_TRAP_SIGPIPE */ - 1, /* ECL_OPT_TRAP_SIGCHLD */ 1, /* ECL_OPT_TRAP_INTERRUPT_SIGNAL */ 1, /* ECL_OPT_SIGNAL_HANDLING_THREAD */ 16, /* ECL_OPT_SIGNAL_QUEUE_SIZE */ @@ -431,8 +430,6 @@ struct cl_core_struct cl_core = { (cl_object)&default_rehash_size_data, /* rehash_size */ (cl_object)&default_rehash_threshold_data, /* rehash_threshold */ - ECL_NIL, /* external_processes */ - ECL_NIL, /* external_processes_lock */ ECL_NIL /* known_signals */ }; diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 859121c5..071e54fb 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1235,7 +1235,6 @@ cl_symbols[] = { {EXT_ "RUN-PROGRAM", EXT_ORDINARY, ECL_NAME(si_run_program), -1, OBJNULL}, {SYS_ "RUN-PROGRAM-INTERNAL", SI_ORDINARY, si_run_program_internal, 8, OBJNULL}, {EXT_ "TERMINATE-PROCESS", EXT_ORDINARY, si_terminate_process, -1, OBJNULL}, -{SYS_ "WAIT-FOR-ALL-PROCESSES", SI_ORDINARY, si_wait_for_all_processes, -1, OBJNULL}, {EXT_ "SAFE-EVAL", EXT_ORDINARY, ECL_NAME(si_safe_eval), -1, OBJNULL}, {SYS_ "SCH-FRS-BASE", SI_ORDINARY, si_sch_frs_base, 2, OBJNULL}, {SYS_ "SCHAR-SET", SI_ORDINARY, si_char_set, 3, OBJNULL}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 926c6df8..cf9c0cba 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1235,7 +1235,6 @@ cl_symbols[] = { {EXT_ "RUN-PROGRAM","ECL_NAME(si_run_program)"}, {SYS_ "RUN-PROGRAM-INTERNAL","si_run_program_internal"}, {EXT_ "TERMINATE-PROCESS","si_terminate_process"}, -{SYS_ "WAIT-FOR-ALL-PROCESSES","si_wait_for_all_processes"}, {EXT_ "SAFE-EVAL","ECL_NAME(si_safe_eval)"}, {SYS_ "SCH-FRS-BASE","si_sch_frs_base"}, {SYS_ "SCHAR-SET","si_char_set"}, diff --git a/src/c/unixint.d b/src/c/unixint.d index 1ceb826b..d43cf24e 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -161,7 +161,7 @@ static struct { { SIGCONT, "+SIGCONT+", ECL_NIL}, #endif #ifdef SIGCHLD - { SIGCHLD, "+SIGCHLD+", @'si::wait-for-all-processes'}, + { SIGCHLD, "+SIGCHLD+", ECL_NIL/* @'si::wait-for-all-processes' */}, #endif #ifdef SIGTTIN { SIGTTIN, "+SIGTTIN+", ECL_NIL}, @@ -568,12 +568,6 @@ asynchronous_signal_servicing_thread() signal_thread_msg.process == the_env->own_process) { break; } -#ifdef SIGCHLD - if (signal_thread_msg.signo == SIGCHLD) { - si_wait_for_all_processes(0); - continue; - } -#endif signal_code = ecl_gethash_safe(ecl_make_fixnum(signal_thread_msg.signo), cl_core.known_signals, ECL_NIL); @@ -1241,14 +1235,6 @@ install_asynchronous_signal_handlers() async_handler(SIGINT, non_evil_signal_handler, sigmask); } #endif -#ifdef SIGCHLD - if (ecl_option_values[ECL_OPT_TRAP_SIGCHLD]) { - /* We have to set the process signal handler explicitly, - * because on many platforms the default is SIG_IGN. */ - mysignal(SIGCHLD, non_evil_signal_handler); - async_handler(SIGCHLD, non_evil_signal_handler, sigmask); - } -#endif #ifdef HAVE_SIGPROCMASK # if defined(ECL_THREADS) pthread_sigmask(SIG_SETMASK, sigmask, NULL); diff --git a/src/c/unixsys.d b/src/c/unixsys.d index cabc7672..87e1fb5d 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -167,77 +167,6 @@ set_external_process_pid(cl_object process, cl_object pid) ecl_structure_set(process, @'ext::external-process', 0, pid); } -static void -set_external_process_streams(cl_object process, cl_object input, - cl_object output, cl_object error) -{ - ecl_structure_set(process, @'ext::external-process', 1, input); - ecl_structure_set(process, @'ext::external-process', 2, output); - ecl_structure_set(process, @'ext::external-process', 3, error); -} - - -static void -update_process_status(cl_object process, cl_object status, cl_object code) -{ - ecl_structure_set(process, @'ext::external-process', 0, ECL_NIL); - ecl_structure_set(process, @'ext::external-process', 4, status); - ecl_structure_set(process, @'ext::external-process', 5, code); -} - -#if defined(SIGCHLD) && !defined(ECL_MS_WINDOWS_HOST) -static void -add_external_process(cl_env_ptr env, cl_object process) -{ - cl_object l = ecl_list1(process); - ecl_disable_interrupts_env(env); - ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock); - { - ECL_RPLACD(l, cl_core.external_processes); - cl_core.external_processes = l; - } - ECL_WITH_SPINLOCK_END; - ecl_enable_interrupts_env(env); -} - -static void -remove_external_process(cl_env_ptr env, cl_object process) -{ - ecl_disable_interrupts_env(env); - ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock); - { - cl_core.external_processes = - ecl_delete_eq(process, cl_core.external_processes); - } - ECL_WITH_SPINLOCK_END; - ecl_enable_interrupts_env(env); -} - -static cl_object -find_external_process(cl_env_ptr env, cl_object pid) -{ - cl_object output = ECL_NIL; - ecl_disable_interrupts_env(env); - ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock); - { - cl_object p; - for (p = cl_core.external_processes; p != ECL_NIL; p = ECL_CONS_CDR(p)) { - cl_object process = ECL_CONS_CAR(p); - if (external_process_pid(process) == pid) { - output = process; - break; - } - } - } - ECL_WITH_SPINLOCK_END(&cl_core.external_processes_lock); - ecl_enable_interrupts_env(env); - return output; -} -#else -#define add_external_process(env,p) -#define remove_external_process(env,p) -#endif - static cl_object ecl_waitpid(cl_object pid, cl_object wait) { @@ -302,61 +231,29 @@ ecl_waitpid(cl_object pid, cl_object wait) } @(defun ext::terminate-process (process &optional (force ECL_NIL)) - @ - { +@ +{ cl_env_ptr env = ecl_process_env(); bool error_encountered = FALSE; - ECL_WITH_SPINLOCK_BEGIN(env, &cl_core.external_processes_lock); - { - cl_object pid = external_process_pid(process); - if (!Null(pid)) { - int ret; + + cl_object pid = external_process_pid(process); + if (!Null(pid)) { + int ret; #if defined(ECL_MS_WINDOWS_HOST) - HANDLE *ph = (HANDLE*)ecl_foreign_data_pointer_safe(pid); - ret = TerminateProcess(*ph, -1); - error_encountered = (ret == 0); + HANDLE *ph = (HANDLE*)ecl_foreign_data_pointer_safe(pid); + ret = TerminateProcess(*ph, -1); + error_encountered = (ret == 0); #else - ret = kill(ecl_fixnum(pid), Null(force) ? SIGTERM : SIGKILL); - error_encountered = (ret != 0); + ret = kill(ecl_fixnum(pid), Null(force) ? SIGTERM : SIGKILL); + error_encountered = (ret != 0); #endif - } } - ECL_WITH_SPINLOCK_END; + if (error_encountered) FEerror("Cannot terminate the process ~A", 1, process); return ECL_NIL; - } - @) - - -@(defun si::wait-for-all-processes (&key (process ECL_NIL)) - @ - { - const cl_env_ptr env = ecl_process_env(); -#if defined(SIGCHLD) && !defined(ECL_WINDOWS_HOST) - do { - cl_object status = ecl_waitpid(ecl_make_fixnum(-1), ECL_NIL); - cl_object code = env->values[1]; - cl_object pid = env->values[2]; - if (Null(pid)) { - if (status != @':abort') - break; - } else { - cl_object p = find_external_process(env, pid); - if (!Null(p)) { - set_external_process_pid(p, ECL_NIL); - update_process_status(p, status, code); - } - if (status != @':running') { - remove_external_process(env, p); - ecl_delete_eq(p, cl_core.external_processes); - } - } - } while (1); -#endif - ecl_return0(env); - } - @) +} +@) #if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin) cl_object @@ -386,11 +283,10 @@ make_windows_handle(HANDLE h) AGAIN: pid = external_process_pid(process); if (Null(pid)) { - /* If PID is NIL, it may be because the process failed, - * or because it is being updated by a separate thread, - * which is why we have to spin here. Note also the order - * here: status is updated _after_ code, and hence we - * check it _before_ code. */ + /* If PID is NIL, it may be because the process failed, or + * because it is being updated by a separate thread, which is + * why we have to spin here. Note also the order here: status is + * updated _after_ code, and hence we check it _before_ code. */ do { ecl_musleep(0.0, 1); status = external_process_status(process); @@ -408,8 +304,9 @@ make_windows_handle(HANDLE h) status = external_process_status(process); code = external_process_code(process); } else { - update_process_status(process, status, code); - remove_external_process(the_env, process); + ecl_structure_set(process, @'ext::external-process', 0, ECL_NIL); + ecl_structure_set(process, @'ext::external-process', 4, status); + ecl_structure_set(process, @'ext::external-process', 5, code); } } @(return status code); @@ -452,9 +349,9 @@ create_descriptor(cl_object stream, cl_object direction, attr.bInheritHandle = TRUE; if (stream == @':stream') { - /* Creates a pipe that we can write to and the - child reads from. We duplicate one extreme of the - pipe so that the child does not inherit it. */ + /* Creates a pipe that we can write to and the child reads + from. We duplicate one extreme of the pipe so that the child + does not inherit it. */ HANDLE tmp; if (CreatePipe(&tmp, child, &attr, 0) == 0) return; @@ -589,8 +486,6 @@ si_run_program_internal(cl_object command, cl_object argv, else create_descriptor(error, @':output', &child_stderr, &parent_error); - add_external_process(the_env, process); - ZeroMemory(&st_info, sizeof(STARTUPINFO)); st_info.cb = sizeof(STARTUPINFO); st_info.lpTitle = NULL; /* No window title, just exec name */ @@ -648,7 +543,6 @@ si_run_program_internal(cl_object command, cl_object argv, else create_descriptor(error, @':output', &child_stderr, &parent_error); - add_external_process(the_env, process); pipe(pipe_fd); child_pid = fork(); if (child_pid == 0) { @@ -727,7 +621,6 @@ si_run_program_internal(cl_object command, cl_object argv, parent_write = 0; parent_read = 0; parent_error = 0; - remove_external_process(the_env, process); FEerror("Could not spawn subprocess to run ~S.", 1, command); } if (parent_write > 0) { @@ -757,8 +650,10 @@ si_run_program_internal(cl_object command, cl_object argv, parent_error = 0; stream_error = cl_core.null_stream; } - set_external_process_streams(process, stream_write, stream_read, - stream_error); + ecl_structure_set(process, @'ext::external-process', 1, input); + ecl_structure_set(process, @'ext::external-process', 2, output); + ecl_structure_set(process, @'ext::external-process', 3, error); + if (!Null(wait)) { exit_status = si_external_process_wait(2, process, ECL_T); exit_status = ecl_nth_value(the_env, 1); diff --git a/src/h/external.h b/src/h/external.h index 5956b903..c5a988d7 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -251,9 +251,6 @@ struct cl_core_struct { cl_object rehash_size; cl_object rehash_threshold; - cl_object external_processes; - cl_object external_processes_lock; - cl_object known_signals; }; @@ -945,7 +942,6 @@ typedef enum { ECL_OPT_TRAP_SIGILL, ECL_OPT_TRAP_SIGBUS, ECL_OPT_TRAP_SIGPIPE, - ECL_OPT_TRAP_SIGCHLD, ECL_OPT_TRAP_INTERRUPT_SIGNAL, ECL_OPT_SIGNAL_HANDLING_THREAD, ECL_OPT_SIGNAL_QUEUE_SIZE, diff --git a/src/h/internal.h b/src/h/internal.h index 9a512c0c..7f18783a 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -526,7 +526,6 @@ extern cl_object mp_get_rwlock_write_wait(cl_object lock); extern void ecl_interrupt_process(cl_object process, cl_object function); /* unixsys.d */ -extern cl_object si_wait_for_all_processes _ECL_ARGS((cl_narg narg, ...)); extern cl_object si_run_program_internal (cl_object command, cl_object argv, cl_object input, cl_object output, cl_object error, From 0144154b9d0bb541b11c0044ad2568ddee117cb8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 18 Feb 2017 19:14:34 +0100 Subject: [PATCH 02/77] prepare-args: coerce arguments for windows --- src/lsp/process.lsp | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 14381a6f..1d292080 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -47,9 +47,8 @@ #+windows :escape-arguments nil)))) ;;; -;;; Wrapper around si_run_program call. Thanks to that C interface -;;; isn't clobbered with lispisms. Ultimately we'd want to have as -;;; little as possible in unixsys.d. +;;; Almighty EXT:RUN-PROGRAM. Built on top of SI:SPAWN-SUBPROCESS. For +;;; simpler alternative see SI:RUN-PROGRAM-INNER. ;;; (defun run-program (command argv &key @@ -79,16 +78,17 @@ #-windows (mapcar #'si:copy-to-simple-base-string args) #+windows - (with-output-to-string (str) - (loop for (arg . rest) on args - do (if (and escape-arguments - (find-if (lambda (c) - (find c '(#\Space #\Tab #\"))) - arg)) - (escape-arg arg str) - (princ arg str)) - (when rest - (write-char #\Space str)))))) + (si:copy-to-simple-base-string + (with-output-to-string (str) + (loop for (arg . rest) on args + do (if (and escape-arguments + (find-if (lambda (c) + (find c '(#\Space #\Tab #\"))) + arg)) + (escape-arg arg str) + (princ arg str)) + (when rest + (write-char #\Space str))))))) (setf input (process-stream input *standard-input* :direction :input From 1e62ca0a1a01e4f3d5cf3f87540c7ad1389b6f37 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 18 Feb 2017 20:23:15 +0100 Subject: [PATCH 03/77] prepare-args: last argument is NIL for POSIX On POSIX arguments starts with command name and end with NULL. Ensure, that last argument is NULL to avoid "Bad address". --- src/lsp/process.lsp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 1d292080..9fa39561 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -76,7 +76,7 @@ (prepare-args (args) #-windows - (mapcar #'si:copy-to-simple-base-string args) + (nconc (mapcar #'si:copy-to-simple-base-string args) (list nil)) #+windows (si:copy-to-simple-base-string (with-output-to-string (str) From 4aaadf0545423e87687af4f99b1ef487846b4436 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 18 Feb 2017 20:25:17 +0100 Subject: [PATCH 04/77] core: bring bad old system function --- src/c/unixsys.d | 8 ++++++++ src/cmp/cmpos-run.lsp | 37 ++++++++----------------------------- src/cmp/sysfun.lsp | 1 - 3 files changed, 16 insertions(+), 30 deletions(-) diff --git a/src/c/unixsys.d b/src/c/unixsys.d index 87e1fb5d..69eead53 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -39,6 +39,14 @@ # undef environ #endif +cl_object +si_system(cl_object cmd_string) +{ + cl_object cmd = si_copy_to_simple_base_string(cmd_string); + int code = system((const char *)(cmd->base_string.self)); + return ecl_make_fixnum(code); +} + cl_object si_getpid(void) { diff --git a/src/cmp/cmpos-run.lsp b/src/cmp/cmpos-run.lsp index b824409a..97ef8aea 100755 --- a/src/cmp/cmpos-run.lsp +++ b/src/cmp/cmpos-run.lsp @@ -18,15 +18,6 @@ #+(and cygwin (not ecl-min)) (ffi:clines "#include ") -(defun safe-system (string) - (cmpnote "Invoking external command:~% ~A~%" string) - (let ((result (ext:system string))) - (unless (zerop result) - (cerror "Continues anyway." - "(SYSTEM ~S) returned non-zero value ~D" - string result)) - result)) - (defun save-directory (forms) (let ((directory (probe-file (make-pathname :name nil :type nil @@ -42,28 +33,16 @@ (defmacro with-current-directory (&body forms) `(save-directory #'(lambda () ,@forms))) -#+(and cygwin (not ecl-min)) -(defun old-crappy-system (program args) - (let* ((command (format nil "~S~{ ~S~}" program args)) - (base-string-command (si:copy-to-simple-base-string command)) - (code (ffi:c-inline (base-string-command) (:object) :int - "system((const char*)(#0->base_string.self))":one-liner t))) - (values nil code nil))) - (defun safe-run-program (program args) (cmpnote "Invoking external command:~% ~A ~{~A ~}" program args) - (multiple-value-bind (stream result process) - (let* ((*standard-output* ext:+process-standard-output+) - (*error-output* ext:+process-error-output+) - (program (split-program-options program)) - (args `(,@(cdr program) ,@args)) - (program (car program))) - (with-current-directory - #-(and cygwin (not ecl-min)) - (ext:run-program program args :input nil :output t :error t :wait t) - #+(and cygwin (not ecl-min)) - (old-crappy-system program args) - )) + (let ((result + (let* ((*standard-output* ext:+process-standard-output+) + (*error-output* ext:+process-error-output+) + (program (split-program-options program)) + (args `(,@(cdr program) ,@args)) + (program (car program))) + (with-current-directory + (ext:system (format nil "~S~{ ~S~}" program args)))))) (cond ((null result) (cerror "Continues anyway." "Unable to execute:~%(RUN-PROGRAM ~S ~S)" diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index 61a37a6c..00c8f660 100644 --- a/src/cmp/sysfun.lsp +++ b/src/cmp/sysfun.lsp @@ -938,7 +938,6 @@ ;; setf.lsp si::do-defsetf si::do-define-setf-method ;; process.lsp - ext:system ext:run-program ;; pprint.lsp pprint-fill copy-pprint-dispatch pprint-dispatch From a402eaca70fd807b7b2ecdc2276dc894bb25cd4f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 18 Feb 2017 20:25:32 +0100 Subject: [PATCH 05/77] core: bring bad old system function (2) --- src/lsp/process.lsp | 1 + 1 file changed, 1 insertion(+) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 9fa39561..20baf669 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -34,6 +34,7 @@ ;;; because we are consuming the process wait status using a SIGCHLD ;;; handler -- this breaks some C libraries out there (OS X 32 bit). ;;; +#+ (or) (defun system (cmd-string) (let ((shell "/bin/sh") (option "-c")) From 6ff556b707b55b76363c504ce29a2ebda87d9473 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 18 Feb 2017 20:25:51 +0100 Subject: [PATCH 06/77] core: bring bad old system function (3) --- src/c/symbols_list.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 071e54fb..2609282b 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1267,7 +1267,7 @@ cl_symbols[] = { {SYS_ "STRUCTUREP", SI_ORDINARY, si_structurep, 1, OBJNULL}, {SYS_ "SVSET", SI_ORDINARY, si_svset, 3, OBJNULL}, {SYS_ "SYMBOL-MACRO", SI_ORDINARY, NULL, -1, OBJNULL}, -{EXT_ "SYSTEM", EXT_ORDINARY, ECL_NAME(si_system), 1, OBJNULL}, +{EXT_ "SYSTEM", EXT_ORDINARY, si_system, 1, OBJNULL}, {SYS_ "TERMINAL-INTERRUPT", SI_ORDINARY, NULL, -1, OBJNULL}, {SYS_ "TOP-LEVEL", SI_ORDINARY, NULL, -1, OBJNULL}, {SYS_ "UNIVERSAL-ERROR-HANDLER", SI_ORDINARY, NULL, -1, OBJNULL}, From 127af0e59a21e13519d421f98df054ce0dd5c07c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 18 Feb 2017 20:27:46 +0100 Subject: [PATCH 07/77] prepare-args: revert, its create process responsibility --- src/c/symbols_list.h | 3 +- src/c/symbols_list2.h | 5 ++-- src/c/unixsys.d | 67 +++++++++++++++++++++++++++++++------------ src/lsp/process.lsp | 2 +- 4 files changed, 54 insertions(+), 23 deletions(-) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 2609282b..3f11c646 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1233,7 +1233,8 @@ cl_symbols[] = { {SYS_ "REPLACE-ARRAY", SI_ORDINARY, si_replace_array, 2, OBJNULL}, {SYS_ "ROW-MAJOR-ASET", SI_ORDINARY, si_row_major_aset, 3, OBJNULL}, {EXT_ "RUN-PROGRAM", EXT_ORDINARY, ECL_NAME(si_run_program), -1, OBJNULL}, -{SYS_ "RUN-PROGRAM-INTERNAL", SI_ORDINARY, si_run_program_internal, 8, OBJNULL}, +{SYS_ "RUN-PROGRAM-INNER", SI_ORDINARY, si_run_program_inner, 3, OBJNULL}, +{SYS_ "SPAWN-SUBPROCESS", SI_ORDINARY, si_spawn_subprocess, 6, OBJNULL}, {EXT_ "TERMINATE-PROCESS", EXT_ORDINARY, si_terminate_process, -1, OBJNULL}, {EXT_ "SAFE-EVAL", EXT_ORDINARY, ECL_NAME(si_safe_eval), -1, OBJNULL}, {SYS_ "SCH-FRS-BASE", SI_ORDINARY, si_sch_frs_base, 2, OBJNULL}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index cf9c0cba..9ffdf107 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1233,7 +1233,8 @@ cl_symbols[] = { {SYS_ "REPLACE-ARRAY","si_replace_array"}, {SYS_ "ROW-MAJOR-ASET","si_row_major_aset"}, {EXT_ "RUN-PROGRAM","ECL_NAME(si_run_program)"}, -{SYS_ "RUN-PROGRAM-INTERNAL","si_run_program_internal"}, +{SYS_ "RUN-PROGRAM-INNER","si_run_program_inner"}, +{SYS_ "SPAWN-SUBPROCESS","si_spawn_subprocess"}, {EXT_ "TERMINATE-PROCESS","si_terminate_process"}, {EXT_ "SAFE-EVAL","ECL_NAME(si_safe_eval)"}, {SYS_ "SCH-FRS-BASE","si_sch_frs_base"}, @@ -1267,7 +1268,7 @@ cl_symbols[] = { {SYS_ "STRUCTUREP","si_structurep"}, {SYS_ "SVSET","si_svset"}, {SYS_ "SYMBOL-MACRO",NULL}, -{EXT_ "SYSTEM","ECL_NAME(si_system)"}, +{EXT_ "SYSTEM","si_system"}, {SYS_ "TERMINAL-INTERRUPT",NULL}, {SYS_ "TOP-LEVEL",NULL}, {SYS_ "UNIVERSAL-ERROR-HANDLER",NULL}, diff --git a/src/c/unixsys.d b/src/c/unixsys.d index 69eead53..cedcdafb 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -145,12 +145,6 @@ from_list_to_execve_argument(cl_object l, char ***environp) return buffer; } -static cl_object -make_external_process() -{ - return _ecl_funcall1(@'ext::make-external-process'); -} - static cl_object external_process_pid(cl_object p) { @@ -454,20 +448,56 @@ create_descriptor(cl_object stream, cl_object direction, #endif cl_object -si_run_program_internal(cl_object command, cl_object argv, - cl_object input, cl_object output, cl_object error, - cl_object wait, cl_object environ, cl_object external_format) { +si_run_program_inner(cl_object command, cl_object argv, cl_object environ) { + cl_env_ptr the_env = ecl_process_env(); + int parent_write = 0, parent_read = 0, parent_error = 0; + cl_object pid, stream_write, stream_read, exit_status; + + command = si_copy_to_simple_base_string(command); + +#if defined(ECL_MS_WINDOWS_HOST) + argv = cl_format(4, ECL_NIL, + make_simple_base_string("~A~{ ~A~}"), + command, argv); + argv = si_copy_to_simple_base_string(argv); +#else + argv = cl_mapcar(2, @'si::copy-to-simple-base-string', argv); +#endif + + pid = si_spawn_subprocess(command, argv, environ, @':stream', @':stream', @':output'); + parent_write = ecl_fixnum(ecl_nth_value(the_env, 1)); + parent_read = ecl_fixnum(ecl_nth_value(the_env, 2)); + + if (Null(pid) || (parent_write <= 0) || (parent_read <= 0)) { + FEerror("Could not spawn subprocess to run ~S.", 1, command); + } + + stream_write = ecl_make_stream_from_fd(command, parent_write, + ecl_smm_output, 8, + ECL_STREAM_DEFAULT_FORMAT, + @':default'); + + stream_read = ecl_make_stream_from_fd(command, parent_read, + ecl_smm_input, 8, + ECL_STREAM_DEFAULT_FORMAT, + @':default'); + + ecl_waitpid(pid, ECL_T); + exit_status = ecl_nth_value(the_env, 1); + @(return cl_make_two_way_stream(stream_read, stream_write) exit_status) +} + +cl_object +si_spawn_subprocess(cl_object command, cl_object argv, cl_object environ, + cl_object input, cl_object output, cl_object error) { cl_env_ptr the_env = ecl_process_env(); int parent_write = 0, parent_read = 0, parent_error = 0; int child_pid; - cl_object pid, process; - cl_object stream_write; - cl_object stream_read; - cl_object stream_error; - cl_object exit_status = ECL_NIL; - @ - process = make_external_process(); + cl_object pid; + + /* command = ecl_null_terminated_base_string(command); */ + #if defined(ECL_MS_WINDOWS_HOST) { BOOL ok; @@ -503,11 +533,11 @@ si_run_program_internal(cl_object command, cl_object argv, st_info.hStdOutput = child_stdout; st_info.hStdError = child_stderr; ZeroMemory(&pr_info, sizeof(PROCESS_INFORMATION)); + /* Command is passed as is from argv. It is responsibility of higher level interface to decide, whenever arguments should be quoted or left as-is. */ - argv = si_copy_to_simple_base_string(argv); - argv = ecl_null_terminated_base_string(argv); + /* ecl_null_terminated_base_string(argv); */ ok = CreateProcess(NULL, argv->base_string.self, NULL, NULL, /* lpProcess/ThreadAttributes */ TRUE, /* Inherit handles (for files) */ @@ -532,7 +562,6 @@ si_run_program_internal(cl_object command, cl_object argv, LocalFree(message); pid = ECL_NIL; } - set_external_process_pid(process, pid); if (child_stdin) CloseHandle(child_stdin); if (child_stdout) CloseHandle(child_stdout); if (child_stderr) CloseHandle(child_stderr); diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 20baf669..60e44d60 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -77,7 +77,7 @@ (prepare-args (args) #-windows - (nconc (mapcar #'si:copy-to-simple-base-string args) (list nil)) + (mapcar #'si:copy-to-simple-base-string args) #+windows (si:copy-to-simple-base-string (with-output-to-string (str) From ce111619cf2a370ed4ae77ec8ee3fc154b9cef9a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 18 Feb 2017 20:31:03 +0100 Subject: [PATCH 08/77] run-program: provide simple interface run-program-inner Both run-program and run-program-inner work on same interface si:spawn-subprocess. --- src/c/unixsys.d | 63 +++++--------------------------------- src/cmp/cmpos-features.lsp | 18 +++++------ src/cmp/proclamations.lsp | 4 +++ src/h/internal.h | 10 +++--- src/lsp/process.lsp | 48 ++++++++++++++++++++++++++--- 5 files changed, 69 insertions(+), 74 deletions(-) diff --git a/src/c/unixsys.d b/src/c/unixsys.d index cedcdafb..251d3c19 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -626,13 +626,9 @@ si_spawn_subprocess(cl_object command, cl_object argv, cl_object environ, } else { pid = ecl_make_fixnum(child_pid); } - set_external_process_pid(process, pid); { - /* This guarantees that the child process does not exit - * before we have created the process structure. If we do not - * do this, the SIGPIPE signal may arrive before - * set_external_process_pid() and our call to external-process-wait - * down there may block indefinitely. */ + /* This guarantees that the child process does not exit before + * we have created the process structure. */ char sync[1]; close(pipe_fd[0]); while (write(pipe_fd[1], sync, 1) < 1) { @@ -647,57 +643,12 @@ si_spawn_subprocess(cl_object command, cl_object argv, cl_object environ, } #else /* NACL */ { - FElibc_error("ext::run-program not implemented",1); + FElibc_error("ext::run-program-inner not implemented",1); @(return ECL_NIL); } #endif - if (Null(pid)) { - if (parent_write) close(parent_write); - if (parent_read) close(parent_read); - if (parent_error) close(parent_error); - parent_write = 0; - parent_read = 0; - parent_error = 0; - FEerror("Could not spawn subprocess to run ~S.", 1, command); - } - if (parent_write > 0) { - stream_write = ecl_make_stream_from_fd(command, parent_write, - ecl_smm_output, 8, - ECL_STREAM_DEFAULT_FORMAT, - external_format); - } else { - parent_write = 0; - stream_write = cl_core.null_stream; - } - if (parent_read > 0) { - stream_read = ecl_make_stream_from_fd(command, parent_read, - ecl_smm_input, 8, - ECL_STREAM_DEFAULT_FORMAT, - external_format); - } else { - parent_read = 0; - stream_read = cl_core.null_stream; - } - if (parent_error > 0) { - stream_error = ecl_make_stream_from_fd(command, parent_error, - ecl_smm_input, 8, - ECL_STREAM_DEFAULT_FORMAT, - external_format); - } else { - parent_error = 0; - stream_error = cl_core.null_stream; - } - ecl_structure_set(process, @'ext::external-process', 1, input); - ecl_structure_set(process, @'ext::external-process', 2, output); - ecl_structure_set(process, @'ext::external-process', 3, error); - - if (!Null(wait)) { - exit_status = si_external_process_wait(2, process, ECL_T); - exit_status = ecl_nth_value(the_env, 1); - } - @(return ((parent_read || parent_write)? - cl_make_two_way_stream(stream_read, stream_write) : - ECL_NIL) - exit_status - process); + @(return pid + ecl_make_fixnum(parent_write) + ecl_make_fixnum(parent_read) + ecl_make_fixnum(parent_error)) } diff --git a/src/cmp/cmpos-features.lsp b/src/cmp/cmpos-features.lsp index 7e956a27..6ea89df5 100644 --- a/src/cmp/cmpos-features.lsp +++ b/src/cmp/cmpos-features.lsp @@ -21,16 +21,14 @@ while line collect line))) (handler-case - (multiple-value-bind (stream process) - (ext:run-program command args :input nil :output :stream :error :output) - (let ((lines (collect-lines stream))) - (cond ((null file) - lines) - ((probe-file file) - (with-open-file (s file :direction :input) - (collect-lines s))) - (t - (warn "Unable to find file ~A" file))))) + (let ((lines (collect-lines (si:run-program-inner command args nil)))) + (cond ((null file) + lines) + ((probe-file file) + (with-open-file (s file :direction :input) + (collect-lines s))) + (t + (warn "Unable to find file ~A" file)))) (error (c) (format t "~&;;; Unable to execute program ~S~&;;; Condition~&;;; ~A" command c))))) diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp index 9fe66b5c..42813d01 100644 --- a/src/cmp/proclamations.lsp +++ b/src/cmp/proclamations.lsp @@ -1329,6 +1329,10 @@ (values (or null two-way-stream) (or null integer) ext:external-process)) +(proclamation si:run-program-inner (string (or list string) list) + (values two-way-stream integer)) +(proclamation si:spawn-subprocess (string (or list string) list t t t) + (values (or null integer) fixnum fixnum fixnum)) (proclamation ext:terminate-process (t &optional gen-bool) null) (proclamation ext:make-weak-pointer (t) ext:weak-pointer :no-side-effects) diff --git a/src/h/internal.h b/src/h/internal.h index 7f18783a..f3710671 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -526,10 +526,12 @@ extern cl_object mp_get_rwlock_write_wait(cl_object lock); extern void ecl_interrupt_process(cl_object process, cl_object function); /* unixsys.d */ -extern cl_object si_run_program_internal -(cl_object command, cl_object argv, - cl_object input, cl_object output, cl_object error, - cl_object wait, cl_object environ, cl_object external_format); +extern cl_object si_run_program_inner +(cl_object command, cl_object argv, cl_object environ); + +extern cl_object si_spawn_subprocess +(cl_object command, cl_object argv, cl_object environ, + cl_object input, cl_object output, cl_object error); /* * Fake several ISO C99 mathematical functions if not available diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 60e44d60..15d7533c 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -104,12 +104,34 @@ :if-exists if-error-exists))) (let ((progname (si:copy-to-simple-base-string command)) - (args (prepare-args (cons command argv)))) - (si:run-program-internal progname args - input output error - wait environ external-format)))) + (args (prepare-args (cons command argv))) + (process (make-external-process))) + (multiple-value-bind (pid parent-write parent-read parent-error) + (si:spawn-subprocess progname args environ input output error) + (unless pid + (when parent-write (ff-close parent-write)) + (when parent-read (ff-close parent-read)) + (when parent-error (ff-close parent-error)) + (error "Could not spawn subprocess to run ~S." progname)) + (let ((stream-write + (when (< 0 parent-write) + (make-output-stream-from-fd progname parent-write external-format))) + (stream-read + (when (< 0 parent-read) + (make-input-stream-from-fd progname parent-read external-format))) + (stream-error + (when (< 0 parent-error) + (make-input-stream-from-fd progname parent-error external-format)))) + (setf (external-process-pid process) pid + (external-process-input process) (or stream-write (null-stream)) + (external-process-output process) (or stream-read (null-stream)) + (external-process-error-stream process) (or stream-error (null-stream))) + (values (make-two-way-stream (external-process-output process) + (external-process-input process)) + (when wait (nth-value 1 (si:external-process-wait process t))) + process)))))) #+windows (defun escape-arg (arg stream) @@ -141,3 +163,21 @@ (loop repeat slashes do (write-char #\\ stream))) (write-char #\" stream)) + + +;;; low level interface to descriptors +(defun make-input-stream-from-fd (name fd external-format) + (ffi:c-inline (name fd external-format) (:string :int :object) :object + "ecl_make_stream_from_fd(#0, #1, ecl_smm_input, 8, ECL_STREAM_DEFAULT_FORMAT, #2)" + :one-liner t)) + +(defun make-output-stream-from-fd (name fd external-format) + (ffi:c-inline (name fd external-format) (:string :int :object) :object + "ecl_make_stream_from_fd(#0, #1, ecl_smm_output, 8, ECL_STREAM_DEFAULT_FORMAT, #2)" + :one-liner t)) + +(defun null-stream () + (ffi:c-inline () () :object "cl_core.null_stream" :one-liner t :side-effects nil)) + +(ffi:defentry ff-close (:int) (:int "close") :no-interrupts t) + From 22ebecd7d021c3ae12587e3d230c9d480aa47ec8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 18 Feb 2017 20:45:43 +0100 Subject: [PATCH 09/77] run-program-inner: argv is (command . argv) --- src/c/unixsys.d | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/c/unixsys.d b/src/c/unixsys.d index 251d3c19..218d1276 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -461,7 +461,7 @@ si_run_program_inner(cl_object command, cl_object argv, cl_object environ) { command, argv); argv = si_copy_to_simple_base_string(argv); #else - argv = cl_mapcar(2, @'si::copy-to-simple-base-string', argv); + argv = CONS(command, cl_mapcar(2, @'si::copy-to-simple-base-string', argv)); #endif pid = si_spawn_subprocess(command, argv, environ, @':stream', @':stream', @':output'); From b4affb9302d98671b497ff321026ba755bd94cf7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 19 Feb 2017 07:45:25 +0100 Subject: [PATCH 10/77] ecl_waitpid: promote to internal global function si_waitpid --- src/c/unixsys.d | 16 +++++----------- src/h/internal.h | 2 ++ 2 files changed, 7 insertions(+), 11 deletions(-) diff --git a/src/c/unixsys.d b/src/c/unixsys.d index 218d1276..a03f92fd 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -163,18 +163,12 @@ external_process_code(cl_object p) return ecl_structure_ref(p, @'ext::external-process', 5); } -static void -set_external_process_pid(cl_object process, cl_object pid) -{ - ecl_structure_set(process, @'ext::external-process', 0, pid); -} - -static cl_object -ecl_waitpid(cl_object pid, cl_object wait) +cl_object +si_waitpid(cl_object pid, cl_object wait) { cl_object status, code; #if defined(NACL) - FElibc_error("ecl_waitpid not implemented",1); + FElibc_error("si_waitpid not implemented",1); @(return ECL_NIL); #elif defined(ECL_MS_WINDOWS_HOST) cl_env_ptr the_env = ecl_process_env(); @@ -295,7 +289,7 @@ make_windows_handle(HANDLE h) } while (status == @':running'); code = external_process_code(process); } else { - status = ecl_waitpid(pid, wait); + status = si_waitpid(pid, wait); code = ecl_nth_value(the_env, 1); pid = ecl_nth_value(the_env, 2); /* A SIGCHLD interrupt may abort waitpid. If this @@ -482,7 +476,7 @@ si_run_program_inner(cl_object command, cl_object argv, cl_object environ) { ECL_STREAM_DEFAULT_FORMAT, @':default'); - ecl_waitpid(pid, ECL_T); + si_waitpid(pid, ECL_T); exit_status = ecl_nth_value(the_env, 1); @(return cl_make_two_way_stream(stream_read, stream_write) exit_status) } diff --git a/src/h/internal.h b/src/h/internal.h index f3710671..3c4d2c75 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -526,6 +526,8 @@ extern cl_object mp_get_rwlock_write_wait(cl_object lock); extern void ecl_interrupt_process(cl_object process, cl_object function); /* unixsys.d */ +extern cl_object si_waitpid(cl_object pid, cl_object wait); + extern cl_object si_run_program_inner (cl_object command, cl_object argv, cl_object environ); From 333c23ad4ceed67b8a3e90466d919c5077203186 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 19 Feb 2017 07:59:41 +0100 Subject: [PATCH 11/77] external-process: move external-process-wait outside the core --- src/c/symbols_list.h | 4 +++- src/c/symbols_list2.h | 4 +++- src/c/unixsys.d | 47 ------------------------------------------- src/lsp/process.lsp | 37 ++++++++++++++++++++++++++++------ 4 files changed, 37 insertions(+), 55 deletions(-) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 3f11c646..ccf97408 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1975,6 +1975,7 @@ cl_symbols[] = { {KEY_ "ENVIRON", KEYWORD, NULL, -1, OBJNULL}, +/* external-process extension */ {EXT_ "MAKE-EXTERNAL-PROCESS", EXT_ORDINARY, NULL, -1, OBJNULL}, {EXT_ "EXTERNAL-PROCESS", EXT_ORDINARY, NULL, -1, OBJNULL}, {EXT_ "EXTERNAL-PROCESS-PID", EXT_ORDINARY, NULL, -1, OBJNULL}, @@ -1982,13 +1983,14 @@ cl_symbols[] = { {EXT_ "EXTERNAL-PROCESS-OUTPUT", EXT_ORDINARY, NULL, -1, OBJNULL}, {EXT_ "EXTERNAL-PROCESS-ERROR-STREAM", EXT_ORDINARY, NULL, -1, OBJNULL}, {EXT_ "EXTERNAL-PROCESS-STATUS", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "EXTERNAL-PROCESS-WAIT", EXT_ORDINARY, NULL, -1, OBJNULL}, {KEY_ "RUNNING", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "EXITED", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "SIGNALED", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "STOPPED", KEYWORD, NULL, -1, OBJNULL}, +/* ~ external-process extension */ -{EXT_ "EXTERNAL-PROCESS-WAIT", EXT_ORDINARY, si_external_process_wait, -1, OBJNULL}, #if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin) {SYS_ "CLOSE-WINDOWS-HANDLE", SI_ORDINARY, si_close_windows_handle, 1, OBJNULL}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 9ffdf107..3e3e5e24 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1975,6 +1975,7 @@ cl_symbols[] = { {KEY_ "ENVIRON",NULL}, +/* external-process extension */ {EXT_ "MAKE-EXTERNAL-PROCESS",NULL}, {EXT_ "EXTERNAL-PROCESS",NULL}, {EXT_ "EXTERNAL-PROCESS-PID",NULL}, @@ -1982,13 +1983,14 @@ cl_symbols[] = { {EXT_ "EXTERNAL-PROCESS-OUTPUT",NULL}, {EXT_ "EXTERNAL-PROCESS-ERROR-STREAM",NULL}, {EXT_ "EXTERNAL-PROCESS-STATUS",NULL}, +{EXT_ "EXTERNAL-PROCESS-WAIT",NULL}, {KEY_ "RUNNING",NULL}, {KEY_ "EXITED",NULL}, {KEY_ "SIGNALED",NULL}, {KEY_ "STOPPED",NULL}, +/* ~ external-process extension */ -{EXT_ "EXTERNAL-PROCESS-WAIT","si_external_process_wait"}, #if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin) {SYS_ "CLOSE-WINDOWS-HANDLE","si_close_windows_handle"}, diff --git a/src/c/unixsys.d b/src/c/unixsys.d index a03f92fd..7d89d8a3 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -151,18 +151,6 @@ external_process_pid(cl_object p) return ecl_structure_ref(p, @'ext::external-process', 0); } -static cl_object -external_process_status(cl_object p) -{ - return ecl_structure_ref(p, @'ext::external-process', 4); -} - -static cl_object -external_process_code(cl_object p) -{ - return ecl_structure_ref(p, @'ext::external-process', 5); -} - cl_object si_waitpid(cl_object pid, cl_object wait) { @@ -273,41 +261,6 @@ make_windows_handle(HANDLE h) } #endif -@(defun ext::external-process-wait (process &optional (wait ECL_NIL)) - @ { - cl_object status, code, pid; - AGAIN: - pid = external_process_pid(process); - if (Null(pid)) { - /* If PID is NIL, it may be because the process failed, or - * because it is being updated by a separate thread, which is - * why we have to spin here. Note also the order here: status is - * updated _after_ code, and hence we check it _before_ code. */ - do { - ecl_musleep(0.0, 1); - status = external_process_status(process); - } while (status == @':running'); - code = external_process_code(process); - } else { - status = si_waitpid(pid, wait); - code = ecl_nth_value(the_env, 1); - pid = ecl_nth_value(the_env, 2); - /* A SIGCHLD interrupt may abort waitpid. If this - * is the case, the signal handler may have consumed - * the process status and we have to start over again */ - if (Null(pid)) { - if (!Null(wait)) goto AGAIN; - status = external_process_status(process); - code = external_process_code(process); - } else { - ecl_structure_set(process, @'ext::external-process', 0, ECL_NIL); - ecl_structure_set(process, @'ext::external-process', 4, status); - ecl_structure_set(process, @'ext::external-process', 5, code); - } - } - @(return status code); - } @) - #if defined(ECL_MS_WINDOWS_HOST) HANDLE ecl_stream_to_HANDLE(cl_object s, bool output) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 15d7533c..0b1f55c5 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -29,6 +29,24 @@ (ext:external-process-wait external-process nil) (values status (external-process-%code external-process))))) +;;; --------------------------------------------------------------------------- +;;; ecl-waitpid -> (values status code pid) +;;; --------------------------------------------------------------------------- +;;; nochg :: (values nil nil nil) +;;; error :: (values (member :abort :error) nil nil) +;;; chang :: (values (member :exited :signalled :stopped :running) code pid) +;;; --------------------------------------------------------------------------- +(defun external-process-wait (process &optional wait) + (let ((pid (external-process-pid process))) + (when pid + (multiple-value-bind (status code pid) (ecl-waitpid pid wait) + (unless (and wait (null status) (null code) (null pid)) + (setf (external-process-pid process) nil + (external-process-%status process) status + (external-process-code process) code))))) + (values (external-process-%status process) + (external-process-code process) code)) + ;;; ;;; Backwards compatible SI:SYSTEM call. We avoid ANSI C system() ;;; because we are consuming the process wait status using a SIGCHLD @@ -167,14 +185,21 @@ ;;; low level interface to descriptors (defun make-input-stream-from-fd (name fd external-format) - (ffi:c-inline (name fd external-format) (:string :int :object) :object - "ecl_make_stream_from_fd(#0, #1, ecl_smm_input, 8, ECL_STREAM_DEFAULT_FORMAT, #2)" - :one-liner t)) + (ffi:c-inline + (name fd external-format) (:string :int :object) :object + "ecl_make_stream_from_fd(#0, #1, ecl_smm_input, 8, ECL_STREAM_DEFAULT_FORMAT, #2)" + :one-liner t)) (defun make-output-stream-from-fd (name fd external-format) - (ffi:c-inline (name fd external-format) (:string :int :object) :object - "ecl_make_stream_from_fd(#0, #1, ecl_smm_output, 8, ECL_STREAM_DEFAULT_FORMAT, #2)" - :one-liner t)) + (ffi:c-inline + (name fd external-format) (:string :int :object) :object + "ecl_make_stream_from_fd(#0, #1, ecl_smm_output, 8, ECL_STREAM_DEFAULT_FORMAT, #2)" + :one-liner t)) + +(defun ecl-waitpid (pid wait) + (ffi:c-inline + (pid wait) (:fixnum :bool) (values :object :object :object) + "si_waitpid(#0, #1)" :one-liner t)) (defun null-stream () (ffi:c-inline () () :object "cl_core.null_stream" :one-liner t :side-effects nil)) From 11d5773d260eb1d2366802c37c1f6dc1721cdaf6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 19 Feb 2017 08:28:01 +0100 Subject: [PATCH 12/77] ecl-waitpid wrapper: si_waitpid takes objects --- src/lsp/process.lsp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 0b1f55c5..8e306af0 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -198,7 +198,7 @@ (defun ecl-waitpid (pid wait) (ffi:c-inline - (pid wait) (:fixnum :bool) (values :object :object :object) + (pid wait) (:object :object) (values :object :object :object) "si_waitpid(#0, #1)" :one-liner t)) (defun null-stream () From ef65a8b1ac6e85a91eaa618a26b978eba17f1364 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 19 Feb 2017 08:29:16 +0100 Subject: [PATCH 13/77] external-process-wait: accessor is *-%code --- src/lsp/process.lsp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 8e306af0..545f10ac 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -43,9 +43,9 @@ (unless (and wait (null status) (null code) (null pid)) (setf (external-process-pid process) nil (external-process-%status process) status - (external-process-code process) code))))) + (external-process-%code process) code))))) (values (external-process-%status process) - (external-process-code process) code)) + (external-process-%code process))) ;;; ;;; Backwards compatible SI:SYSTEM call. We avoid ANSI C system() From 91c45d09cda7ba4726c9eef7768be1fa8562ce12 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 19 Feb 2017 11:10:30 +0100 Subject: [PATCH 14/77] dpp: always set zero-th variable with values --- src/c/dpp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/c/dpp.c b/src/c/dpp.c index ec3bd783..678fdf2e 100755 --- a/src/c/dpp.c +++ b/src/c/dpp.c @@ -813,7 +813,7 @@ put_return(void) } put_tabs(t); fprintf(out, "the_env->nvalues = %d;\n", nres); - for (i = nres-1; i > 0; i--) { + for (i = nres-1; i >= 0; i--) { put_tabs(t); fprintf(out, "the_env->values[%d] = __value%d;\n", i, i); } From bcacc6bdb0db52ce5f0d7dbd1cfabb23a6411043 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 19 Feb 2017 11:12:22 +0100 Subject: [PATCH 15/77] si_wait: move to external, its called from the outside --- src/c/symbols_list.h | 1 + src/c/symbols_list2.h | 1 + src/c/unixsys.d | 8 +------- src/cmp/proclamations.lsp | 4 ++++ src/h/external.h | 10 +++++++++- src/h/internal.h | 8 -------- src/lsp/process.lsp | 11 +++-------- 7 files changed, 19 insertions(+), 24 deletions(-) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index ccf97408..904ae9f6 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1233,6 +1233,7 @@ cl_symbols[] = { {SYS_ "REPLACE-ARRAY", SI_ORDINARY, si_replace_array, 2, OBJNULL}, {SYS_ "ROW-MAJOR-ASET", SI_ORDINARY, si_row_major_aset, 3, OBJNULL}, {EXT_ "RUN-PROGRAM", EXT_ORDINARY, ECL_NAME(si_run_program), -1, OBJNULL}, +{SYS_ "WAITPID", SI_ORDINARY, si_waitpid, 2, OBJNULL}, {SYS_ "RUN-PROGRAM-INNER", SI_ORDINARY, si_run_program_inner, 3, OBJNULL}, {SYS_ "SPAWN-SUBPROCESS", SI_ORDINARY, si_spawn_subprocess, 6, OBJNULL}, {EXT_ "TERMINATE-PROCESS", EXT_ORDINARY, si_terminate_process, -1, OBJNULL}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 3e3e5e24..47850587 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1233,6 +1233,7 @@ cl_symbols[] = { {SYS_ "REPLACE-ARRAY","si_replace_array"}, {SYS_ "ROW-MAJOR-ASET","si_row_major_aset"}, {EXT_ "RUN-PROGRAM","ECL_NAME(si_run_program)"}, +{SYS_ "WAITPID","si_waitpid"}, {SYS_ "RUN-PROGRAM-INNER","si_run_program_inner"}, {SYS_ "SPAWN-SUBPROCESS","si_spawn_subprocess"}, {EXT_ "TERMINATE-PROCESS","si_terminate_process"}, diff --git a/src/c/unixsys.d b/src/c/unixsys.d index 7d89d8a3..4896f97c 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -145,12 +145,6 @@ from_list_to_execve_argument(cl_object l, char ***environp) return buffer; } -static cl_object -external_process_pid(cl_object p) -{ - return ecl_structure_ref(p, @'ext::external-process', 0); -} - cl_object si_waitpid(cl_object pid, cl_object wait) { @@ -220,7 +214,7 @@ si_waitpid(cl_object pid, cl_object wait) cl_env_ptr env = ecl_process_env(); bool error_encountered = FALSE; - cl_object pid = external_process_pid(process); + cl_object pid = ecl_structure_ref(process, @'ext::external-process', 0); if (!Null(pid)) { int ret; #if defined(ECL_MS_WINDOWS_HOST) diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp index 42813d01..aecf456d 100644 --- a/src/cmp/proclamations.lsp +++ b/src/cmp/proclamations.lsp @@ -1329,6 +1329,10 @@ (values (or null two-way-stream) (or null integer) ext:external-process)) +(proclamation si:waitpid (fixnum gen-bool) (values + (or null keyword) + (or null fixnum) + (or null fixnum))) (proclamation si:run-program-inner (string (or list string) list) (values two-way-stream integer)) (proclamation si:spawn-subprocess (string (or list string) list t t t) diff --git a/src/h/external.h b/src/h/external.h index c5a988d7..ac816027 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -1884,9 +1884,17 @@ extern ECL_API void ecl_check_pending_interrupts(cl_env_ptr env); extern ECL_API cl_object si_system(cl_object cmd); extern ECL_API cl_object si_make_pipe(); extern ECL_API cl_object si_run_program _ECL_ARGS((cl_narg narg, cl_object command, cl_object args, ...)); -extern ECL_API cl_object si_external_process_wait _ECL_ARGS((cl_narg narg, cl_object h, ...)); extern ECL_API cl_object si_close_windows_handle(cl_object h); extern ECL_API cl_object si_terminate_process _ECL_ARGS((cl_narg narg, cl_object process, ...)); +extern ECL_API cl_object si_waitpid(cl_object pid, cl_object wait); + +extern ECL_API cl_object si_run_program_inner +(cl_object command, cl_object argv, cl_object environ); + +extern ECL_API cl_object si_spawn_subprocess +(cl_object command, cl_object argv, cl_object environ, + cl_object input, cl_object output, cl_object error); + /* unicode -- no particular file, but we group these changes here */ diff --git a/src/h/internal.h b/src/h/internal.h index 3c4d2c75..f7209c22 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -526,14 +526,6 @@ extern cl_object mp_get_rwlock_write_wait(cl_object lock); extern void ecl_interrupt_process(cl_object process, cl_object function); /* unixsys.d */ -extern cl_object si_waitpid(cl_object pid, cl_object wait); - -extern cl_object si_run_program_inner -(cl_object command, cl_object argv, cl_object environ); - -extern cl_object si_spawn_subprocess -(cl_object command, cl_object argv, cl_object environ, - cl_object input, cl_object output, cl_object error); /* * Fake several ISO C99 mathematical functions if not available diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 545f10ac..fdfe900b 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -30,7 +30,7 @@ (values status (external-process-%code external-process))))) ;;; --------------------------------------------------------------------------- -;;; ecl-waitpid -> (values status code pid) +;;; si:waitpid -> (values status code pid) ;;; --------------------------------------------------------------------------- ;;; nochg :: (values nil nil nil) ;;; error :: (values (member :abort :error) nil nil) @@ -39,9 +39,9 @@ (defun external-process-wait (process &optional wait) (let ((pid (external-process-pid process))) (when pid - (multiple-value-bind (status code pid) (ecl-waitpid pid wait) + (multiple-value-bind (status code pid) (si:waitpid pid wait) (unless (and wait (null status) (null code) (null pid)) - (setf (external-process-pid process) nil + (setf (external-process-pid process) pid (external-process-%status process) status (external-process-%code process) code))))) (values (external-process-%status process) @@ -196,11 +196,6 @@ "ecl_make_stream_from_fd(#0, #1, ecl_smm_output, 8, ECL_STREAM_DEFAULT_FORMAT, #2)" :one-liner t)) -(defun ecl-waitpid (pid wait) - (ffi:c-inline - (pid wait) (:object :object) (values :object :object :object) - "si_waitpid(#0, #1)" :one-liner t)) - (defun null-stream () (ffi:c-inline () () :object "cl_core.null_stream" :one-liner t :side-effects nil)) From 40f47f04aa7abb9470df1adab880562eb7cbe806 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 19 Feb 2017 12:51:23 +0100 Subject: [PATCH 16/77] cosmetic fixes --- src/c/unixsys.d | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/c/unixsys.d b/src/c/unixsys.d index 4896f97c..094463d3 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -432,7 +432,6 @@ cl_object si_spawn_subprocess(cl_object command, cl_object argv, cl_object environ, cl_object input, cl_object output, cl_object error) { - cl_env_ptr the_env = ecl_process_env(); int parent_write = 0, parent_read = 0, parent_error = 0; int child_pid; cl_object pid; @@ -553,7 +552,7 @@ si_spawn_subprocess(cl_object command, cl_object argv, cl_object environ, } if (!Null(environ)) { char **pstrings; - cl_object buffer = from_list_to_execve_argument(environ, &pstrings); + from_list_to_execve_argument(environ, &pstrings); execve((char*)command->base_string.self, (char **)argv_ptr, pstrings); } else { execvp((char*)command->base_string.self, (char **)argv_ptr); From 786039ca97a493a735563ec1b5cac225fd5fe78f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 19 Feb 2017 12:51:35 +0100 Subject: [PATCH 17/77] cosmetic fixes(2) --- src/c/unixsys.d | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/c/unixsys.d b/src/c/unixsys.d index 094463d3..394d694c 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -391,7 +391,7 @@ create_descriptor(cl_object stream, cl_object direction, cl_object si_run_program_inner(cl_object command, cl_object argv, cl_object environ) { cl_env_ptr the_env = ecl_process_env(); - int parent_write = 0, parent_read = 0, parent_error = 0; + int parent_write = 0, parent_read = 0; cl_object pid, stream_write, stream_read, exit_status; command = si_copy_to_simple_base_string(command); From 47f1525ebdba36c0fdd9c60e282a18d96f8d74dd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 19 Feb 2017 13:00:58 +0100 Subject: [PATCH 18/77] external-process: add disabled terminate-process --- src/lsp/process.lsp | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index fdfe900b..7dee9afc 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -29,6 +29,8 @@ (ext:external-process-wait external-process nil) (values status (external-process-%code external-process))))) +;;; XXX: we do not handle zombies yet + ;;; --------------------------------------------------------------------------- ;;; si:waitpid -> (values status code pid) ;;; --------------------------------------------------------------------------- @@ -47,6 +49,19 @@ (values (external-process-%status process) (external-process-%code process))) +#+ (or) +(defun terminate-process (process &optional force) + (let ((pid (external-process-pid process))) + #+windows + (ffi:c-inline + (process pid) (:object :object) :void + "HANDLE *ph = (HANDLE*)ecl_foreign_data_pointer_safe(#1); + ret = TerminateProcess(*ph, -1); + if (ret == 0) FEerror(\"Cannot terminate the process ~A\", 1, #2);") + #-windows + (unless (zerop (si:signal pid (if force +sigkill+ +sigterm+))) + (error "Cannot terminate the process ~A" process)))) + ;;; ;;; Backwards compatible SI:SYSTEM call. We avoid ANSI C system() ;;; because we are consuming the process wait status using a SIGCHLD From 65c70996fc87eb1de27fe5619cc7b5695e8a9c98 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 19 Feb 2017 13:01:24 +0100 Subject: [PATCH 19/77] cosmetic --- src/lsp/process.lsp | 14 +++----------- 1 file changed, 3 insertions(+), 11 deletions(-) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 7dee9afc..86df1141 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -1,17 +1,9 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: SYSTEM -*- -;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: - -;;;; -;;;; PROCESS.LSP -- External processes +;;;; process.lsp -- External processes. ;;;; Copyright (c) 2003, Juan Jose Garcia-Ripoll +;;;; Copyright (c) 2017, Daniel Kochmański ;;;; -;;;; This program is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Library General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 2 of the License, or (at your option) any later version. -;;;; -;;;; See file '../Copyright' for full details. +;;;; See file 'LICENSE' for the copyright details. (in-package "EXT") From 500a7b7d6bad8c4629fe0c65b1d788a7ca70c6f2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 19 Feb 2017 13:21:58 +0100 Subject: [PATCH 20/77] external-process: move terminate-process outside the core --- src/c/symbols_list.h | 5 ++++- src/c/symbols_list2.h | 5 ++++- src/c/unixsys.d | 25 ------------------------- src/cmp/sysfun.lsp | 1 + src/lsp/process.lsp | 11 ++++++----- 5 files changed, 15 insertions(+), 32 deletions(-) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 904ae9f6..d3d54101 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1232,11 +1232,14 @@ cl_symbols[] = { {SYS_ "REM-SYSPROP", SI_ORDINARY, si_rem_sysprop, 2, OBJNULL}, {SYS_ "REPLACE-ARRAY", SI_ORDINARY, si_replace_array, 2, OBJNULL}, {SYS_ "ROW-MAJOR-ASET", SI_ORDINARY, si_row_major_aset, 3, OBJNULL}, +/* process.lsp */ {EXT_ "RUN-PROGRAM", EXT_ORDINARY, ECL_NAME(si_run_program), -1, OBJNULL}, +{EXT_ "TERMINATE-PROCESS", EXT_ORDINARY, ECL_NAME(si_terminate_process), -1, OBJNULL}, +/* unixsys.d */ {SYS_ "WAITPID", SI_ORDINARY, si_waitpid, 2, OBJNULL}, {SYS_ "RUN-PROGRAM-INNER", SI_ORDINARY, si_run_program_inner, 3, OBJNULL}, {SYS_ "SPAWN-SUBPROCESS", SI_ORDINARY, si_spawn_subprocess, 6, OBJNULL}, -{EXT_ "TERMINATE-PROCESS", EXT_ORDINARY, si_terminate_process, -1, OBJNULL}, +/* ~ */ {EXT_ "SAFE-EVAL", EXT_ORDINARY, ECL_NAME(si_safe_eval), -1, OBJNULL}, {SYS_ "SCH-FRS-BASE", SI_ORDINARY, si_sch_frs_base, 2, OBJNULL}, {SYS_ "SCHAR-SET", SI_ORDINARY, si_char_set, 3, OBJNULL}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 47850587..49815739 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1232,11 +1232,14 @@ cl_symbols[] = { {SYS_ "REM-SYSPROP","si_rem_sysprop"}, {SYS_ "REPLACE-ARRAY","si_replace_array"}, {SYS_ "ROW-MAJOR-ASET","si_row_major_aset"}, +/* process.lsp */ {EXT_ "RUN-PROGRAM","ECL_NAME(si_run_program)"}, +{EXT_ "TERMINATE-PROCESS","ECL_NAME(si_terminate_process)"}, +/* unixsys.d */ {SYS_ "WAITPID","si_waitpid"}, {SYS_ "RUN-PROGRAM-INNER","si_run_program_inner"}, {SYS_ "SPAWN-SUBPROCESS","si_spawn_subprocess"}, -{EXT_ "TERMINATE-PROCESS","si_terminate_process"}, +/* ~ */ {EXT_ "SAFE-EVAL","ECL_NAME(si_safe_eval)"}, {SYS_ "SCH-FRS-BASE","si_sch_frs_base"}, {SYS_ "SCHAR-SET","si_char_set"}, diff --git a/src/c/unixsys.d b/src/c/unixsys.d index 394d694c..35cf02a3 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -208,31 +208,6 @@ si_waitpid(cl_object pid, cl_object wait) @(return status code pid); } -@(defun ext::terminate-process (process &optional (force ECL_NIL)) -@ -{ - cl_env_ptr env = ecl_process_env(); - bool error_encountered = FALSE; - - cl_object pid = ecl_structure_ref(process, @'ext::external-process', 0); - if (!Null(pid)) { - int ret; -#if defined(ECL_MS_WINDOWS_HOST) - HANDLE *ph = (HANDLE*)ecl_foreign_data_pointer_safe(pid); - ret = TerminateProcess(*ph, -1); - error_encountered = (ret == 0); -#else - ret = kill(ecl_fixnum(pid), Null(force) ? SIGTERM : SIGKILL); - error_encountered = (ret != 0); -#endif - } - - if (error_encountered) - FEerror("Cannot terminate the process ~A", 1, process); - return ECL_NIL; -} -@) - #if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin) cl_object si_close_windows_handle(cl_object h) diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index 00c8f660..b75c02b3 100644 --- a/src/cmp/sysfun.lsp +++ b/src/cmp/sysfun.lsp @@ -939,6 +939,7 @@ si::do-defsetf si::do-define-setf-method ;; process.lsp ext:run-program + ext:terminate-process ;; pprint.lsp pprint-fill copy-pprint-dispatch pprint-dispatch pprint-linear pprint-newline pprint-tab pprint-tabular diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 86df1141..fc9d3ac4 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -41,18 +41,19 @@ (values (external-process-%status process) (external-process-%code process))) -#+ (or) (defun terminate-process (process &optional force) (let ((pid (external-process-pid process))) #+windows (ffi:c-inline (process pid) (:object :object) :void "HANDLE *ph = (HANDLE*)ecl_foreign_data_pointer_safe(#1); - ret = TerminateProcess(*ph, -1); - if (ret == 0) FEerror(\"Cannot terminate the process ~A\", 1, #2);") + int ret = TerminateProcess(*ph, -1); + if (ret == 0) FEerror(\"Cannot terminate the process ~A\", 1, #0);") #-windows - (unless (zerop (si:signal pid (if force +sigkill+ +sigterm+))) - (error "Cannot terminate the process ~A" process)))) + (ffi:c-inline + (process pid (if force +sigkill+ +sigterm+)) (:object :object :object) :void + "int ret = kill(ecl_fixnum(#1), ecl_fixnum(#2)); + if (ret != 0) FEerror(\"Cannot terminate the process ~A\", 1, #0);"))) ;;; ;;; Backwards compatible SI:SYSTEM call. We avoid ANSI C system() From f0ad7b9550bb33a844bcd7a5a104a6e118657262 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 19 Feb 2017 13:47:58 +0100 Subject: [PATCH 21/77] killpid: add internal interface to kill --- src/c/symbols_list.h | 21 ++++++++++++--------- src/c/symbols_list2.h | 21 ++++++++++++--------- src/c/unixsys.d | 8 ++++++++ src/cmp/proclamations.lsp | 1 + src/h/external.h | 1 + 5 files changed, 34 insertions(+), 18 deletions(-) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index d3d54101..73447a05 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1232,14 +1232,6 @@ cl_symbols[] = { {SYS_ "REM-SYSPROP", SI_ORDINARY, si_rem_sysprop, 2, OBJNULL}, {SYS_ "REPLACE-ARRAY", SI_ORDINARY, si_replace_array, 2, OBJNULL}, {SYS_ "ROW-MAJOR-ASET", SI_ORDINARY, si_row_major_aset, 3, OBJNULL}, -/* process.lsp */ -{EXT_ "RUN-PROGRAM", EXT_ORDINARY, ECL_NAME(si_run_program), -1, OBJNULL}, -{EXT_ "TERMINATE-PROCESS", EXT_ORDINARY, ECL_NAME(si_terminate_process), -1, OBJNULL}, -/* unixsys.d */ -{SYS_ "WAITPID", SI_ORDINARY, si_waitpid, 2, OBJNULL}, -{SYS_ "RUN-PROGRAM-INNER", SI_ORDINARY, si_run_program_inner, 3, OBJNULL}, -{SYS_ "SPAWN-SUBPROCESS", SI_ORDINARY, si_spawn_subprocess, 6, OBJNULL}, -/* ~ */ {EXT_ "SAFE-EVAL", EXT_ORDINARY, ECL_NAME(si_safe_eval), -1, OBJNULL}, {SYS_ "SCH-FRS-BASE", SI_ORDINARY, si_sch_frs_base, 2, OBJNULL}, {SYS_ "SCHAR-SET", SI_ORDINARY, si_char_set, 3, OBJNULL}, @@ -1988,6 +1980,8 @@ cl_symbols[] = { {EXT_ "EXTERNAL-PROCESS-ERROR-STREAM", EXT_ORDINARY, NULL, -1, OBJNULL}, {EXT_ "EXTERNAL-PROCESS-STATUS", EXT_ORDINARY, NULL, -1, OBJNULL}, {EXT_ "EXTERNAL-PROCESS-WAIT", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "TERMINATE-PROCESS", EXT_ORDINARY, ECL_NAME(si_terminate_process), -1, OBJNULL}, +{EXT_ "RUN-PROGRAM", EXT_ORDINARY, ECL_NAME(si_run_program), -1, OBJNULL}, {KEY_ "RUNNING", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "EXITED", KEYWORD, NULL, -1, OBJNULL}, @@ -1995,12 +1989,21 @@ cl_symbols[] = { {KEY_ "STOPPED", KEYWORD, NULL, -1, OBJNULL}, /* ~ external-process extension */ - +/* unixsys.d */ +{SYS_ "WAITPID", SI_ORDINARY, si_waitpid, 2, OBJNULL}, +#if !defined(ECL_MS_WINDOWS_HOST) +{SYS_ "KILLPID", SI_ORDINARY, si_killpid, 2, OBJNULL}, +#else +{SYS_ "KILLPID", SI_ORDINARY, NULL, 2, OBJNULL}, +#endif +{SYS_ "RUN-PROGRAM-INNER", SI_ORDINARY, si_run_program_inner, 3, OBJNULL}, +{SYS_ "SPAWN-SUBPROCESS", SI_ORDINARY, si_spawn_subprocess, 6, OBJNULL}, #if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin) {SYS_ "CLOSE-WINDOWS-HANDLE", SI_ORDINARY, si_close_windows_handle, 1, OBJNULL}, #else {SYS_ "CLOSE-WINDOWS-HANDLE", SI_ORDINARY, NULL, -1, OBJNULL}, #endif +/* ~ */ {EXT_ "*INVOKE-DEBUGGER-HOOK*", EXT_SPECIAL, NULL, -1, ECL_NIL}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 49815739..a737ccaf 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1232,14 +1232,6 @@ cl_symbols[] = { {SYS_ "REM-SYSPROP","si_rem_sysprop"}, {SYS_ "REPLACE-ARRAY","si_replace_array"}, {SYS_ "ROW-MAJOR-ASET","si_row_major_aset"}, -/* process.lsp */ -{EXT_ "RUN-PROGRAM","ECL_NAME(si_run_program)"}, -{EXT_ "TERMINATE-PROCESS","ECL_NAME(si_terminate_process)"}, -/* unixsys.d */ -{SYS_ "WAITPID","si_waitpid"}, -{SYS_ "RUN-PROGRAM-INNER","si_run_program_inner"}, -{SYS_ "SPAWN-SUBPROCESS","si_spawn_subprocess"}, -/* ~ */ {EXT_ "SAFE-EVAL","ECL_NAME(si_safe_eval)"}, {SYS_ "SCH-FRS-BASE","si_sch_frs_base"}, {SYS_ "SCHAR-SET","si_char_set"}, @@ -1988,6 +1980,8 @@ cl_symbols[] = { {EXT_ "EXTERNAL-PROCESS-ERROR-STREAM",NULL}, {EXT_ "EXTERNAL-PROCESS-STATUS",NULL}, {EXT_ "EXTERNAL-PROCESS-WAIT",NULL}, +{EXT_ "TERMINATE-PROCESS","ECL_NAME(si_terminate_process)"}, +{EXT_ "RUN-PROGRAM","ECL_NAME(si_run_program)"}, {KEY_ "RUNNING",NULL}, {KEY_ "EXITED",NULL}, @@ -1995,12 +1989,21 @@ cl_symbols[] = { {KEY_ "STOPPED",NULL}, /* ~ external-process extension */ - +/* unixsys.d */ +{SYS_ "WAITPID","si_waitpid"}, +#if !defined(ECL_MS_WINDOWS_HOST) +{SYS_ "KILLPID","si_killpid"}, +#else +{SYS_ "KILLPID",NULL}, +#endif +{SYS_ "RUN-PROGRAM-INNER","si_run_program_inner"}, +{SYS_ "SPAWN-SUBPROCESS","si_spawn_subprocess"}, #if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin) {SYS_ "CLOSE-WINDOWS-HANDLE","si_close_windows_handle"}, #else {SYS_ "CLOSE-WINDOWS-HANDLE",NULL}, #endif +/* ~ */ {EXT_ "*INVOKE-DEBUGGER-HOOK*",NULL}, diff --git a/src/c/unixsys.d b/src/c/unixsys.d index 35cf02a3..ca35bf20 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -208,6 +208,14 @@ si_waitpid(cl_object pid, cl_object wait) @(return status code pid); } +#if !defined(ECL_MS_WINDOWS_HOST) +cl_object +si_killpid(cl_object pid, cl_object signal) { + int ret = kill(ecl_fixnum(pid), ecl_fixnum(signal)); + return ecl_make_fixnum(ret); +} +#endif + #if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin) cl_object si_close_windows_handle(cl_object h) diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp index aecf456d..1e2d5709 100644 --- a/src/cmp/proclamations.lsp +++ b/src/cmp/proclamations.lsp @@ -1333,6 +1333,7 @@ (or null keyword) (or null fixnum) (or null fixnum))) +(proclamation si:killpid (fixnum fixnum) fixnum) (proclamation si:run-program-inner (string (or list string) list) (values two-way-stream integer)) (proclamation si:spawn-subprocess (string (or list string) list t t t) diff --git a/src/h/external.h b/src/h/external.h index ac816027..261b8dd6 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -1887,6 +1887,7 @@ extern ECL_API cl_object si_run_program _ECL_ARGS((cl_narg narg, cl_object comma extern ECL_API cl_object si_close_windows_handle(cl_object h); extern ECL_API cl_object si_terminate_process _ECL_ARGS((cl_narg narg, cl_object process, ...)); extern ECL_API cl_object si_waitpid(cl_object pid, cl_object wait); +extern ECL_API cl_object si_killpid(cl_object pid, cl_object signal); extern ECL_API cl_object si_run_program_inner (cl_object command, cl_object argv, cl_object environ); From 4554336fae68cea7235209f529524141d4447749 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 19 Feb 2017 14:09:56 +0100 Subject: [PATCH 22/77] cosmetic --- src/c/unixint.d | 2 +- src/lsp/process.lsp | 6 ++---- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/src/c/unixint.d b/src/c/unixint.d index d43cf24e..8ffc19c0 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -1136,7 +1136,7 @@ BOOL WINAPI W32_console_ctrl_handler(DWORD type) } case CTRL_CLOSE_EVENT: case CTRL_LOGOFF_EVENT: - case CTRL_SHUTDOWN_EVENT: { + case CTRL_SHUTDOWN_EVENT: { cl_object function = ECL_SYM_FUN(@'ext::quit'); if (function) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index fc9d3ac4..c48ea399 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -50,10 +50,8 @@ int ret = TerminateProcess(*ph, -1); if (ret == 0) FEerror(\"Cannot terminate the process ~A\", 1, #0);") #-windows - (ffi:c-inline - (process pid (if force +sigkill+ +sigterm+)) (:object :object :object) :void - "int ret = kill(ecl_fixnum(#1), ecl_fixnum(#2)); - if (ret != 0) FEerror(\"Cannot terminate the process ~A\", 1, #0);"))) + (unless (zerop (si:killpid pid (if force +sigkill+ +sigterm+))) + (error "Cannot terminate the process ~A" process)))) ;;; ;;; Backwards compatible SI:SYSTEM call. We avoid ANSI C system() From 270131004613b599c74ef65b160aeb4b5bb6d33e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 19 Feb 2017 14:41:25 +0100 Subject: [PATCH 23/77] external-process-wait: handle stopped process we have a few possibilities here. Handle them correctly. --- src/lsp/process.lsp | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index c48ea399..762e4862 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -34,10 +34,15 @@ (let ((pid (external-process-pid process))) (when pid (multiple-value-bind (status code pid) (si:waitpid pid wait) - (unless (and wait (null status) (null code) (null pid)) - (setf (external-process-pid process) pid - (external-process-%status process) status - (external-process-%code process) code))))) + (case status + ((:exitted :signalled :abort :error) + (setf (external-process-pid process) nil + (external-process-%status process) status + (external-process-%code process) code)) + ((:stopped :running) + (setf (external-process-pid process) pid + (external-process-%status process) status + (external-process-%code process) code)))))) (values (external-process-%status process) (external-process-%code process))) From a92c50fe4470c861625fba091a9eacbf43e49317 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 19 Feb 2017 17:55:27 +0100 Subject: [PATCH 24/77] external-process: add sigchld handler It's not installed by default yet due to a kludge with our interrupt interface. --- src/c/unixint.d | 11 +++---- src/lsp/process.lsp | 70 ++++++++++++++++++++++++++++++++++----------- 2 files changed, 57 insertions(+), 24 deletions(-) diff --git a/src/c/unixint.d b/src/c/unixint.d index 8ffc19c0..a35db62a 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -161,7 +161,7 @@ static struct { { SIGCONT, "+SIGCONT+", ECL_NIL}, #endif #ifdef SIGCHLD - { SIGCHLD, "+SIGCHLD+", ECL_NIL/* @'si::wait-for-all-processes' */}, + { SIGCHLD, "+SIGCHLD+", ECL_NIL}, #endif #ifdef SIGTTIN { SIGTTIN, "+SIGTTIN+", ECL_NIL}, @@ -852,12 +852,9 @@ do_catch_signal(int code, cl_object action, cl_object process) mysignal(SIGILL, evil_signal_handler); } #endif -#if defined(SIGCHLD) && defined(ECL_THREADS) - else if (code == SIGCHLD && - ecl_option_values[ECL_OPT_SIGNAL_HANDLING_THREAD]) - { - /* Do nothing. This is taken care of in - * the asynchronous signal handler. */ +#ifdef SIGCHLD + else if (code == SIGCHLD) { + mysignal(SIGCHLD, evil_signal_handler); } #endif else { diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 762e4862..e71e5595 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -7,11 +7,42 @@ (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 () + (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)))))) + +;; (ext:set-signal-handler ext:+sigchld+ #'sigchld-handler) + + + (defstruct (external-process (:constructor make-external-process ())) pid input output error-stream + status-hook (%status :running) (%code nil)) @@ -21,8 +52,6 @@ (ext:external-process-wait external-process nil) (values status (external-process-%code external-process))))) -;;; XXX: we do not handle zombies yet - ;;; --------------------------------------------------------------------------- ;;; si:waitpid -> (values status code pid) ;;; --------------------------------------------------------------------------- @@ -35,28 +64,30 @@ (when pid (multiple-value-bind (status code pid) (si:waitpid pid wait) (case status - ((:exitted :signalled :abort :error) - (setf (external-process-pid process) nil - (external-process-%status process) status - (external-process-%code process) code)) + ((:exited :signalled :abort :error) + (with-active-processes-lock + (setf *active-processes* (delete process *active-processes*) + (external-process-pid process) nil + (external-process-%status process) status + (external-process-%code process) code))) ((:stopped :running) - (setf (external-process-pid process) pid - (external-process-%status process) status + (setf (external-process-%status process) status (external-process-%code process) code)))))) (values (external-process-%status process) (external-process-%code process))) (defun terminate-process (process &optional force) - (let ((pid (external-process-pid process))) - #+windows - (ffi:c-inline - (process pid) (:object :object) :void - "HANDLE *ph = (HANDLE*)ecl_foreign_data_pointer_safe(#1); + (with-active-processes-lock + (let ((pid (external-process-pid process))) + #+windows + (ffi:c-inline + (process pid) (:object :object) :void + "HANDLE *ph = (HANDLE*)ecl_foreign_data_pointer_safe(#1); int ret = TerminateProcess(*ph, -1); if (ret == 0) FEerror(\"Cannot terminate the process ~A\", 1, #0);") - #-windows - (unless (zerop (si:killpid pid (if force +sigkill+ +sigterm+))) - (error "Cannot terminate the process ~A" process)))) + #-windows + (unless (zerop (si:killpid pid (if force +sigkill+ +sigterm+))) + (error "Cannot terminate the process ~A" process))))) ;;; ;;; Backwards compatible SI:SYSTEM call. We avoid ANSI C system() @@ -90,6 +121,7 @@ (if-input-does-not-exist nil) (if-output-exists :error) (if-error-exists :error) + status-hook (external-format :default) #+windows (escape-arguments t)) @@ -135,12 +167,15 @@ (let ((progname (si:copy-to-simple-base-string command)) (args (prepare-args (cons command argv))) (process (make-external-process))) + (with-active-processes-lock (push process *active-processes*)) (multiple-value-bind (pid parent-write parent-read parent-error) (si:spawn-subprocess progname args environ input output error) (unless pid (when parent-write (ff-close parent-write)) (when parent-read (ff-close parent-read)) (when parent-error (ff-close parent-error)) + (with-active-processes-lock + (setf *active-processes* (delete process *active-processes*))) (error "Could not spawn subprocess to run ~S." progname)) (let ((stream-write @@ -155,7 +190,8 @@ (setf (external-process-pid process) pid (external-process-input process) (or stream-write (null-stream)) (external-process-output process) (or stream-read (null-stream)) - (external-process-error-stream process) (or stream-error (null-stream))) + (external-process-error-stream process) (or stream-error (null-stream)) + (external-process-status-hook process) status-hook) (values (make-two-way-stream (external-process-output process) (external-process-input process)) From d6b0354772f6258350fabc6eaa63a24e84cdb99a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 19 Feb 2017 18:25:03 +0100 Subject: [PATCH 25/77] run-program: add hack for installing signal-handler --- src/c/symbols_list.h | 3 ++- src/c/symbols_list2.h | 3 ++- src/lsp/process.lsp | 11 +++++++++-- 3 files changed, 13 insertions(+), 4 deletions(-) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 73447a05..5bcb1f93 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1972,6 +1972,8 @@ cl_symbols[] = { {KEY_ "ENVIRON", KEYWORD, NULL, -1, OBJNULL}, /* external-process extension */ +{EXT_ "RUN-PROGRAM", EXT_ORDINARY, ECL_NAME(si_run_program), -1, OBJNULL}, + {EXT_ "MAKE-EXTERNAL-PROCESS", EXT_ORDINARY, NULL, -1, OBJNULL}, {EXT_ "EXTERNAL-PROCESS", EXT_ORDINARY, NULL, -1, OBJNULL}, {EXT_ "EXTERNAL-PROCESS-PID", EXT_ORDINARY, NULL, -1, OBJNULL}, @@ -1981,7 +1983,6 @@ cl_symbols[] = { {EXT_ "EXTERNAL-PROCESS-STATUS", EXT_ORDINARY, NULL, -1, OBJNULL}, {EXT_ "EXTERNAL-PROCESS-WAIT", EXT_ORDINARY, NULL, -1, OBJNULL}, {EXT_ "TERMINATE-PROCESS", EXT_ORDINARY, ECL_NAME(si_terminate_process), -1, OBJNULL}, -{EXT_ "RUN-PROGRAM", EXT_ORDINARY, ECL_NAME(si_run_program), -1, OBJNULL}, {KEY_ "RUNNING", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "EXITED", KEYWORD, NULL, -1, OBJNULL}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index a737ccaf..671ce0c9 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1972,6 +1972,8 @@ cl_symbols[] = { {KEY_ "ENVIRON",NULL}, /* external-process extension */ +{EXT_ "RUN-PROGRAM","ECL_NAME(si_run_program)"}, + {EXT_ "MAKE-EXTERNAL-PROCESS",NULL}, {EXT_ "EXTERNAL-PROCESS",NULL}, {EXT_ "EXTERNAL-PROCESS-PID",NULL}, @@ -1981,7 +1983,6 @@ cl_symbols[] = { {EXT_ "EXTERNAL-PROCESS-STATUS",NULL}, {EXT_ "EXTERNAL-PROCESS-WAIT",NULL}, {EXT_ "TERMINATE-PROCESS","ECL_NAME(si_terminate_process)"}, -{EXT_ "RUN-PROGRAM","ECL_NAME(si_run_program)"}, {KEY_ "RUNNING",NULL}, {KEY_ "EXITED",NULL}, diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index e71e5595..126bde20 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -33,8 +33,6 @@ (let ((hook (external-process-status-hook proc))) (when hook (funcall hook proc)))))) -;; (ext:set-signal-handler ext:+sigchld+ #'sigchld-handler) - (defstruct (external-process (:constructor make-external-process ())) @@ -125,6 +123,15 @@ (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. + (unless (ext:get-signal-handler ext:+sigchld+) + (ext:set-signal-handler ext:+sigchld+ #'sigchld-handler)) + (flet ((process-stream (which default &rest args) (cond ((eql which t) default) ((or (stringp which) (pathnamep which)) From 412770daac159ffd067c891a45a1e487ea939e23 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 20 Feb 2017 11:39:02 +0100 Subject: [PATCH 26/77] spawn-subprocess: duplicate parent_error fd Handler needs to be duplicated if we want to have separate stream for error. --- src/c/unixsys.d | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/src/c/unixsys.d b/src/c/unixsys.d index ca35bf20..c354c715 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -438,12 +438,16 @@ si_spawn_subprocess(cl_object command, cl_object argv, cl_object environ, } create_descriptor(input, @':input', &child_stdin, &parent_write); create_descriptor(output, @':output', &child_stdout, &parent_read); - if (error == @':output') - /* The child inherits a duplicate of its own output - handle.*/ + if (error == @':output') { + /* The child inherits a duplicate of its own output handle. */ DuplicateHandle(current, child_stdout, current, &child_stderr, 0, TRUE, DUPLICATE_SAME_ACCESS); + /* Same for the parent_read and parent_error. */ + DuplicateHandle(current, parent_read, current, + &parent_error, 0, TRUE, + DUPLICATE_SAME_ACCESS); + } else create_descriptor(error, @':output', &child_stderr, &parent_error); @@ -498,8 +502,10 @@ si_spawn_subprocess(cl_object command, cl_object argv, cl_object environ, create_descriptor(input, @':input', &child_stdin, &parent_write); create_descriptor(output, @':output', &child_stdout, &parent_read); - if (error == @':output') + if (error == @':output') { child_stderr = child_stdout; + parent_error = dup(parent_read); + } else create_descriptor(error, @':output', &child_stderr, &parent_error); From 236e8b38d1a3d555f51749bd937854cac618455c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 20 Feb 2017 12:14:10 +0100 Subject: [PATCH 27/77] ext:terminate-process: sanitize input --- src/lsp/process.lsp | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 126bde20..d76a45f3 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -77,15 +77,16 @@ (defun terminate-process (process &optional force) (with-active-processes-lock (let ((pid (external-process-pid process))) - #+windows - (ffi:c-inline - (process pid) (:object :object) :void - "HANDLE *ph = (HANDLE*)ecl_foreign_data_pointer_safe(#1); - int ret = TerminateProcess(*ph, -1); - if (ret == 0) FEerror(\"Cannot terminate the process ~A\", 1, #0);") - #-windows - (unless (zerop (si:killpid pid (if force +sigkill+ +sigterm+))) - (error "Cannot terminate the process ~A" process))))) + (when pid + #+windows + (ffi:c-inline + (process pid) (:object :object) :void + "HANDLE *ph = (HANDLE*)ecl_foreign_data_pointer_safe(#1); + int ret = TerminateProcess(*ph, -1); + if (ret == 0) FEerror(\"Cannot terminate the process ~A\", 1, #0);") + #-windows + (unless (zerop (si:killpid pid (if force +sigkill+ +sigterm+))) + (error "Cannot terminate the process ~A" process)))))) ;;; ;;; Backwards compatible SI:SYSTEM call. We avoid ANSI C system() From 03bd29426bfc646d42d40a2badd3f7a000c3f663 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 20 Feb 2017 12:35:01 +0100 Subject: [PATCH 28/77] process-wait: fix very important typo --- src/lsp/process.lsp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index d76a45f3..eb79fedd 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -62,7 +62,7 @@ (when pid (multiple-value-bind (status code pid) (si:waitpid pid wait) (case status - ((:exited :signalled :abort :error) + ((:exited :signaled :abort :error) (with-active-processes-lock (setf *active-processes* (delete process *active-processes*) (external-process-pid process) nil From 772262f1c67d1e7377265939c09958717e9e3c43 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 20 Feb 2017 13:03:01 +0100 Subject: [PATCH 29/77] external-process-wait: be exact with case Sanity check. --- src/lsp/process.lsp | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index eb79fedd..dfb1e2c1 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -61,7 +61,7 @@ (let ((pid (external-process-pid process))) (when pid (multiple-value-bind (status code pid) (si:waitpid pid wait) - (case status + (ecase status ((:exited :signaled :abort :error) (with-active-processes-lock (setf *active-processes* (delete process *active-processes*) @@ -70,7 +70,8 @@ (external-process-%code process) code))) ((:stopped :running) (setf (external-process-%status process) status - (external-process-%code process) code)))))) + (external-process-%code process) code)) + ((nil) #| wait was nil and process didn't change |#))))) (values (external-process-%status process) (external-process-%code process))) From abf580c9e4a0f024c192724fb8d7102eec7d70b2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 20 Feb 2017 15:21:26 +0100 Subject: [PATCH 30/77] external process: handle sigstop / sigcont in process New state "resumed" added. --- src/c/symbols_list.h | 1 + src/c/symbols_list2.h | 1 + src/c/unixsys.d | 10 +++++++++- src/lsp/process.lsp | 17 +++++++++-------- 4 files changed, 20 insertions(+), 9 deletions(-) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 5bcb1f93..26cebde1 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1988,6 +1988,7 @@ cl_symbols[] = { {KEY_ "EXITED", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "SIGNALED", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "STOPPED", KEYWORD, NULL, -1, OBJNULL}, +{KEY_ "RESUMED", KEYWORD, NULL, -1, OBJNULL}, /* ~ external-process extension */ /* unixsys.d */ diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 671ce0c9..43c041a0 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1988,6 +1988,7 @@ cl_symbols[] = { {KEY_ "EXITED",NULL}, {KEY_ "SIGNALED",NULL}, {KEY_ "STOPPED",NULL}, +{KEY_ "RESUMED",NULL}, /* ~ external-process extension */ /* unixsys.d */ diff --git a/src/c/unixsys.d b/src/c/unixsys.d index c354c715..9bf76838 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -175,7 +175,12 @@ si_waitpid(cl_object pid, cl_object wait) ecl_enable_interrupts_env(the_env); #else int code_int, error; - error = waitpid(ecl_to_fix(pid), &code_int, Null(wait)? WNOHANG : 0); + + if (Null(wait)) + error = waitpid(ecl_to_fix(pid), &code_int, WNOHANG | WUNTRACED | WCONTINUED); + else + error = waitpid(ecl_to_fix(pid), &code_int, WUNTRACED | WCONTINUED); + if (error < 0) { if (errno == EINTR) { status = @':abort'; @@ -199,6 +204,9 @@ si_waitpid(cl_object pid, cl_object wait) } else if (WIFSTOPPED(code_int)) { status = @':stopped'; code = ecl_make_fixnum(WSTOPSIG(code_int)); + } else if (WIFCONTINUED(code_int)) { + status = @':resumed'; + code = ecl_make_fixnum(SIGCONT); } else { status = @':running'; code = ECL_NIL; diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index dfb1e2c1..99c7dfd1 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -50,13 +50,14 @@ (ext:external-process-wait external-process nil) (values status (external-process-%code external-process))))) -;;; --------------------------------------------------------------------------- -;;; si:waitpid -> (values status code pid) -;;; --------------------------------------------------------------------------- -;;; nochg :: (values nil nil nil) -;;; error :: (values (member :abort :error) nil nil) -;;; chang :: (values (member :exited :signalled :stopped :running) code pid) -;;; --------------------------------------------------------------------------- +;;; --------------------------------------------------------------------- +;;; si:waitpid -> (values status code pid) +;;; --------------------------------------------------------------------- +;;; no change :: (values nil nil nil) +;;; error :: (values (member :abort :error) nil nil) +;;; finished :: (values (member :exited :signalled) code pid) +;;; running :: (values (member :stopped :resumed :running) code pid) +;;; --------------------------------------------------------------------- (defun external-process-wait (process &optional wait) (let ((pid (external-process-pid process))) (when pid @@ -68,7 +69,7 @@ (external-process-pid process) nil (external-process-%status process) status (external-process-%code process) code))) - ((:stopped :running) + ((:stopped :resumed :running) (setf (external-process-%status process) status (external-process-%code process) code)) ((nil) #| wait was nil and process didn't change |#))))) From ccacf11cbc6fcb8d2f43f37490c56a8f93184afc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 20 Feb 2017 15:22:41 +0100 Subject: [PATCH 31/77] run-program: add preliminary test suite --- .../auxiliary/external-process-programs.lisp | 46 ++++++ src/tests/ecl-tests.asd | 1 + src/tests/ecl-tests.lisp | 4 +- src/tests/normal-tests/mixed.lsp | 21 --- src/tests/normal-tests/run-program.lsp | 137 ++++++++++++++++++ 5 files changed, 186 insertions(+), 23 deletions(-) create mode 100644 src/tests/auxiliary/external-process-programs.lisp create mode 100644 src/tests/normal-tests/run-program.lsp diff --git a/src/tests/auxiliary/external-process-programs.lisp b/src/tests/auxiliary/external-process-programs.lisp new file mode 100644 index 00000000..bb6de41c --- /dev/null +++ b/src/tests/auxiliary/external-process-programs.lisp @@ -0,0 +1,46 @@ +(in-package #:cl-user) + +(defmacro define-function (name &body body) + `(defun ,name (&aux + (argc (si:argc)) + (argv (ext:command-args))) + (declare (ignorable argc argv)) + ,@body)) + +(define-function arg-test + (if (= argc *args-number*) + (quit 0) + (quit 1))) + +(define-function print-test + (terpri *standard-output*) + (princ "Hello stdout" *standard-output*) + (terpri *error-output*) + (princ "Hello stderr" *error-output*)) + +(define-function io/err + (princ "Welcome to ITP(NR) - Intelligent Test Program (not really)!") + (print argc *error-output*) + + (princ "Type your SEXP: ") + (let ((result (read *standard-input* nil :eof))) + (princ result *error-output*) + (cond ((eq result :eof) + (princ "No? Shame...") + (quit 1)) + (:otherwise + "Thank you. Your wish has been heard loud and clear." + (quit 0))))) + +(define-function terminate + ;; timeout is for case of zombies, this process should be killed + ;; from the outside. + (sleep 10) + (quit 0)) + +(define-function suspend + (do () (nil) + (print "heartbit") + (sleep 1) + (print "boombaya") + (sleep 1))) diff --git a/src/tests/ecl-tests.asd b/src/tests/ecl-tests.asd index 9a12e117..bab5acfc 100644 --- a/src/tests/ecl-tests.asd +++ b/src/tests/ecl-tests.asd @@ -16,6 +16,7 @@ (:file "mixed") (:file "compiler") (:file "executable-cli") + (:file "run-program") (:file "multiprocessing" :if-feature :threads) (:file "embedding" :if-feature (:not :ecl-bytecmp)) (:file "foreign-interface" :if-feature :ffi) diff --git a/src/tests/ecl-tests.lisp b/src/tests/ecl-tests.lisp index 03957aec..963294b3 100644 --- a/src/tests/ecl-tests.lisp +++ b/src/tests/ecl-tests.lisp @@ -22,11 +22,11 @@ ;;;; Declare the suites (suite 'ecl-tests '(executable eformat ieee-fp eprocess package-locks ansi+ mixed - cmp emb ffi mop mp)) + cmp emb ffi mop mp run-program)) (suite 'make-check '(executable ieee-fp eprocess package-locks ansi+ mixed cmp emb - ffi mop)) + ffi mop run-program)) ;;; Some syntactic sugar for 2am diff --git a/src/tests/normal-tests/mixed.lsp b/src/tests/normal-tests/mixed.lsp index 8203eab1..f2ddf9a7 100644 --- a/src/tests/normal-tests/mixed.lsp +++ b/src/tests/normal-tests/mixed.lsp @@ -173,27 +173,6 @@ (fail (ext:file-stream-fd (make-string-output-stream)) "Not-file stream would cause internal error on this ECL (skipped)"))) - -;;;; Author: Daniel Kochmański -;;;; Created: 2016-09-07 -;;;; Contains: External process interaction API -;;;; -(test mix.0011.run-program - (let ((p (nth-value 2 (ext:run-program #-windows "sleep" - #+windows "timeout" - (list "3") :wait nil)))) - (is (eql :running (ext:external-process-wait p nil)) - "process doesn't run") - (ext:terminate-process p) - (sleep 1) - (multiple-value-bind (status code) - (ext:external-process-wait p nil) - (is (eql :signaled status) - "status is ~s, should be ~s" status :signalled) - (is (eql ext:+sigterm+ code) - "signal code is ~s, should be ~s" code ext:+sigterm+)) - (finishes (ext:terminate-process p)))) - ;;; Date: 2016-12-20 ;;; Reported by: Kris Katterjohn diff --git a/src/tests/normal-tests/run-program.lsp b/src/tests/normal-tests/run-program.lsp new file mode 100644 index 00000000..bcbaa9c2 --- /dev/null +++ b/src/tests/normal-tests/run-program.lsp @@ -0,0 +1,137 @@ +(in-package :cl-test) + +(suite 'run-program) + +;; +;; ;;;; Author: Daniel Kochmański +;; ;;;; Created: 2016-09-07 +;; ;;;; Contains: External process interaction API +;; ;;;; +;; (test run-program.0001 +;; (let ((p (nth-value 2 (ext:run-program #-windows "sleep" +;; #+windows "timeout" +;; (list "3") :wait nil)))) +;; (is (eql :running (ext:external-process-wait p nil)) +;; "process doesn't run") +;; (ext:terminate-process p) +;; (sleep 1) +;; (multiple-value-bind (status code) +;; (ext:external-process-wait p nil) +;; (is (eql :signaled status) +;; "status is ~s, should be ~s" status :signalled) +;; (is (eql ext:+sigterm+ code) +;; "signal code is ~s, should be ~s" code ext:+sigterm+)) +;; (finishes (ext:terminate-process p)))) + +;; (test run-program.0002 +;; (is (eql (nth-value 1 (ext:run-program "ip" '("/all"))) 0)) +;; (multiple-value-bind (s c) + +;; (is))) + + +;;; I was wondering about the program which we could could use to test +;;; the interface (i.e both on Linux and Windows). Easy! ECL is a +;;; perfect program for that. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *binary* (si:argv 0)) + (defparameter *program* (namestring (merge-pathnames "external-process-programs.lisp" *aux-dir*)))) + +(defmacro with-run-program ((name args &rest params) &body body) + `(multiple-value-bind (,name code process) + (ext:run-program *binary* + '("--norc" + "--eval" ,(format nil "(setf *args-number* ~a)" (+ 13 (length args))) + "--eval" "(setf *load-verbose* nil)" + "--load" ,*program* + "--eval" ,(format nil "(~a)" name) + "--eval" "(quit)" + "--" ,@args) + ,@params + :wait nil) + (declare (ignorable ,name code)) + (let ((result (progn ,@body))) + (cons result (multiple-value-list (ext:external-process-wait process t)))))) + +(defmacro with-run-program2 ((name args &rest params) &body body) + `(multiple-value-bind (,name code process) + (ext:run-program *binary* + '("--norc" + "--eval" ,(format nil "(setf *args-number* ~a)" (+ 13 (length args))) + "--eval" "(setf *load-verbose* nil)" + "--load" ,*program* + "--eval" ,(format nil "(~a)" name) + "--eval" "(quit)" + "--" ,@args) + ,@params + :wait nil) + (list ,name code process))) + +(defun slurp (stream) + (do ((line #1=(read-line stream nil :eof) #1#) + (last nil line)) + ((eql line :eof) last))) + +(test arg-test + (is (equal '(nil :exited 0) + (with-run-program (arg-test ("a" "b c" "d \\" "e\ 4\\ +")))) "ext:run-program doesn't escape arguments properly")) + +(test output-streams + ;; error is a separate stream + (is-equal '(("Hello stdout" "Hello stderr") :exited 0) + (with-run-program + (print-test nil :output :stream :error :stream) + (let ((print-test-err (ext:external-process-error-stream process))) + (list (slurp print-test) (slurp print-test-err))))) + ;; :error :output + (is-equal '(("Hello stderr" nil) :exited 0) + (with-run-program + (print-test nil :output :stream :error :output) + (let ((print-test-err (ext:external-process-error-stream process))) + ;; print-test-err is drained by reading from print-test + (list (slurp print-test) (slurp print-test-err)))))) + +(test interactive-input + (is-equal '(nil :exited 0) + (with-run-program (io/err nil) + (format io/err "42~%"))) + ;; process will have :eof on input and should quit with "1" + (is-equal '(nil :exited 1) (with-run-program (io/err nil :input nil)))) + + +(test terminate-process + (is-equal `(t :signaled ,ext:+sigterm+) + (with-run-program (terminate nil) + (is-eql :running (ext:external-process-wait process nil)) + (finishes (ext:terminate-process process)) + (finishes (ext:terminate-process process)) ; no-op + (sleep 1) + (is-eql :signaled (ext:external-process-wait process nil)) + (finishes (ext:terminate-process process)))) + + (is-equal `(t :signaled ,ext:+sigkill+) + (with-run-program (terminate nil) + (is-eql :running (ext:external-process-wait process nil)) + (finishes (ext:terminate-process process t)) + (finishes (ext:terminate-process process t)) ; no-op + (sleep 1) + (is-eql :signaled (ext:external-process-wait process nil)) + (finishes (ext:terminate-process process t))))) + +;;; We may want to craft it into an interface. Suspend/Resume *is* +;;; possible on Windows: +;;; http://stackoverflow.com/questions/11010165/how-to-suspend-resume-a-process-in-windows +#-windows +(test suspend-resume + (let ((process (nth-value 2 (ext:run-program "sleep" '("100") :wait nil)))) + (let ((pid (ext:external-process-pid process))) + (is-eql :running (ext:external-process-wait process nil)) + (si:killpid pid ext:+sigstop+) + (sleep 2) + (is-eql :stopped (ext:external-process-wait process nil)) + (si:killpid pid ext:+sigcont+) + (sleep 2) + (is-eql :resumed (ext:external-process-wait process nil)) + (finishes (ext:terminate-process process t))))) From 8e537800d80e2c830d44e7d8f907e790af46daf5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 20 Feb 2017 15:26:50 +0100 Subject: [PATCH 32/77] cosmetic --- src/tests/normal-tests/run-program.lsp | 17 +---------------- 1 file changed, 1 insertion(+), 16 deletions(-) diff --git a/src/tests/normal-tests/run-program.lsp b/src/tests/normal-tests/run-program.lsp index bcbaa9c2..c038ad71 100644 --- a/src/tests/normal-tests/run-program.lsp +++ b/src/tests/normal-tests/run-program.lsp @@ -54,20 +54,6 @@ (let ((result (progn ,@body))) (cons result (multiple-value-list (ext:external-process-wait process t)))))) -(defmacro with-run-program2 ((name args &rest params) &body body) - `(multiple-value-bind (,name code process) - (ext:run-program *binary* - '("--norc" - "--eval" ,(format nil "(setf *args-number* ~a)" (+ 13 (length args))) - "--eval" "(setf *load-verbose* nil)" - "--load" ,*program* - "--eval" ,(format nil "(~a)" name) - "--eval" "(quit)" - "--" ,@args) - ,@params - :wait nil) - (list ,name code process))) - (defun slurp (stream) (do ((line #1=(read-line stream nil :eof) #1#) (last nil line)) @@ -120,8 +106,7 @@ (is-eql :signaled (ext:external-process-wait process nil)) (finishes (ext:terminate-process process t))))) -;;; We may want to craft it into an interface. Suspend/Resume *is* -;;; possible on Windows: +;;; We may want to craft it into an interface. Suspend/Resume *is* possible on Windows: ;;; http://stackoverflow.com/questions/11010165/how-to-suspend-resume-a-process-in-windows #-windows (test suspend-resume From 6733369ea0553dfe8292f6f054cb1b954d34dc9a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 20 Feb 2017 15:53:56 +0100 Subject: [PATCH 33/77] run-program: refine tests --- .../auxiliary/external-process-programs.lisp | 2 +- src/tests/normal-tests/run-program.lsp | 62 +++++++------------ 2 files changed, 25 insertions(+), 39 deletions(-) diff --git a/src/tests/auxiliary/external-process-programs.lisp b/src/tests/auxiliary/external-process-programs.lisp index bb6de41c..c0efd5da 100644 --- a/src/tests/auxiliary/external-process-programs.lisp +++ b/src/tests/auxiliary/external-process-programs.lisp @@ -38,7 +38,7 @@ (sleep 10) (quit 0)) -(define-function suspend +(define-function heartbeat (do () (nil) (print "heartbit") (sleep 1) diff --git a/src/tests/normal-tests/run-program.lsp b/src/tests/normal-tests/run-program.lsp index c038ad71..aae6c52f 100644 --- a/src/tests/normal-tests/run-program.lsp +++ b/src/tests/normal-tests/run-program.lsp @@ -2,34 +2,6 @@ (suite 'run-program) -;; -;; ;;;; Author: Daniel Kochmański -;; ;;;; Created: 2016-09-07 -;; ;;;; Contains: External process interaction API -;; ;;;; -;; (test run-program.0001 -;; (let ((p (nth-value 2 (ext:run-program #-windows "sleep" -;; #+windows "timeout" -;; (list "3") :wait nil)))) -;; (is (eql :running (ext:external-process-wait p nil)) -;; "process doesn't run") -;; (ext:terminate-process p) -;; (sleep 1) -;; (multiple-value-bind (status code) -;; (ext:external-process-wait p nil) -;; (is (eql :signaled status) -;; "status is ~s, should be ~s" status :signalled) -;; (is (eql ext:+sigterm+ code) -;; "signal code is ~s, should be ~s" code ext:+sigterm+)) -;; (finishes (ext:terminate-process p)))) - -;; (test run-program.0002 -;; (is (eql (nth-value 1 (ext:run-program "ip" '("/all"))) 0)) -;; (multiple-value-bind (s c) - -;; (is))) - - ;;; I was wondering about the program which we could could use to test ;;; the interface (i.e both on Linux and Windows). Easy! ECL is a ;;; perfect program for that. @@ -110,13 +82,27 @@ ;;; http://stackoverflow.com/questions/11010165/how-to-suspend-resume-a-process-in-windows #-windows (test suspend-resume - (let ((process (nth-value 2 (ext:run-program "sleep" '("100") :wait nil)))) - (let ((pid (ext:external-process-pid process))) - (is-eql :running (ext:external-process-wait process nil)) - (si:killpid pid ext:+sigstop+) - (sleep 2) - (is-eql :stopped (ext:external-process-wait process nil)) - (si:killpid pid ext:+sigcont+) - (sleep 2) - (is-eql :resumed (ext:external-process-wait process nil)) - (finishes (ext:terminate-process process t))))) + (is-equal `(t :signaled ,ext:+sigkill+) + (with-run-program (heartbeat nil) + (let ((pid (ext:external-process-pid process))) + (is-eql :running (ext:external-process-wait process nil)) + (si:killpid pid ext:+sigstop+) + (sleep 2) + (is-eql :stopped (ext:external-process-wait process nil)) + (si:killpid pid ext:+sigcont+) + (sleep 2) + (is-eql :resumed (ext:external-process-wait process nil)) + (finishes (ext:terminate-process process t)))))) + +;;; This test is disabled because we don't support virtual streams in +;;; run-program yet. +#+ (or) (test no-fd-streams + (let ((output-stream (make-string-output-stream)) + (error-stream (make-string-output-stream))) + (with-input-from-string (input-stream "42") + (with-run-program (io/err nil :input input-stream + :output output-stream + :error error-stream))) + (is-not (zerop (length (get-output-stream-string output-stream)))) + (is-not (zerop (length (get-output-stream-string error-stream)))) + (mapc #'close (list output-stream error-stream)))) From 663b1bdcf2f3751b8a11cb99a317e63bea158d56 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 20 Feb 2017 16:20:29 +0100 Subject: [PATCH 34/77] terminate-process: add information about potential race --- src/lsp/process.lsp | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 99c7dfd1..d98bbb13 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -76,6 +76,13 @@ (values (external-process-%status process) (external-process-%code process))) +;;; This function isn't overly safe. Assuming `external-process-wait' +;;; is called after getting PID bu 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 (let ((pid (external-process-pid process))) From 41d8de93824f93b98bd5b65349a35be336c7c018 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 20 Feb 2017 17:27:40 +0100 Subject: [PATCH 35/77] windows: use internal commands --- src/compile.lsp.in | 6 ++---- src/lsp/process.lsp | 1 + 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/src/compile.lsp.in b/src/compile.lsp.in index 678949af..ffd46737 100755 --- a/src/compile.lsp.in +++ b/src/compile.lsp.in @@ -340,10 +340,8 @@ :if-does-not-exist :create) (write-line "id ICON \"ecl.ico\"" s)) (ext:copy-file #p"src:util;ecl.ico" "ecl.ico") - #+msvc - (ext:run-program "rc" '("/r" "ecl.rc")) - #-msvc - (ext:run-program "windres" '("ecl.rc" "-O" "coff" "ecl.res"))) + #+msvc (ext:system "rc /r ecl.rc") + #-msvc (ext:system "windres ecl.rc -O coff ecl.res")) (si::pathname-translations "SYS" '(("**;*.*.*" "@true_builddir@/**/*.*"))) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index d98bbb13..4c0d3be4 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -139,6 +139,7 @@ ;; 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)) From 5f86a3f8b97525e2915f9f0b0722407a78ac2819 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 20 Feb 2017 17:39:24 +0100 Subject: [PATCH 36/77] cmpos-run: be more windows-friendly --- src/cmp/cmpos-run.lsp | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/cmp/cmpos-run.lsp b/src/cmp/cmpos-run.lsp index 97ef8aea..81eccbb4 100755 --- a/src/cmp/cmpos-run.lsp +++ b/src/cmp/cmpos-run.lsp @@ -42,7 +42,8 @@ (args `(,@(cdr program) ,@args)) (program (car program))) (with-current-directory - (ext:system (format nil "~S~{ ~S~}" program args)))))) + #-msvc(si:run-program-inner program args nil) + #+msvc(si:system (format nil "~A~{ ~A~}" program args)))))) (cond ((null result) (cerror "Continues anyway." "Unable to execute:~%(RUN-PROGRAM ~S ~S)" From 7a16333f4a3a15bab18efaa46e01b83638920000 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 20 Feb 2017 17:43:37 +0100 Subject: [PATCH 37/77] tests: adjust to windows --- src/tests/normal-tests/run-program.lsp | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/src/tests/normal-tests/run-program.lsp b/src/tests/normal-tests/run-program.lsp index aae6c52f..25550fbf 100644 --- a/src/tests/normal-tests/run-program.lsp +++ b/src/tests/normal-tests/run-program.lsp @@ -60,6 +60,7 @@ (test terminate-process + #-msvc (is-equal `(t :signaled ,ext:+sigterm+) (with-run-program (terminate nil) (is-eql :running (ext:external-process-wait process nil)) @@ -68,7 +69,7 @@ (sleep 1) (is-eql :signaled (ext:external-process-wait process nil)) (finishes (ext:terminate-process process)))) - + #-msvc (is-equal `(t :signaled ,ext:+sigkill+) (with-run-program (terminate nil) (is-eql :running (ext:external-process-wait process nil)) @@ -76,11 +77,21 @@ (finishes (ext:terminate-process process t)) ; no-op (sleep 1) (is-eql :signaled (ext:external-process-wait process nil)) + (finishes (ext:terminate-process process t)))) + + #+msvc + (is-equal `(t :error nil) + (with-run-program (terminate nil) + (is-eql :running (ext:external-process-wait process nil)) + (finishes (ext:terminate-process process t)) + (finishes (ext:terminate-process process t)) ; no-op + (sleep 1) + (is-eql :error (ext:external-process-wait process nil)) (finishes (ext:terminate-process process t))))) ;;; We may want to craft it into an interface. Suspend/Resume *is* possible on Windows: ;;; http://stackoverflow.com/questions/11010165/how-to-suspend-resume-a-process-in-windows -#-windows +#-msvc (test suspend-resume (is-equal `(t :signaled ,ext:+sigkill+) (with-run-program (heartbeat nil) From 58a705cf692849668cb0e3c2baef82ac02fa46f0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 21 Feb 2017 07:42:48 +0100 Subject: [PATCH 38/77] Revert "tests: adjust to windows" This reverts commit 7a16333f4a3a15bab18efaa46e01b83638920000. --- src/tests/normal-tests/run-program.lsp | 15 ++------------- 1 file changed, 2 insertions(+), 13 deletions(-) diff --git a/src/tests/normal-tests/run-program.lsp b/src/tests/normal-tests/run-program.lsp index 25550fbf..aae6c52f 100644 --- a/src/tests/normal-tests/run-program.lsp +++ b/src/tests/normal-tests/run-program.lsp @@ -60,7 +60,6 @@ (test terminate-process - #-msvc (is-equal `(t :signaled ,ext:+sigterm+) (with-run-program (terminate nil) (is-eql :running (ext:external-process-wait process nil)) @@ -69,7 +68,7 @@ (sleep 1) (is-eql :signaled (ext:external-process-wait process nil)) (finishes (ext:terminate-process process)))) - #-msvc + (is-equal `(t :signaled ,ext:+sigkill+) (with-run-program (terminate nil) (is-eql :running (ext:external-process-wait process nil)) @@ -77,21 +76,11 @@ (finishes (ext:terminate-process process t)) ; no-op (sleep 1) (is-eql :signaled (ext:external-process-wait process nil)) - (finishes (ext:terminate-process process t)))) - - #+msvc - (is-equal `(t :error nil) - (with-run-program (terminate nil) - (is-eql :running (ext:external-process-wait process nil)) - (finishes (ext:terminate-process process t)) - (finishes (ext:terminate-process process t)) ; no-op - (sleep 1) - (is-eql :error (ext:external-process-wait process nil)) (finishes (ext:terminate-process process t))))) ;;; We may want to craft it into an interface. Suspend/Resume *is* possible on Windows: ;;; http://stackoverflow.com/questions/11010165/how-to-suspend-resume-a-process-in-windows -#-msvc +#-windows (test suspend-resume (is-equal `(t :signaled ,ext:+sigkill+) (with-run-program (heartbeat nil) From 000b6b0b00dc4561d983b7eccf3bb7854dbedf0e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 21 Feb 2017 07:46:43 +0100 Subject: [PATCH 39/77] subprocess: windows: handle NIL as a stream argument --- src/c/unixsys.d | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/c/unixsys.d b/src/c/unixsys.d index 9bf76838..9703b2a0 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -319,7 +319,10 @@ create_descriptor(cl_object stream, cl_object direction, printf("open_osfhandle failed\n"); } else if (Null(stream)) { - *child = NULL; + if (direction == @':input') + *child = open("nul", O_RDONLY); + else + *child = open("nul", O_WRONLY); } else if (!Null(cl_streamp(stream))) { HANDLE stream_handle = ecl_stream_to_HANDLE From 5c15b325df66695749153070b4786be3bdeb4ab4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 21 Feb 2017 07:48:05 +0100 Subject: [PATCH 40/77] subprocess: windows: safe-run-program adjustment --- src/cmp/cmpos-run.lsp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/cmp/cmpos-run.lsp b/src/cmp/cmpos-run.lsp index 81eccbb4..648a8f44 100755 --- a/src/cmp/cmpos-run.lsp +++ b/src/cmp/cmpos-run.lsp @@ -42,8 +42,8 @@ (args `(,@(cdr program) ,@args)) (program (car program))) (with-current-directory - #-msvc(si:run-program-inner program args nil) - #+msvc(si:system (format nil "~A~{ ~A~}" program args)))))) + #-windows(si:run-program-inner program args nil) + #+windows(si:system (format nil "~A~{ ~A~}" program args)))))) (cond ((null result) (cerror "Continues anyway." "Unable to execute:~%(RUN-PROGRAM ~S ~S)" From a3d68f9847c27e9277eff6a01662135bb68b0014 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 21 Feb 2017 08:16:43 +0100 Subject: [PATCH 41/77] run-program: spawn-subprocess always returns fixnum --- src/lsp/process.lsp | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 4c0d3be4..8cc16a21 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -189,9 +189,9 @@ (multiple-value-bind (pid parent-write parent-read parent-error) (si:spawn-subprocess progname args environ input output error) (unless pid - (when parent-write (ff-close parent-write)) - (when parent-read (ff-close parent-read)) - (when parent-error (ff-close parent-error)) + (unless (zerop parent-write) (ff-close parent-write)) + (unless (zerop parent-read) (ff-close parent-read)) + (unless (zerop parent-error) (ff-close parent-error)) (with-active-processes-lock (setf *active-processes* (delete process *active-processes*))) (error "Could not spawn subprocess to run ~S." progname)) From 5e2679e5fc0a5eb324e43f74883e0d920201c593 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 21 Feb 2017 08:36:24 +0100 Subject: [PATCH 42/77] spawn-subprocess: on error signal condition --- src/c/unixsys.d | 15 +++++++++++---- src/lsp/process.lsp | 17 +++++------------ 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/src/c/unixsys.d b/src/c/unixsys.d index 9703b2a0..e364fd99 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -403,10 +403,6 @@ si_run_program_inner(cl_object command, cl_object argv, cl_object environ) { parent_write = ecl_fixnum(ecl_nth_value(the_env, 1)); parent_read = ecl_fixnum(ecl_nth_value(the_env, 2)); - if (Null(pid) || (parent_write <= 0) || (parent_read <= 0)) { - FEerror("Could not spawn subprocess to run ~S.", 1, command); - } - stream_write = ecl_make_stream_from_fd(command, parent_write, ecl_smm_output, 8, ECL_STREAM_DEFAULT_FORMAT, @@ -587,6 +583,17 @@ si_spawn_subprocess(cl_object command, cl_object argv, cl_object environ, @(return ECL_NIL); } #endif + + if (Null(pid)) { + if (parent_write) close(parent_write); + if (parent_read) close(parent_read); + if (parent_error) close(parent_error); + parent_write = 0; + parent_read = 0; + parent_error = 0; + FEerror("Could not spawn subprocess to run ~S.", 1, command); + } + @(return pid ecl_make_fixnum(parent_write) ecl_make_fixnum(parent_read) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 8cc16a21..f3c411f9 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -187,15 +187,11 @@ (process (make-external-process))) (with-active-processes-lock (push process *active-processes*)) (multiple-value-bind (pid parent-write parent-read parent-error) - (si:spawn-subprocess progname args environ input output error) - (unless pid - (unless (zerop parent-write) (ff-close parent-write)) - (unless (zerop parent-read) (ff-close parent-read)) - (unless (zerop parent-error) (ff-close parent-error)) - (with-active-processes-lock - (setf *active-processes* (delete process *active-processes*))) - (error "Could not spawn subprocess to run ~S." progname)) - + (handler-case (si:spawn-subprocess progname args environ input output error) + (t (c) + (with-active-processes-lock + (setf *active-processes* (delete process *active-processes*))) + (signal c))) (let ((stream-write (when (< 0 parent-write) (make-output-stream-from-fd progname parent-write external-format))) @@ -263,6 +259,3 @@ (defun null-stream () (ffi:c-inline () () :object "cl_core.null_stream" :one-liner t :side-effects nil)) - -(ffi:defentry ff-close (:int) (:int "close") :no-interrupts t) - From 488797c910cc638e7b04662b2e53f6ef89b8c872 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 21 Feb 2017 08:59:05 +0100 Subject: [PATCH 43/77] don't duplicate parent_error --- src/c/unixsys.d | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/c/unixsys.d b/src/c/unixsys.d index e364fd99..ec71df37 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -451,9 +451,9 @@ si_spawn_subprocess(cl_object command, cl_object argv, cl_object environ, &child_stderr, 0, TRUE, DUPLICATE_SAME_ACCESS); /* Same for the parent_read and parent_error. */ - DuplicateHandle(current, parent_read, current, - &parent_error, 0, TRUE, - DUPLICATE_SAME_ACCESS); + /* DuplicateHandle(current, parent_read, current, */ + /* &parent_error, 0, TRUE, */ + /* DUPLICATE_SAME_ACCESS); */ } else create_descriptor(error, @':output', &child_stderr, &parent_error); From 487e671d3412197a87d4bed0d81f66d99bb7fe70 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 21 Feb 2017 08:59:48 +0100 Subject: [PATCH 44/77] process: reduce code nesting --- src/lsp/process.lsp | 55 ++++++++++++++++++++++++--------------------- 1 file changed, 29 insertions(+), 26 deletions(-) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index f3c411f9..77c5b430 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -184,33 +184,36 @@ (let ((progname (si:copy-to-simple-base-string command)) (args (prepare-args (cons command argv))) - (process (make-external-process))) - (with-active-processes-lock (push process *active-processes*)) - (multiple-value-bind (pid parent-write parent-read parent-error) - (handler-case (si:spawn-subprocess progname args environ input output error) - (t (c) - (with-active-processes-lock - (setf *active-processes* (delete process *active-processes*))) - (signal c))) - (let ((stream-write - (when (< 0 parent-write) - (make-output-stream-from-fd progname parent-write external-format))) - (stream-read - (when (< 0 parent-read) - (make-input-stream-from-fd progname parent-read external-format))) - (stream-error - (when (< 0 parent-error) - (make-input-stream-from-fd progname parent-error external-format)))) - (setf (external-process-pid process) pid - (external-process-input process) (or stream-write (null-stream)) - (external-process-output process) (or stream-read (null-stream)) - (external-process-error-stream process) (or stream-error (null-stream)) - (external-process-status-hook process) status-hook) + (process (make-external-process)) + pid parent-write parent-read parent-error) - (values (make-two-way-stream (external-process-output process) - (external-process-input process)) - (when wait (nth-value 1 (si:external-process-wait process t))) - process)))))) + (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) + (with-active-processes-lock + (setf *active-processes* (delete process *active-processes*))) + (signal c))) + + (let ((stream-write + (when (< 0 parent-write) + (make-output-stream-from-fd progname parent-write external-format))) + (stream-read + (when (< 0 parent-read) + (make-input-stream-from-fd progname parent-read external-format))) + (stream-error + (when (< 0 parent-error) + (make-input-stream-from-fd progname parent-error external-format)))) + (setf (external-process-pid process) pid + (external-process-input process) (or stream-write (null-stream)) + (external-process-output process) (or stream-read (null-stream)) + (external-process-error-stream process) (or stream-error (null-stream)) + (external-process-status-hook process) status-hook) + + (values (make-two-way-stream (external-process-output process) + (external-process-input process)) + (when wait (nth-value 1 (si:external-process-wait process t))) + process))))) #+windows (defun escape-arg (arg stream) From 6c343fd33442df454a241a13b05b289cb40de105 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 21 Feb 2017 09:22:30 +0100 Subject: [PATCH 45/77] safe-run-program: return code --- src/cmp/cmpos-run.lsp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/cmp/cmpos-run.lsp b/src/cmp/cmpos-run.lsp index 648a8f44..e54bf266 100755 --- a/src/cmp/cmpos-run.lsp +++ b/src/cmp/cmpos-run.lsp @@ -42,8 +42,8 @@ (args `(,@(cdr program) ,@args)) (program (car program))) (with-current-directory - #-windows(si:run-program-inner program args nil) - #+windows(si:system (format nil "~A~{ ~A~}" program args)))))) + #-windows (nth-value 1 (si:run-program-inner program args nil)) + #+windows (si:system (format nil "~A~{ ~A~}" program args)))))) (cond ((null result) (cerror "Continues anyway." "Unable to execute:~%(RUN-PROGRAM ~S ~S)" From a3076235641dd6cb5dda77ca66f60a4227885a16 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 17 Mar 2017 08:09:49 +0100 Subject: [PATCH 46/77] cosmetic: improve gitignore --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index 8465ef51..3d05a50e 100644 --- a/.gitignore +++ b/.gitignore @@ -17,6 +17,7 @@ cov-int *.manifest *.obj *.pdb +*.fasl msvc/help.doc @@ -96,3 +97,4 @@ regressions/eformat-tests/*.txt /msvc/rt.asd /msvc/sb-bsd-sockets.asd /msvc/sockets.asd +doc/tmp/ From 656696e62abf53470a7b96841bbfd67aba346e6a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 17 Mar 2017 09:32:03 +0100 Subject: [PATCH 47/77] tests: run-program: add test for various values for streams --- src/tests/normal-tests/run-program.lsp | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/src/tests/normal-tests/run-program.lsp b/src/tests/normal-tests/run-program.lsp index aae6c52f..c622bd90 100644 --- a/src/tests/normal-tests/run-program.lsp +++ b/src/tests/normal-tests/run-program.lsp @@ -31,6 +31,7 @@ (last nil line)) ((eql line :eof) last))) + (test arg-test (is (equal '(nil :exited 0) (with-run-program (arg-test ("a" "b c" "d \\" "e\ 4\\ @@ -58,6 +59,20 @@ ;; process will have :eof on input and should quit with "1" (is-equal '(nil :exited 1) (with-run-program (io/err nil :input nil)))) +(test stream-values + (is-equal '(nil :exited 0) + (with-run-program (print-test nil :output nil :error nil :input nil))) + (is-equal '(nil :exited 0) + (with-run-program (print-test nil :output nil :error :output :input nil))) + (is-equal '(nil :exited 0) + (with-run-program (print-test nil :output nil :error :output :input :stream))) + (is-equal '(nil :exited 0) + (with-run-program (print-test nil :output :stream :error :output :input :stream))) + (is-equal '(nil :exited 0) + (with-run-program (print-test nil :output :stream :error :stream :input :stream))) + (signals simple-error + (with-run-program (print-test nil :output :bam :error :stream :input :stream)))) + (test terminate-process (is-equal `(t :signaled ,ext:+sigterm+) From 4256ac7e2b700ee56d716383222acc7730886d3e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 17 Mar 2017 09:37:08 +0100 Subject: [PATCH 48/77] tests: run-program: add test for escape-arguents (windows) --- src/tests/normal-tests/run-program.lsp | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/tests/normal-tests/run-program.lsp b/src/tests/normal-tests/run-program.lsp index c622bd90..c27bc1b0 100644 --- a/src/tests/normal-tests/run-program.lsp +++ b/src/tests/normal-tests/run-program.lsp @@ -35,7 +35,11 @@ (test arg-test (is (equal '(nil :exited 0) (with-run-program (arg-test ("a" "b c" "d \\" "e\ 4\\ -")))) "ext:run-program doesn't escape arguments properly")) +")))) "ext:run-program doesn't escape arguments properly") + #+windows + (is-false (equal '(nil :exited 0) + (with-run-program (arg-test ("a" "b c" "d \\" "e\ 4\\ +") :escape-arguments nil))) "ext:run-program doesn't escape arguments properly")) (test output-streams ;; error is a separate stream From 716ab71010b06ac49bee785baedd02e349289156 Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Fri, 17 Mar 2017 11:53:52 +0100 Subject: [PATCH 49/77] windows: fix make check --- msvc/tests/Makefile | 46 ++++++-------------------- src/tests/config.lsp.in | 2 ++ src/tests/normal-tests/run-program.lsp | 26 +++++++-------- 3 files changed, 24 insertions(+), 50 deletions(-) diff --git a/msvc/tests/Makefile b/msvc/tests/Makefile index d8bcbfd1..cc7f8bf3 100755 --- a/msvc/tests/Makefile +++ b/msvc/tests/Makefile @@ -2,44 +2,18 @@ top_srcdir=..\.. ECLDIR=../package/ ECL=..\package\ecl.exe -all: show-fails +.PHONY: all -.PHONY: do-regressions cleanup clean-sources update +all: check + +check: config.lsp + set ECLDIR=$(ECLDIR) + $(ECL) -norc \ + -load config.lsp \ + -eval "(ecl-tests::run-tests '($(TESTS)))" \ + -eval "(ext:quit)" config.lsp: $(top_srcdir)\src\tests\config.lsp.in ..\c\cut.exe Makefile ..\c\cut.exe "@builddir@" "./" \ - "@top_srcdir@" "../.." \ + "@true_srcdir@" "../src" \ < $(top_srcdir)\src\tests\config.lsp.in > config.lsp - -output.ecl\regressions.log: config.lsp - $(MAKE) do-regressions - -do-regressions: regressions config.lsp - set ECLDIR=$(ECLDIR) - $(ECL) -norc -load config.lsp -eval "(ecl-tests::run-regressions-tests)" -eval "(ext:quit)" - -show-fails: regressions.log - type regressions.log - -# -# Create directories -# -regressions.log: config.lsp - $(MAKE) do-regressions - -# -# Cleanup -# -clean: - rm -rf output* - -clean-sources: - test -f config.lsp.in || rm -rf bugs - rm -rf ansi-tests quicklisp - -distclean: clean-sources clean - rm -rf cache - -update: clean-sources - $(MAKE) regressions - diff --git a/src/tests/config.lsp.in b/src/tests/config.lsp.in index 071e0659..13b6b571 100755 --- a/src/tests/config.lsp.in +++ b/src/tests/config.lsp.in @@ -21,6 +21,8 @@ when (probe-file "configure.ac") return *default-pathname-defaults*)) +(setf *ecl-sources* (truename *ecl-sources*)) + (defvar *here* (merge-pathnames "@builddir@/")) (defvar *cache* (merge-pathnames "./cache/" *here*)) diff --git a/src/tests/normal-tests/run-program.lsp b/src/tests/normal-tests/run-program.lsp index c27bc1b0..13890743 100644 --- a/src/tests/normal-tests/run-program.lsp +++ b/src/tests/normal-tests/run-program.lsp @@ -37,9 +37,9 @@ (with-run-program (arg-test ("a" "b c" "d \\" "e\ 4\\ ")))) "ext:run-program doesn't escape arguments properly") #+windows - (is-false (equal '(nil :exited 0) + (is (null (equal '(nil :exited 0) (with-run-program (arg-test ("a" "b c" "d \\" "e\ 4\\ -") :escape-arguments nil))) "ext:run-program doesn't escape arguments properly")) +") :escape-arguments nil)))) "ext:run-program :ESCAPE-ARGUMENTS NIL doesn't work")) (test output-streams ;; error is a separate stream @@ -61,19 +61,17 @@ (with-run-program (io/err nil) (format io/err "42~%"))) ;; process will have :eof on input and should quit with "1" - (is-equal '(nil :exited 1) (with-run-program (io/err nil :input nil)))) + (is-equal '(nil :exited 1) (with-run-program (io/err nil :input nil))) + ) -(test stream-values - (is-equal '(nil :exited 0) - (with-run-program (print-test nil :output nil :error nil :input nil))) - (is-equal '(nil :exited 0) - (with-run-program (print-test nil :output nil :error :output :input nil))) - (is-equal '(nil :exited 0) - (with-run-program (print-test nil :output nil :error :output :input :stream))) - (is-equal '(nil :exited 0) - (with-run-program (print-test nil :output :stream :error :output :input :stream))) - (is-equal '(nil :exited 0) - (with-run-program (print-test nil :output :stream :error :stream :input :stream))) +(test stream-values () + (finishes (with-run-program (print-test nil :output nil :error nil :input nil))) + (finishes (with-run-program (print-test nil :output nil :error :output :input nil))) + (finishes (with-run-program (print-test nil :output nil :error :output :input :stream))) + (finishes (with-run-program + (print-test nil :output :stream :error :output :input :stream))) + (finishes (with-run-program + (print-test nil :output :stream :error :stream :input :stream))) (signals simple-error (with-run-program (print-test nil :output :bam :error :stream :input :stream)))) From 1651219474a7b415a5c64341c82316c8ad3664b3 Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Fri, 17 Mar 2017 12:21:21 +0100 Subject: [PATCH 50/77] tests: run-program: windows: fix terminate answers --- src/tests/normal-tests/run-program.lsp | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/tests/normal-tests/run-program.lsp b/src/tests/normal-tests/run-program.lsp index 13890743..d485a023 100644 --- a/src/tests/normal-tests/run-program.lsp +++ b/src/tests/normal-tests/run-program.lsp @@ -77,22 +77,25 @@ (test terminate-process - (is-equal `(t :signaled ,ext:+sigterm+) + (is-equal #-windows `(t :signaled ,ext:+sigterm+) + #+windows `(t :exited -1) (with-run-program (terminate nil) (is-eql :running (ext:external-process-wait process nil)) (finishes (ext:terminate-process process)) (finishes (ext:terminate-process process)) ; no-op (sleep 1) - (is-eql :signaled (ext:external-process-wait process nil)) + #-windows(is-eql :signaled (ext:external-process-wait process nil)) + #+windows(is-eql :exited (ext:external-process-wait process nil)) (finishes (ext:terminate-process process)))) - - (is-equal `(t :signaled ,ext:+sigkill+) + (is-equal #-windows `(t :signaled ,ext:+sigterm+) + #+windows `(t :exited -1) (with-run-program (terminate nil) (is-eql :running (ext:external-process-wait process nil)) (finishes (ext:terminate-process process t)) (finishes (ext:terminate-process process t)) ; no-op (sleep 1) - (is-eql :signaled (ext:external-process-wait process nil)) + #-windows(is-eql :signaled (ext:external-process-wait process nil)) + #+windows(is-eql :exited (ext:external-process-wait process nil)) (finishes (ext:terminate-process process t))))) ;;; We may want to craft it into an interface. Suspend/Resume *is* possible on Windows: From ad0fad5b06e7a6d89fc2231ee2f170c2e41ad111 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 18 Mar 2017 09:52:05 +0100 Subject: [PATCH 51/77] external-program: don't reuse core.null-stream --- src/lsp/process.lsp | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 8056742e..c2f443f1 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -168,7 +168,11 @@ (escape-arg arg str) (princ arg str)) (when rest - (write-char #\Space str))))))) + (write-char #\Space str)))))) + (null-stream (direction) + (open #-windows "/dev/null" + #+windows "nul" + :direction direction))) (setf input (process-stream input *standard-input* :direction :input @@ -205,9 +209,9 @@ (when (< 0 parent-error) (make-input-stream-from-fd progname parent-error external-format)))) (setf (external-process-pid process) pid - (external-process-input process) (or stream-write (null-stream)) - (external-process-output process) (or stream-read (null-stream)) - (external-process-error-stream process) (or stream-error (null-stream)) + (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) (values (make-two-way-stream (external-process-output process) @@ -259,6 +263,3 @@ (name fd external-format) (:string :int :object) :object "ecl_make_stream_from_fd(#0, #1, ecl_smm_output, 8, ECL_STREAM_DEFAULT_FORMAT, #2)" :one-liner t)) - -(defun null-stream () - (ffi:c-inline () () :object "cl_core.null_stream" :one-liner t :side-effects nil)) From 7a76c928f36353a3b3e196bf1460179bcfd0ffce Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 18 Mar 2017 09:52:22 +0100 Subject: [PATCH 52/77] run-program: tests: fix typo --- src/tests/normal-tests/run-program.lsp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tests/normal-tests/run-program.lsp b/src/tests/normal-tests/run-program.lsp index d485a023..40983202 100644 --- a/src/tests/normal-tests/run-program.lsp +++ b/src/tests/normal-tests/run-program.lsp @@ -87,7 +87,7 @@ #-windows(is-eql :signaled (ext:external-process-wait process nil)) #+windows(is-eql :exited (ext:external-process-wait process nil)) (finishes (ext:terminate-process process)))) - (is-equal #-windows `(t :signaled ,ext:+sigterm+) + (is-equal #-windows `(t :signaled ,ext:+sigkill+) #+windows `(t :exited -1) (with-run-program (terminate nil) (is-eql :running (ext:external-process-wait process nil)) From 43c19eafe2d86d7d7cdd2a7c0b14a510533f98af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 18 Mar 2017 20:06:46 +0100 Subject: [PATCH 53/77] run-program: don't handle nil stream in unixsys Valid values are either :stream or stream object, prepare null earlier. --- src/c/unixsys.d | 12 --------- src/lsp/process.lsp | 60 ++++++++++++++++++++++----------------------- 2 files changed, 30 insertions(+), 42 deletions(-) diff --git a/src/c/unixsys.d b/src/c/unixsys.d index ec71df37..b54a31cb 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -318,12 +318,6 @@ create_descriptor(cl_object stream, cl_object direction, if (*parent < 0) printf("open_osfhandle failed\n"); } - else if (Null(stream)) { - if (direction == @':input') - *child = open("nul", O_RDONLY); - else - *child = open("nul", O_WRONLY); - } else if (!Null(cl_streamp(stream))) { HANDLE stream_handle = ecl_stream_to_HANDLE (stream, direction != @':input'); @@ -357,12 +351,6 @@ create_descriptor(cl_object stream, cl_object direction, *child = fd[1]; } } - else if (Null(stream)) { - if (direction == @':input') - *child = open("/dev/null", O_RDONLY); - else - *child = open("/dev/null", O_WRONLY); - } else if (!Null(cl_streamp(stream))) { *child = ecl_stream_to_handle (stream, direction != @':input'); diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index c2f443f1..0e2a5064 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -143,36 +143,36 @@ (unless (ext:get-signal-handler ext:+sigchld+) (ext:set-signal-handler ext:+sigchld+ #'sigchld-handler)) - (flet ((process-stream (which default &rest args) - (cond ((eql which t) default) - ((or (stringp which) (pathnamep which)) - (apply #'open which :external-format external-format args)) - ;; this three cases are handled in create_descriptor (for now) - ((eql which nil) which) - ((eql which :stream) which) - ((streamp which) which) - ;; signal error as early as possible - (T (error "Invalid ~S argument to EXT:RUN-PROGRAM" which)))) - - (prepare-args (args) - #-windows - (mapcar #'si:copy-to-simple-base-string args) - #+windows - (si:copy-to-simple-base-string - (with-output-to-string (str) - (loop for (arg . rest) on args - do (if (and escape-arguments - (find-if (lambda (c) - (find c '(#\Space #\Tab #\"))) - arg)) - (escape-arg arg str) - (princ arg str)) - (when rest - (write-char #\Space str)))))) - (null-stream (direction) - (open #-windows "/dev/null" - #+windows "nul" - :direction direction))) + (labels ((process-stream (which default &rest args) + (cond ((eql which t) + default) + ((or (stringp which) (pathnamep which)) + (apply #'open which :external-format external-format args)) + ((eql which nil) + (null-stream (getf args :direction))) + ((or (eql which :stream) (streamp which)) + which) + ;; signal error as early as possible + (T (error "Invalid ~S argument to EXT:RUN-PROGRAM" which)))) + (prepare-args (args) + #-windows + (mapcar #'si:copy-to-simple-base-string args) + #+windows + (si:copy-to-simple-base-string + (with-output-to-string (str) + (loop for (arg . rest) on args + do (if (and escape-arguments + (find-if (lambda (c) + (find c '(#\Space #\Tab #\"))) + arg)) + (escape-arg arg str) + (princ arg str)) + (when rest + (write-char #\Space str)))))) + (null-stream (direction) + (open #-windows "/dev/null" + #+windows "nul" + :direction direction))) (setf input (process-stream input *standard-input* :direction :input From 1cff676abd959be2b50bdfe43b7c0813d7c4af99 Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Sun, 19 Mar 2017 21:27:50 +0100 Subject: [PATCH 54/77] debugger: be more error-prone in debugger --- src/lsp/top.lsp | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/lsp/top.lsp b/src/lsp/top.lsp index 54595272..493ca8ec 100644 --- a/src/lsp/top.lsp +++ b/src/lsp/top.lsp @@ -1448,11 +1448,12 @@ package." (setq *console-owner* mp:*current-process*) ;; As of ECL 9.4.1 making a normal function return from the debugger ;; seems to be a very bad idea! Basically, it dumps core... - (when (listen *debug-io*) - (clear-input *debug-io*)) + (ignore-errors + (when (listen *debug-io*) + (clear-input *debug-io*))) ;; Like in SBCL, the error message is output through *error-output* ;; The rest of the interaction is performed through *debug-io* - (finish-output) + (ignore-errors (finish-output)) ;; We wrap the following in `ignore-errors' because error may be ;; caused by writing to the `*error-output*', what leads to ;; infinite recursion! From d6c8fec000d095882e9ab211236797f2e2c5fb00 Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Sun, 19 Mar 2017 21:28:32 +0100 Subject: [PATCH 55/77] tests: run-program: test more stream cases --- src/tests/normal-tests/run-program.lsp | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/tests/normal-tests/run-program.lsp b/src/tests/normal-tests/run-program.lsp index 40983202..efa547fd 100644 --- a/src/tests/normal-tests/run-program.lsp +++ b/src/tests/normal-tests/run-program.lsp @@ -66,8 +66,16 @@ (test stream-values () (finishes (with-run-program (print-test nil :output nil :error nil :input nil))) + (finishes (with-run-program (print-test nil :output nil :error nil :input t))) + (finishes (with-run-program (print-test nil :output nil :error nil :input :stream))) (finishes (with-run-program (print-test nil :output nil :error :output :input nil))) (finishes (with-run-program (print-test nil :output nil :error :output :input :stream))) + (finishes (with-run-program (print-test nil :output t :error nil :input nil))) + (finishes (with-run-program (print-test nil :output t :error :output :input nil))) + (finishes (with-run-program (print-test nil :output t :error :stream :input nil))) + (finishes (with-run-program (print-test nil :output t :error nil :input nil))) + (finishes (with-run-program (print-test nil :output t :error :output :input nil))) + (finishes (with-run-program (print-test nil :output t :error :stream :input nil))) (finishes (with-run-program (print-test nil :output :stream :error :output :input :stream))) (finishes (with-run-program From a16c006d944d3eecab84c5ab1117be8010f8715c Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Sun, 19 Mar 2017 21:28:55 +0100 Subject: [PATCH 56/77] windows: remove unused variables --- src/c/unixsys.d | 1 - 1 file changed, 1 deletion(-) diff --git a/src/c/unixsys.d b/src/c/unixsys.d index b54a31cb..6d983c1f 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -423,7 +423,6 @@ si_spawn_subprocess(cl_object command, cl_object argv, cl_object environ, PROCESS_INFORMATION pr_info; HANDLE child_stdout, child_stdin, child_stderr; HANDLE current = GetCurrentProcess(); - HANDLE saved_stdout, saved_stdin, saved_stderr; cl_object env_buffer; char *env = NULL; From 26c74e39a6dfa027e0e956882f54ef48843338f0 Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Sun, 19 Mar 2017 22:31:09 +0100 Subject: [PATCH 57/77] run-program: fix windows interactive streams --- src/c/unixsys.d | 25 +++++++++++++++---------- 1 file changed, 15 insertions(+), 10 deletions(-) diff --git a/src/c/unixsys.d b/src/c/unixsys.d index 6d983c1f..90ed32b1 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -287,16 +287,14 @@ create_descriptor(cl_object stream, cl_object direction, from. We duplicate one extreme of the pipe so that the child does not inherit it. */ HANDLE tmp; - if (CreatePipe(&tmp, child, &attr, 0) == 0) - return; - - if (DuplicateHandle(current, tmp, current, - &tmp, 0, FALSE, - DUPLICATE_CLOSE_SOURCE | - DUPLICATE_SAME_ACCESS) == 0) - return; - if (direction == @':input') { + if (CreatePipe(child, &tmp, &attr, 0) == 0) + return; + if (DuplicateHandle(current, tmp, current, + &tmp, 0, FALSE, + DUPLICATE_CLOSE_SOURCE | + DUPLICATE_SAME_ACCESS) == 0) + return; #ifdef cygwin *parent = cygwin_attach_handle_to_fd (0, -1, tmp, S_IRWXU, GENERIC_WRITE); @@ -305,7 +303,14 @@ create_descriptor(cl_object stream, cl_object direction, ((intptr_t)tmp, _O_WRONLY); #endif } - else { + else /* if (direction == @':output') */ { + if (CreatePipe(&tmp, child, &attr, 0) == 0) + return; + if (DuplicateHandle(current, tmp, current, + &tmp, 0, FALSE, + DUPLICATE_CLOSE_SOURCE | + DUPLICATE_SAME_ACCESS) == 0) + return; #ifdef cygwin *parent = cygwin_attach_handle_to_fd (0, -1, tmp, S_IRWXU, GENERIC_READ); From 17f4e28249e075dbaca46fb1117762e3a1663a27 Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Mon, 20 Mar 2017 07:21:42 +0100 Subject: [PATCH 58/77] create-descriptor: cygwin is handled like UNIX --- src/c/symbols_list.h | 2 +- src/c/symbols_list2.h | 2 +- src/c/unixsys.d | 27 ++++++--------------------- 3 files changed, 8 insertions(+), 23 deletions(-) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 26cebde1..84851385 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -2000,7 +2000,7 @@ cl_symbols[] = { #endif {SYS_ "RUN-PROGRAM-INNER", SI_ORDINARY, si_run_program_inner, 3, OBJNULL}, {SYS_ "SPAWN-SUBPROCESS", SI_ORDINARY, si_spawn_subprocess, 6, OBJNULL}, -#if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin) +#if defined(ECL_MS_WINDOWS_HOST) {SYS_ "CLOSE-WINDOWS-HANDLE", SI_ORDINARY, si_close_windows_handle, 1, OBJNULL}, #else {SYS_ "CLOSE-WINDOWS-HANDLE", SI_ORDINARY, NULL, -1, OBJNULL}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 43c041a0..a64c40c4 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -2000,7 +2000,7 @@ cl_symbols[] = { #endif {SYS_ "RUN-PROGRAM-INNER","si_run_program_inner"}, {SYS_ "SPAWN-SUBPROCESS","si_spawn_subprocess"}, -#if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin) +#if defined(ECL_MS_WINDOWS_HOST) {SYS_ "CLOSE-WINDOWS-HANDLE","si_close_windows_handle"}, #else {SYS_ "CLOSE-WINDOWS-HANDLE",NULL}, diff --git a/src/c/unixsys.d b/src/c/unixsys.d index 90ed32b1..7e4fcdee 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -23,10 +23,7 @@ #endif #include #include -#ifdef cygwin -# include /* For cygwin_attach_handle_to_fd() */ -#endif -#if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin) +#if defined(ECL_MS_WINDOWS_HOST) # include #endif #ifdef HAVE_SYS_WAIT_H @@ -224,7 +221,7 @@ si_killpid(cl_object pid, cl_object signal) { } #endif -#if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin) +#if defined(ECL_MS_WINDOWS_HOST) cl_object si_close_windows_handle(cl_object h) { @@ -258,9 +255,7 @@ ecl_stream_to_HANDLE(cl_object s, bool output) case ecl_smm_output_wsock: case ecl_smm_io_wsock: #endif -#if defined(ECL_MS_WINDOWS_HOST) case ecl_smm_io_wcon: -#endif return (HANDLE)IO_FILE_DESCRIPTOR(s); default: { int stream_descriptor = ecl_stream_to_handle(s, output); @@ -295,13 +290,8 @@ create_descriptor(cl_object stream, cl_object direction, DUPLICATE_CLOSE_SOURCE | DUPLICATE_SAME_ACCESS) == 0) return; -#ifdef cygwin - *parent = cygwin_attach_handle_to_fd - (0, -1, tmp, S_IRWXU, GENERIC_WRITE); -#else - *parent = _open_osfhandle - ((intptr_t)tmp, _O_WRONLY); -#endif + + *parent = _open_osfhandle((intptr_t)tmp, _O_WRONLY); } else /* if (direction == @':output') */ { if (CreatePipe(&tmp, child, &attr, 0) == 0) @@ -311,13 +301,8 @@ create_descriptor(cl_object stream, cl_object direction, DUPLICATE_CLOSE_SOURCE | DUPLICATE_SAME_ACCESS) == 0) return; -#ifdef cygwin - *parent = cygwin_attach_handle_to_fd - (0, -1, tmp, S_IRWXU, GENERIC_READ); -#else - *parent = _open_osfhandle - ((intptr_t)tmp, _O_RDONLY); -#endif + + *parent = _open_osfhandle((intptr_t)tmp, _O_RDONLY); } if (*parent < 0) From afad65bcc695e37d442622fe20e8fcd55e9b136d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 20 Mar 2017 21:05:04 +0100 Subject: [PATCH 59/77] cosmetic: typo --- src/lsp/process.lsp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 0e2a5064..6644ca2d 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -77,7 +77,7 @@ (external-process-%code process))) ;;; This function isn't overly safe. Assuming `external-process-wait' -;;; is called after getting PID bu before function sends signal, +;;; 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 From 135a43a027cd084de1297832a0025ce8eb982a3d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 20 Mar 2017 21:05:13 +0100 Subject: [PATCH 60/77] tests: run-program: add status-hook tests --- src/tests/normal-tests/run-program.lsp | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/src/tests/normal-tests/run-program.lsp b/src/tests/normal-tests/run-program.lsp index efa547fd..7771701a 100644 --- a/src/tests/normal-tests/run-program.lsp +++ b/src/tests/normal-tests/run-program.lsp @@ -134,3 +134,18 @@ (is-not (zerop (length (get-output-stream-string output-stream)))) (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)) + (is (= x 3) "X is ~s, should be 3." x)))) From bc9b33168c036c6817a4dcf87ab0f04ed654c7e5 Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Mon, 20 Mar 2017 22:15:42 +0100 Subject: [PATCH 61/77] test: sigchld-handler: adjust for cygwin --- src/tests/normal-tests/run-program.lsp | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/tests/normal-tests/run-program.lsp b/src/tests/normal-tests/run-program.lsp index 7771701a..5ddd1570 100644 --- a/src/tests/normal-tests/run-program.lsp +++ b/src/tests/normal-tests/run-program.lsp @@ -148,4 +148,9 @@ (sleep 1) (ext:terminate-process process) (sleep 1)) - (is (= x 3) "X is ~s, should be 3." x)))) + #-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)))) From d2f760970faf0b1fa69ab8bb54683cb122f2c7fc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 21 Mar 2017 18:33:56 +0100 Subject: [PATCH 62/77] fix: sigchld-handler takes key parameter process --- src/c/main.d | 1 + src/lsp/process.lsp | 3 ++- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/src/c/main.d b/src/c/main.d index 0b754a19..16bda290 100755 --- a/src/c/main.d +++ b/src/c/main.d @@ -71,6 +71,7 @@ const char *ecl_self; static int ARGC; static char **ARGV; +/* INV: see ecl_option enum in external.h */ cl_fixnum ecl_option_values[ECL_OPT_LIMIT+1] = { #ifdef GBC_BOEHM_GENGC 1, /* ECL_OPT_INCREMENTAL_GC */ diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 6644ca2d..ee999cc2 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -21,7 +21,8 @@ (mp:with-lock (*active-processes-lock*) ,@body))) -(defun sigchld-handler () +(defun sigchld-handler (&key process) + (declare (ignore process)) (let (changed) (with-active-processes-lock (mapc (lambda (process) From b5d8310f42a6106d2028408355647928c0048e83 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 22 Mar 2017 10:24:23 +0100 Subject: [PATCH 63/77] run-program: don't add process to global list if wait = t --- src/lsp/process.lsp | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index ee999cc2..88588edb 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -192,12 +192,15 @@ (process (make-external-process)) pid parent-write parent-read parent-error) - (with-active-processes-lock (push process *active-processes*)) + (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) - (with-active-processes-lock - (setf *active-processes* (delete process *active-processes*))) + (unless wait + (with-active-processes-lock + (setf *active-processes* (delete process *active-processes*)))) (signal c))) (let ((stream-write From 2991c8f27e8bbe8e037d66772d36811ff4891498 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 23 Mar 2017 13:51:52 +0100 Subject: [PATCH 64/77] cmp:run-program: show exact command --- src/cmp/cmpos-run.lsp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/cmp/cmpos-run.lsp b/src/cmp/cmpos-run.lsp index e54bf266..013bdd48 100755 --- a/src/cmp/cmpos-run.lsp +++ b/src/cmp/cmpos-run.lsp @@ -46,11 +46,11 @@ #+windows (si:system (format nil "~A~{ ~A~}" program args)))))) (cond ((null result) (cerror "Continues anyway." - "Unable to execute:~%(RUN-PROGRAM ~S ~S)" + "Unable to execute:~%(SI:RUN-PROGRAM-INNER ~S ~S NIL)" program args result)) ((not (zerop result)) (cerror "Continues anyway." - "Error code ~D when executing~%(RUN-PROGRAM ~S ~S)" + "Error code ~D when executing~%(SI:RUN-PROGRAM-INNER ~S ~S NIL)" result program args))) result)) From 3cbede6606b763aba0ef7ce4af66443f5424be5f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 23 Mar 2017 14:06:16 +0100 Subject: [PATCH 65/77] external-process-status: take into account other states --- src/lsp/process.lsp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 88588edb..f4f45fa5 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -47,7 +47,7 @@ (defun external-process-status (external-process) (let ((status (external-process-%status external-process))) - (if (eq status :running) + (if (member status (:stopped :resumed :running)) (ext:external-process-wait external-process nil) (values status (external-process-%code external-process))))) 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 66/77] 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 a35db62a..ced8a31d 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 f4f45fa5..46d787b8 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 5ddd1570..f92ddf66 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)))) From 74f4300aa055d550dd78dba7d8c693db2e0ccee8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 23 Mar 2017 18:07:57 +0100 Subject: [PATCH 67/77] run-program: arg-prep: add informative comment --- src/lsp/process.lsp | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 46d787b8..04f23b50 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -107,7 +107,13 @@ (apply #'open which :external-format external-format args)) ((eql which nil) (null-stream (getf args :direction))) - ((or (eql which :stream) (streamp which)) + #+(and (or) clos-streams threads) + ((and (streamp which) + (null (typep which 'ext:ansi-stream))) + #| Here we may want to return `:stream' and spawn + thread to handle data at runtime to fd. |#) + ((or (eql which :stream) + (streamp which)) which) ;; signal error as early as possible (T (error "Invalid ~S argument to EXT:RUN-PROGRAM" which)))) From a3a040aa8d5d188b782918129d0c06835303bf63 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 23 Mar 2017 18:09:18 +0100 Subject: [PATCH 68/77] run-program: don't shadow original arguments --- src/lsp/process.lsp | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 04f23b50..2ef1e7b4 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -137,21 +137,20 @@ #+windows "nul" :direction direction))) - (setf input (process-stream input *standard-input* - :direction :input - :if-does-not-exist if-input-does-not-exist) - output (process-stream output *standard-output* - :direction :output - :if-exists if-output-exists) - error (if (eql error :output) - :output - (process-stream error *error-output* - :direction :output - :if-exists if-error-exists))) - (let ((progname (si:copy-to-simple-base-string command)) (args (prepare-args (cons command argv))) (process (make-external-process)) + (process-input (process-stream input *standard-input* + :direction :input + :if-does-not-exist if-input-does-not-exist)) + (process-output (process-stream output *standard-output* + :direction :output + :if-exists if-output-exists)) + (process-error (if (eql error :output) + :output + (process-stream error *error-output* + :direction :output + :if-exists if-error-exists))) pid parent-write parent-read parent-error) (multiple-value-setq (pid parent-write parent-read parent-error) @@ -166,6 +165,7 @@ (stream-error (when (< 0 parent-error) (make-input-stream-from-fd progname parent-error external-format)))) + (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)) From 53a9d5d454b7942275dbd59edced35cb46481b6e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 23 Mar 2017 18:09:42 +0100 Subject: [PATCH 69/77] run-program: add process finalizer --- src/lsp/process.lsp | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 2ef1e7b4..b5e7c5e0 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -83,6 +83,13 @@ :wait t :output nil :input nil :error nil #+windows :escape-arguments #+windows nil)))) +;;; We don't handle `sigchld' because we don't want races with +;;; `external-process-wait'. Take care of forgotten processes. +(defun finalize-external-process (process) + (unless (member (ext:external-process-wait process nil) + (:exited :signaled :abort :error)) + (ext:set-finalizer process #'finalize-external-process))) + ;;; ;;; Almighty EXT:RUN-PROGRAM. Built on top of SI:SPAWN-SUBPROCESS. For ;;; simpler alternative see SI:RUN-PROGRAM-INNER. @@ -173,7 +180,9 @@ (values (make-two-way-stream (external-process-output process) (external-process-input process)) - (when wait (nth-value 1 (si:external-process-wait process t))) + (if wait + (nth-value 1 (si:external-process-wait process t)) + (ext:set-finalizer process #'finalize-external-process)) process))))) #+windows From 66e808728c59e0b5d8e3c5a992657c60e8a9c95c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 23 Mar 2017 18:41:03 +0100 Subject: [PATCH 70/77] fix typos --- src/lsp/process.lsp | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index b5e7c5e0..d74a735a 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -87,7 +87,7 @@ ;;; `external-process-wait'. Take care of forgotten processes. (defun finalize-external-process (process) (unless (member (ext:external-process-wait process nil) - (:exited :signaled :abort :error)) + '(:exited :signaled :abort :error)) (ext:set-finalizer process #'finalize-external-process))) ;;; @@ -110,10 +110,11 @@ (labels ((process-stream (which default &rest args) (cond ((eql which t) default) - ((or (stringp which) (pathnamep which)) - (apply #'open which :external-format external-format args)) ((eql which nil) (null-stream (getf args :direction))) + ((or (stringp which) (pathnamep which)) + (apply #'open which :external-format external-format args)) + #+(and (or) clos-streams threads) ((and (streamp which) (null (typep which 'ext:ansi-stream))) @@ -161,7 +162,7 @@ pid parent-write parent-read parent-error) (multiple-value-setq (pid parent-write parent-read parent-error) - (si:spawn-subprocess progname args environ input output error)) + (si:spawn-subprocess progname args environ process-input process-output process-error)) (let ((stream-write (when (< 0 parent-write) From 1d495a2edef4fe41efc667ea050e7e4564077380 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 23 Mar 2017 18:46:30 +0100 Subject: [PATCH 71/77] cosmetic: remove empty line --- src/lsp/process.lsp | 1 - 1 file changed, 1 deletion(-) diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index d74a735a..898fa7a0 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -114,7 +114,6 @@ (null-stream (getf args :direction))) ((or (stringp which) (pathnamep which)) (apply #'open which :external-format external-format args)) - #+(and (or) clos-streams threads) ((and (streamp which) (null (typep which 'ext:ansi-stream))) From cc6f893bd32b90e93c8947a487b5c9b6ab1e29e8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 23 Mar 2017 23:12:58 +0100 Subject: [PATCH 72/77] run-program: environ: coerce to base-string list --- src/c/unixsys.d | 16 ++-------------- src/lsp/process.lsp | 1 + 2 files changed, 3 insertions(+), 14 deletions(-) diff --git a/src/c/unixsys.d b/src/c/unixsys.d index 7e4fcdee..a5fc15e1 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -105,15 +105,6 @@ from_list_to_execve_argument(cl_object l, char ***environp) char **environ; for (p = l; !Null(p); p = ECL_CONS_CDR(p)) { cl_object s; - if (!CONSP(p)) { - FEerror("In EXT:RUN-PROGRAM, environment " - "is not a list of strings", 0); - } - s = ECL_CONS_CAR(p); - if (!ECL_BASE_STRING_P(s)) { - FEerror("In EXT:RUN-PROGRAM, environment " - "is not a list of base strings", 0); - } total_size += s->base_string.fillp + 1; nstrings++; } @@ -124,11 +115,7 @@ from_list_to_execve_argument(cl_object l, char ***environp) for (j = i = 0, p = l; !Null(p); p = ECL_CONS_CDR(p)) { cl_object s = ECL_CONS_CAR(p); cl_index l = s->base_string.fillp; - if (i + l + 1 >= total_size) { - FEerror("In EXT:RUN-PROGRAM, environment list" - " changed during execution.", 0); - break; - } + environ[j++] = (char*)(buffer->base_string.self + i); memcpy(buffer->base_string.self + i, s->base_string.self, @@ -367,6 +354,7 @@ si_run_program_inner(cl_object command, cl_object argv, cl_object environ) { cl_object pid, stream_write, stream_read, exit_status; command = si_copy_to_simple_base_string(command); + environ = cl_mapcar(2, @'si::copy-to-simple-base-string', environ); #if defined(ECL_MS_WINDOWS_HOST) argv = cl_format(4, ECL_NIL, diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 898fa7a0..b608c374 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -146,6 +146,7 @@ (let ((progname (si:copy-to-simple-base-string command)) (args (prepare-args (cons command argv))) + (environ (mapcar #'si:copy-to-simple-base-string environ)) (process (make-external-process)) (process-input (process-stream input *standard-input* :direction :input From 4c30430fe8cacb812fadc05b879e550721cc195b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 24 Mar 2017 00:17:14 +0100 Subject: [PATCH 73/77] waitpid: if synchronous call don't unblock on resume/pause --- src/c/unixsys.d | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/c/unixsys.d b/src/c/unixsys.d index a5fc15e1..04dd0c65 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -163,7 +163,7 @@ si_waitpid(cl_object pid, cl_object wait) if (Null(wait)) error = waitpid(ecl_to_fix(pid), &code_int, WNOHANG | WUNTRACED | WCONTINUED); else - error = waitpid(ecl_to_fix(pid), &code_int, WUNTRACED | WCONTINUED); + error = waitpid(ecl_to_fix(pid), &code_int, 0); if (error < 0) { if (errno == EINTR) { From 85103d63672e4ed54bf900cb29fef85b9add6ef7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 24 Mar 2017 00:28:35 +0100 Subject: [PATCH 74/77] new-doc: improve documentation on operating system --- src/doc/new-doc/extensions/index.txi | 10 +- src/doc/new-doc/extensions/memory.txi | 18 +++ src/doc/new-doc/extensions/osi.txi | 188 ++++++++++++++++++++++++++ 3 files changed, 211 insertions(+), 5 deletions(-) create mode 100644 src/doc/new-doc/extensions/memory.txi create mode 100644 src/doc/new-doc/extensions/osi.txi diff --git a/src/doc/new-doc/extensions/index.txi b/src/doc/new-doc/extensions/index.txi index 67625893..33a961ba 100644 --- a/src/doc/new-doc/extensions/index.txi +++ b/src/doc/new-doc/extensions/index.txi @@ -23,11 +23,11 @@ * CDR Extensions:: @end menu -@ System building +@c System building @include extensions/building.txi -@node Operating System Interface -@section Operating System Interface +@c Operating System Interface +@include extensions/osi.txi @c Foreign function interface @include extensions/ffi.txi @@ -41,8 +41,8 @@ @node Signals and Interrupts @section Signals and Interrupts -@node Memory Management -@section Memory Management +@c Memory Management +@include extensions/memory.txi @node Meta-Object Protocol (MOP) @section Meta-Object Protocol (MOP) diff --git a/src/doc/new-doc/extensions/memory.txi b/src/doc/new-doc/extensions/memory.txi new file mode 100644 index 00000000..3f47d837 --- /dev/null +++ b/src/doc/new-doc/extensions/memory.txi @@ -0,0 +1,18 @@ +@node Memory Management +@section Memory Management + +@menu +* Memory Managament Introduction:: +* Boehm-Weiser garbage collector:: +* Memory limits:: +* Memory conditions:: +* Finalization:: +* Memory Managament Reference:: +@end menu + +@node Memory Managament Introduction +@node Boehm-Weiser garbage collector +@node Memory limits +@node Memory conditions +@node Finalization +@node Memory Managament Reference diff --git a/src/doc/new-doc/extensions/osi.txi b/src/doc/new-doc/extensions/osi.txi new file mode 100644 index 00000000..a2ee473d --- /dev/null +++ b/src/doc/new-doc/extensions/osi.txi @@ -0,0 +1,188 @@ +@node Operating System Interface +@section Operating System Interface + +@menu +* External processes:: +@c * Command line arguments:: +@c * Signals and interrupts:: +* Operating System Interface Reference:: +@end menu + +@cindex External processes +@node External processes +@subsection External processes + +External process is a structure created with +@code{ext:run-program}. It is programmer responsibility, to call +@code{ext:external-process-wait} on finished processes, however during +garbage collection object will be finalized. + +@defun ext:external-process-pid process +@end defun + +@defun ext:external-process-input process +@defunx ext:external-process-output process +@defunx ext:external-process-error-stream process +Process stream accessors (read-only). +@end defun + +@defun ext:external-process-input process +@end defun + +@node Operating System Interface Reference +@subsection Operating System Interface Reference + +@lspindex ext:run-program +@defun ext:run-program command argv @ + &key input output error wait environ @ + if-input-does-not-exist if-output-exists if-error-exists @ + external-format #+windows escape-arguments + +@code{run-program} creates a new process specified by the +@var{command} argument. @var{argv} are the standard arguments that can +be passed to a program. For no arguments, use @code{nil} (which means +that just the name of the program is passed as arg 0). + +@code{run-program} will return three values - two-way stream for +communication, return code or @code{nil} (if process is called +asynchronously), and @code{ext:external-process} object holding +process state. + +It is programmer responsibility to call +@code{ext:external-process-wait} on finished process, however ECL +associates @ref{Finalization, finalizer} with the object calling it +when the object is garbage collected. If process didn't finish but is +not referenced, finalizer will be invoked once more during next +garbage collection. + +The @code{&key} arguments have the following meanings: + +@defvr argument input +Either @code{t}, @code{nil}, a pathname, a string, a stream or +@code{:stream}. If @code{t} the standard input for the current process +is inherited. If @code{nil}, @code{/dev/null} is used. If a pathname +(or a string), the file so specified is used. If a stream, all the +input is read from that stream and sent to the subprocess - stream +must be ANSI stream (no in-memory virtual streams). If @code{:stream}, +the @code{external-process-input} slot is filled in with a stream that +sends its output to the process. Defaults to @code{:stream}. +@end defvr + +@defvr argument if-input-does-not-exist +can be one of: @code{:error} to generate an error @code{:create} to +create an empty file @code{nil} (the default) to return nil from +@code{run-program} +@end defvr + +@defvr argument output +Either @code{t}, @code{nil}, a pathname, a string, a stream, or +@code{:stream}. If @code{t}, the standard output for the current +process is inherited. If @code{nil}, @code{/dev/null} is used. If a +pathname (or as string), the file so specified is used. If a stream, +all the output from the process is written to this stream - stream +must be ANSI stream (no in-memory virtual streams). If @code{:stream}, +the @code{external-process-output} slot is filled in with a stream +that can be read to get the output. Defaults to @code{stream}. +@end defvr + +@defvr argument if-output-exists +@end defvr + +@defvr argument error +Same as @code{:output}, except that @code{:error} can also be +specified as @code{:output} in which case all error output is routed +to the same place as normal output. Defaults to @code{:output}. +@end defvr + +@defvr argument if-error-exists +Same as @code{:if-output-exists}. +@end defvr + +@defvr argument wait +If non-NIL (default), wait until the created process finishes. If +@code{nil}, continue running Lisp until the program finishes. +@end defvr + +@defvr argument environ +A list of STRINGs describing the new Unix environment (as in "man +environ"). The default is to copy the environment of the current +process. To extend existing environment (instead of replacing it), +use @code{:environ (append *my-env* (ext:environ))}. + +If non-NIL @code{environ} argument is supplied, then first argument to +@code{ext:run-program} @code{command} must be full path to the file. +@end defvr + +@defvr argument external-format +The external-format to use for @code{:input}, @code{:output}, and +@code{:error} STREAMs. +@end defvr + +@emph{Windows specific options:} +@defvr argument escape-arguments +Controls escaping of the arguments passed to CreateProcess. +@end defvr +@end defun + +@c environment routines + +@defun ext:command-args +Returns the original command line arguments as list. First argument is +the ECL program itself. +@end defun + +@c Don't advertise argc and argv, we have command-args + +@c @defun ext:argc +@c @end defun + +@c @defun ext:argv +@c @end defun + +@defun ext:quit &optional code kill-all-threads +@end defun + +@defun ext:getenv variable +@end defun + +@defun ext:setenv variable value +@end defun + +@defun ext:environ +@end defun + +@c UNIX shell interface + +@defun ext:system command +@end defun + +@defun ext:make-pipe +@end defun + +@defun ext:getpid +@defunx ext:getuid +@defunx ext:getcwd +@defunx ext:chdir +@defunx ext:file-kind +@defunx ext:copy-file +@defunx ext:chmod +Common operating system functions. +@end defun + +@c Internal UNIX shell interface + +@c @defun si:mkdir +@c @defunx si:rmdir +@c @defunx si:mkstemp +@c @defunx si:copy-file +@c @end defun + +@c @defun si:get-library-pathname +@c @end defun + +@c @defun si:waitpid pid wait +@c @defunx si:kill pid signal +@c @end defun + +@c @defun si:run-program-inner command argv environ +@c @end defun From 55522ff6077072d41b5da7bb3cea17b85f8176f0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 24 Mar 2017 00:43:08 +0100 Subject: [PATCH 75/77] newdoc: osi: improve documentation --- src/doc/new-doc/extensions/osi.txi | 54 +++++++++++++++++++----------- 1 file changed, 34 insertions(+), 20 deletions(-) diff --git a/src/doc/new-doc/extensions/osi.txi b/src/doc/new-doc/extensions/osi.txi index a2ee473d..f0848a86 100644 --- a/src/doc/new-doc/extensions/osi.txi +++ b/src/doc/new-doc/extensions/osi.txi @@ -18,6 +18,21 @@ External process is a structure created with garbage collection object will be finalized. @defun ext:external-process-pid process +Process PID. +@end defun + +@defun ext:external-process-status process +Updates process status. Returns two values: + +@code{status} - member of @code{(:abort :error :exited :signalled +:stopped :resumed :running)} + +@code{code} - if process exited it is a returned value, if terminated +it is a signal code. Otherwise NIL. +@end defun + +@defun ext:terminate-process process &optional force +Terminates external process. @end defun @defun ext:external-process-input process @@ -26,12 +41,6 @@ garbage collection object will be finalized. Process stream accessors (read-only). @end defun -@defun ext:external-process-input process -@end defun - -@node Operating System Interface Reference -@subsection Operating System Interface Reference - @lspindex ext:run-program @defun ext:run-program command argv @ &key input output error wait environ @ @@ -124,6 +133,9 @@ Controls escaping of the arguments passed to CreateProcess. @end defvr @end defun +@node Operating System Interface Reference +@subsection Operating System Interface Reference + @c environment routines @defun ext:command-args @@ -139,26 +151,28 @@ the ECL program itself. @c @defun ext:argv @c @end defun -@defun ext:quit &optional code kill-all-threads -@end defun - -@defun ext:getenv variable -@end defun - -@defun ext:setenv variable value -@end defun - -@defun ext:environ -@end defun - -@c UNIX shell interface - @defun ext:system command +Run shell command ignoring its output. Uses fork. @end defun @defun ext:make-pipe +Creates a pipe and wraps it in a two way stream. @end defun + +@defun ext:quit &optional code kill-all-threads +Routine used to exit ECL in graceful manner. +@end defun + +@defun ext:environ +@defunx ext:getenv variable +@defunx ext:setenv variable value +Environment accessors. +@end defun + + +@c UNIX shell interface + @defun ext:getpid @defunx ext:getuid @defunx ext:getcwd From 4a8f4dbf9e94ec6197f1466b5b793906773b4d5c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 24 Mar 2017 01:01:14 +0100 Subject: [PATCH 76/77] newdoc: improve documentatin --- src/doc/new-doc/extensions/osi.txi | 34 +++++++++++++++++++++++++----- 1 file changed, 29 insertions(+), 5 deletions(-) diff --git a/src/doc/new-doc/extensions/osi.txi b/src/doc/new-doc/extensions/osi.txi index f0848a86..3c2f2fea 100644 --- a/src/doc/new-doc/extensions/osi.txi +++ b/src/doc/new-doc/extensions/osi.txi @@ -12,17 +12,27 @@ @node External processes @subsection External processes -External process is a structure created with -@code{ext:run-program}. It is programmer responsibility, to call +ECL provides several facilities for invoking and communicating with +@code{ext:external-process}. If one just wishes to execute some +program, without caring for its output, then probably +@code{ext:system} is the best function. In all other cases it is +preferable to use @code{ext:run-program}, which opens pipes to +communicate with the program and manipulate it while it runs on the +background. + +External process is a structure created with @code{ext:run-program} +(returned as third value). It is programmer responsibility, to call @code{ext:external-process-wait} on finished processes, however during garbage collection object will be finalized. @defun ext:external-process-pid process -Process PID. +Returns process PID or @code{nil} if already finished. @end defun @defun ext:external-process-status process -Updates process status. Returns two values: +Updates process status. @code{ext:external-process-status} calls +@code{ext:external-process-wait} if proces has not finished yet +(non-blocking call). Returns two values: @code{status} - member of @code{(:abort :error :exited :signalled :stopped :resumed :running)} @@ -31,6 +41,12 @@ Updates process status. Returns two values: it is a signal code. Otherwise NIL. @end defun +@defunx ext:external-process-wait proces wait +If the second argument is non-NIL, function blocks until external +process is finished. Otherwise status is updated. Returns two values +(see @code{ext:external-process-status}). +@end defun + @defun ext:terminate-process process &optional force Terminates external process. @end defun @@ -161,7 +177,15 @@ Creates a pipe and wraps it in a two way stream. @defun ext:quit &optional code kill-all-threads -Routine used to exit ECL in graceful manner. +This function abruptly stops the execution of the program in which ECL +is embedded. Depending on the platform, several other functions will +be invoked to free resources, close loaded modules, etc. + +The exit code is the code seen by the parent process that invoked this +program. Normally a code other than zero denotes an error. + +If @code{kill-all-threads} is non-NIL, tries to gently kill and join +with running threads. @end defun @defun ext:environ From 2d3666742963b848363e72381ecfbffdeff50fe5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 24 Mar 2017 01:22:57 +0100 Subject: [PATCH 77/77] OSI: add documentation, improve changelog --- CHANGELOG | 10 ++ src/doc/new-doc/extensions/osi.txi | 144 +++++++++++++++++++++++++++-- 2 files changed, 146 insertions(+), 8 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 37f1c2c7..712ac421 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -29,6 +29,10 @@ * Pending changes since 16.1.3 ** Enhancements +- ext:run-program has been rewritten (almost) from scratch +- improved documentation of operating system interface (newdoc) +- example of parsing arguments in standalone executable (newdoc) +- example of using shared libraries from C world (newdoc) - reduced =format= directive tables size - simplified =atan2= implementation by using c99 equivalent :: Now we produce correct output for signed zeros, infinities and nans. @@ -36,8 +40,14 @@ =--with-libgc-incdir= and =--with-libgc-libdir= (these flags work the same as flags for =libffi= and =libgmp=) ** Issues fixed +- interactive input stream in ext:run-program on Windows +- removed race condition between waitpid and sigchld handler on UNIX - buildsystem parallel builds work (i.e make -j999) - ECL builds on consoles with unusual encodings on Windows (i.e cp936) +** API changes +- No more explicit option in =main.d= to trap SIGCHLD asynchronously. +- Zombie processes are cleaned in external-process finalizer. If process is + referenced in the memory, it's programmer duty to call wait on it. * 16.1.3 changes since 16.1.2 ** Announcement Dear Community, diff --git a/src/doc/new-doc/extensions/osi.txi b/src/doc/new-doc/extensions/osi.txi index 3c2f2fea..4b055bfa 100644 --- a/src/doc/new-doc/extensions/osi.txi +++ b/src/doc/new-doc/extensions/osi.txi @@ -2,12 +2,145 @@ @section Operating System Interface @menu +* Command line arguments:: * External processes:: -@c * Command line arguments:: @c * Signals and interrupts:: * Operating System Interface Reference:: @end menu +@cindex Command line processing +@node Command line arguments +@subsection Command line arguments +@deftypevar string ext:*help-message* +Command line help message. Initial value is ECL help message. This +variable contains the help message which is output when ECL is invoked +with the @code{--help}. +@end deftypevar + +@deftypevar list-of-pathname-designators ext:*lisp-init-file-list* +ECL initialization files. Initial value is @code{'("~/.ecl" +"~/.eclrc")}. This variable contains the names of initialization files +that are loaded by ECL or embedding programs. The loading of +initialization files happens automatically in ECL unless invoked with +the option @code{--norc}. Whether initialization files are loaded or +not is controlled by the command line options rules, as described in +@code{ext:process-command-args}. +@end deftypevar + +@deftypevar list-of-lists ext:+default-command-arg-rules+ +ECL command line options. This constant contains a list of rules for +parsing the command line arguments. This list is made of all the +options which ECL accepts by default. It can be passed as first +argument to @code{ext:process-command-args}, and you can use it as a +starting point to extend ECL. +@end deftypevar + +@defun ext:command-args +Original list of command line arguments. This function returns the +list of command line arguments passed to either ECL or the program it +was embedded in. The output is a list of strings and it corresponds to +the argv vector in a C program. Typically, the first argument is the +name of the program as it was invoked. You should not count on ths +filename to be resolved. +@end defun + +@defun ext:process-command-args &key args rules + +@defvr argument args +A list of strings. Defaults to the output of @code{ext:command-args}. +@end defvr +@defvr argument rules +A list of lists. Defaults to the value of +@code{ext:+default-command-arg-rules+}. +@end defvr + +This function processes the command line arguments passed to either +ECL or the program that embeds it. It uses the list of rules rules, +which has the following syntax: + +@code{(option-name nargs template [:stop | :noloadrc | :loadrc]*)} + +@defvr opt option-name +A string with the option prefix as typed by the user. For instance +@code{--help}, @code{-?}, @code{--compile}, etc. +@end defvr + +@defvr opt nargs +A non-negative integer denoting the number of arguments taken by this +option. +@end defvr + +@defvr opt template +A lisp form, not evaluated, where numbers from 0 to nargs will be +replaced by the corresponding option argument. +@end defvr + +@defvr opt :STOP +If present, parsing of arguments stops after this option is found and +processed. The list of remaining arguments is passed to the +rule. ECL's top-level uses this option with the @code{--} command line +option to set @code{ext:*unprocessed-ecl-command-args*} to the list of +remaining arguments. +@end defvr + +@defvr opt :NOLOADRC +@defvrx opt :LOADRC +Determine whether the lisp initalization file +@code{(ext:*lisp-init-file-list*)} will be loaded before processing +all forms. +@end defvr + +@code{ext:process-command-args} works as follows. First of all, it +parses all the command line arguments, except for the first one, which +is assumed to contain the program name. Each of these arguments is +matched against the rules, sequentially, until one of the patterns +succeeeds. + +A special name @code{*DEFAULT*}, matches any unknown command line +option. If there is no @code{*DEFAULT*} rule and no match is found, an +error is signalled. For each rule that succeeds, the function +constructs a lisp statement using the template. + +After all arguments have been processed, +@code{ext:process-command-args}, and there were no occurences of +@code{:noloadrc}, one of the files listed in +@code{ext:*lisp-init-file-list*} will be loaded. Finally, the list of +lisp statements will be evaluated. +@end defun + +@cindex Parsing arguments in standalone executable +@exindex LS implementation + +The following piece of code implements the ls command using +lisp. Instructions for building this program are found under +@code{ecl/examples/cmdline/ls.lsp}. + +@lisp +@verbatim +(setq ext:*help-message* " +ls [--help | -?] filename* + Lists the file that match the given patterns. +") + +(defun print-directory (pathnames) + (format t "~{~A~%~}" + (mapcar #'(lambda (x) (enough-namestring x (si::getcwd))) + (mapcan #'directory (or pathnames '("*.*" "*/")))))) + +(defconstant +ls-rules+ + '(("--help" 0 (progn (princ ext:*help-message* *standard-output*) (ext:quit 0))) + ("-?" 0 (progn (princ ext:*help-message* *standard-output*) (ext:quit 0))) + ("*DEFAULT*" 1 (print-directory 1) :stop))) + +(let ((ext:*lisp-init-file-list* NIL)) ; No initialization files + (handler-case (ext:process-command-args :rules +ls-rules+) + (error (c) + (princ ext:*help-message* *error-output*) + (ext:quit 1)))) +(ext:quit 0) +@end verbatim +@end lisp + @cindex External processes @node External processes @subsection External processes @@ -41,7 +174,7 @@ Updates process status. @code{ext:external-process-status} calls it is a signal code. Otherwise NIL. @end defun -@defunx ext:external-process-wait proces wait +@defun ext:external-process-wait proces wait If the second argument is non-NIL, function blocks until external process is finished. Otherwise status is updated. Returns two values (see @code{ext:external-process-status}). @@ -154,11 +287,6 @@ Controls escaping of the arguments passed to CreateProcess. @c environment routines -@defun ext:command-args -Returns the original command line arguments as list. First argument is -the ECL program itself. -@end defun - @c Don't advertise argc and argv, we have command-args @c @defun ext:argc @@ -176,7 +304,7 @@ Creates a pipe and wraps it in a two way stream. @end defun -@defun ext:quit &optional code kill-all-threads +@defun ext:quit &optional exit-code kill-all-threads This function abruptly stops the execution of the program in which ECL is embedded. Depending on the platform, several other functions will be invoked to free resources, close loaded modules, etc.