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 8e5e43acb..0b754a19e 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 859121c5b..071e54fbe 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 926c6df87..cf9c0cbae 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 1ceb826b4..d43cf24eb 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 cabc76723..87e1fb5d6 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 5956b9034..c5a988d7f 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 9a512c0cd..7f18783a8 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 14381a6f7..1d292080a 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 1d292080a..9fa39561b 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 87e1fb5d6..69eead536 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 b824409ac..97ef8aeae 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 61a37a6cc..00c8f6606 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 9fa39561b..20baf669c 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 071e54fbe..2609282b0 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 2609282b0..3f11c646b 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 cf9c0cbae..9ffdf1073 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 69eead536..cedcdafb3 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 20baf669c..60e44d601 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 cedcdafb3..251d3c192 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 7e956a27e..6ea89df53 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 9fe66b5c5..42813d01f 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 7f18783a8..f37106713 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 60e44d601..15d7533c6 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 251d3c192..218d1276e 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 218d1276e..a03f92fd7 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 f37106713..3c4d2c757 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 3f11c646b..ccf974086 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 9ffdf1073..3e3e5e24f 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 a03f92fd7..7d89d8a39 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 15d7533c6..0b1f55c58 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 0b1f55c58..8e306af00 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 8e306af00..545f10acf 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 ec3bd7833..678fdf2e4 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 ccf974086..904ae9f67 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 3e3e5e24f..47850587e 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 7d89d8a39..4896f97c0 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 42813d01f..aecf456d7 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 c5a988d7f..ac8160277 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 3c4d2c757..f7209c22b 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 545f10acf..fdfe900be 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 4896f97c0..094463d39 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 094463d39..394d694c5 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 fdfe900be..7dee9afc7 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 7dee9afc7..86df1141a 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 904ae9f67..d3d541018 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 47850587e..498157399 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 394d694c5..35cf02a31 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 00c8f6606..b75c02b38 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 86df1141a..fc9d3ac4f 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 d3d541018..73447a059 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 498157399..a737ccaf8 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 35cf02a31..ca35bf20d 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 aecf456d7..1e2d57097 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 ac8160277..261b8dd6f 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 d43cf24eb..8ffc19c0e 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 fc9d3ac4f..c48ea3996 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 c48ea3996..762e48626 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 8ffc19c0e..a35db62a3 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 762e48626..e71e5595a 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 73447a059..5bcb1f935 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 a737ccaf8..671ce0c9e 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 e71e5595a..126bde20d 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 ca35bf20d..c354c7154 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 126bde20d..d76a45f38 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 d76a45f38..eb79fedd1 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 eb79fedd1..dfb1e2c1a 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 5bcb1f935..26cebde16 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 671ce0c9e..43c041a0a 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 c354c7154..9bf76838b 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 dfb1e2c1a..99c7dfd15 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 000000000..bb6de41cd --- /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 9a12e1174..bab5acfc3 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 03957aecf..963294b3a 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 8203eab14..f2ddf9a73 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 000000000..bcbaa9c2d --- /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 bcbaa9c2d..c038ad711 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 bb6de41cd..c0efd5da9 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 c038ad711..aae6c52f6 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 99c7dfd15..d98bbb130 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 678949af8..ffd467374 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 d98bbb130..4c0d3be4f 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 97ef8aeae..81eccbb4a 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 aae6c52f6..25550fbf0 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 25550fbf0..aae6c52f6 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 9bf76838b..9703b2a05 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 81eccbb4a..648a8f449 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 4c0d3be4f..8cc16a216 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 9703b2a05..e364fd993 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 8cc16a216..f3c411f94 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 e364fd993..ec71df376 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 f3c411f94..77c5b4305 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 648a8f449..e54bf266c 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 8465ef51e..3d05a50e6 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 aae6c52f6..c622bd90e 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 c622bd90e..c27bc1b0b 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 d8bcbfd1f..cc7f8bf32 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 071e06591..13b6b5715 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 c27bc1b0b..13890743d 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 13890743d..d485a0231 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 8056742ed..c2f443f15 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 d485a0231..40983202b 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 ec71df376..b54a31cb0 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 c2f443f15..0e2a5064e 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 545952727..493ca8ec1 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 40983202b..efa547fdf 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 b54a31cb0..6d983c1fc 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 6d983c1fc..90ed32b10 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 26cebde16..84851385a 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 43c041a0a..a64c40c4f 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 90ed32b10..7e4fcdee0 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 0e2a5064e..6644ca2dc 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 efa547fdf..7771701aa 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 7771701aa..5ddd1570c 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 0b754a19e..16bda2905 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 6644ca2dc..ee999cc29 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 ee999cc29..88588edb9 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 e54bf266c..013bdd481 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 88588edb9..f4f45fa59 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 a35db62a3..ced8a31da 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -851,11 +851,6 @@ do_catch_signal(int code, cl_object action, cl_object process) else if (code == SIGILL) { mysignal(SIGILL, evil_signal_handler); } -#endif -#ifdef SIGCHLD - else if (code == SIGCHLD) { - mysignal(SIGCHLD, evil_signal_handler); - } #endif else { mysignal(code, non_evil_signal_handler); diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index f4f45fa59..46d787b84 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -7,43 +7,18 @@ (in-package "EXT") -(defvar *active-processes* nil - "List of process structures for all active processes.") - -(defvar *active-processes-lock* - (mp:make-lock :recursive t :name "Lock for active processes.")) - -;;; *ACTIVE-PROCESSES* can be accessed from multiple threads so a -;;; mutex is needed. More importantly the sigchld signal handler also -;;; accesses it, that's why we need without-interrupts. -(defmacro with-active-processes-lock (&body body) - `(mp:without-interrupts - (mp:with-lock (*active-processes-lock*) - ,@body))) - -(defun sigchld-handler (&key process) - (declare (ignore process)) - (let (changed) - (with-active-processes-lock - (mapc (lambda (process) - (when (external-process-wait process nil) - (push process changed))) - ;; `external-process-wait' may modify `*active-processes*'. - (copy-list *active-processes*))) - (dolist (proc changed) - (let ((hook (external-process-status-hook proc))) - (when hook (funcall hook proc)))))) - - +(defmacro with-process-lock ((process) &body body) + `(mp:with-lock ((external-process-%lock process)) + ,@body)) (defstruct (external-process (:constructor make-external-process ())) pid input output error-stream - status-hook (%status :running) - (%code nil)) + (%code nil) + (%lock (mp:make-lock))) (defun external-process-status (external-process) (let ((status (external-process-%status external-process))) @@ -60,32 +35,24 @@ ;;; running :: (values (member :stopped :resumed :running) code pid) ;;; --------------------------------------------------------------------- (defun external-process-wait (process &optional wait) - (let ((pid (external-process-pid process))) - (when pid - (multiple-value-bind (status code pid) (si:waitpid pid wait) - (ecase status - ((:exited :signaled :abort :error) - (with-active-processes-lock - (setf *active-processes* (delete process *active-processes*) - (external-process-pid process) nil + (with-process-lock (process) + (let ((pid (external-process-pid process))) + (when pid + (multiple-value-bind (status code pid) (si:waitpid pid wait) + (ecase status + ((:exited :signaled :abort :error) + (setf (external-process-pid process) nil (external-process-%status process) status - (external-process-%code process) code))) - ((:stopped :resumed :running) - (setf (external-process-%status process) status - (external-process-%code process) code)) - ((nil) #| wait was nil and process didn't change |#))))) + (external-process-%code process) code)) + ((:stopped :resumed :running) + (setf (external-process-%status process) status + (external-process-%code process) code)) + ((nil) #| wait was nil and process didn't change |#)))))) (values (external-process-%status process) (external-process-%code process))) -;;; This function isn't overly safe. Assuming `external-process-wait' -;;; is called after getting PID but before function sends signal, -;;; zombie may be already removed and we are shooting the -;;; air. Reasonable expectation here would be putting the burden on -;;; the user, that he can't call both functions in racy manner. We are -;;; protected from sigchld-handler here thanks to the global lock -;;; active processes. (defun terminate-process (process &optional force) - (with-active-processes-lock + (with-process-lock (process) (let ((pid (external-process-pid process))) (when pid #+windows @@ -130,20 +97,9 @@ (if-input-does-not-exist nil) (if-output-exists :error) (if-error-exists :error) - status-hook (external-format :default) #+windows (escape-arguments t)) - ;; XXX: we should install handler during loading of external-process - ;; module. Problem lies in fact, that handlers can't be installed - ;; before cl_boot finishes, so this form can't be top level in case - ;; when moudle is built-in. Good solution to that problem would be - ;; providing hook mechanism for functions to call after cl_boot. - ;; This way many modules may be easily untied from the core. - #-msvc - (unless (ext:get-signal-handler ext:+sigchld+) - (ext:set-signal-handler ext:+sigchld+ #'sigchld-handler)) - (labels ((process-stream (which default &rest args) (cond ((eql which t) default) @@ -192,16 +148,8 @@ (process (make-external-process)) pid parent-write parent-read parent-error) - (unless wait - (with-active-processes-lock (push process *active-processes*))) - - (handler-case (multiple-value-setq (pid parent-write parent-read parent-error) - (si:spawn-subprocess progname args environ input output error)) - (t (c) - (unless wait - (with-active-processes-lock - (setf *active-processes* (delete process *active-processes*)))) - (signal c))) + (multiple-value-setq (pid parent-write parent-read parent-error) + (si:spawn-subprocess progname args environ input output error)) (let ((stream-write (when (< 0 parent-write) @@ -215,8 +163,7 @@ (setf (external-process-pid process) pid (external-process-input process) (or stream-write (null-stream :output)) (external-process-output process) (or stream-read (null-stream :input)) - (external-process-error-stream process) (or stream-error (null-stream :input)) - (external-process-status-hook process) status-hook) + (external-process-error-stream process) (or stream-error (null-stream :input))) (values (make-two-way-stream (external-process-output process) (external-process-input process)) diff --git a/src/tests/normal-tests/run-program.lsp b/src/tests/normal-tests/run-program.lsp index 5ddd1570c..f92ddf661 100644 --- a/src/tests/normal-tests/run-program.lsp +++ b/src/tests/normal-tests/run-program.lsp @@ -135,22 +135,3 @@ (is-not (zerop (length (get-output-stream-string error-stream)))) (mapc #'close (list output-stream error-stream)))) - -#-windows -(test sigchld-handler - (let ((x 0)) - (flet ((status-hook (process) - (incf x))) - (with-run-program (heartbeat nil :status-hook #'status-hook) - (si:killpid (ext:external-process-pid process) ext:+sigstop+) - (sleep 1) - (si:killpid (ext:external-process-pid process) ext:+sigcont+) - (sleep 1) - (ext:terminate-process process) - (sleep 1)) - #-cygwin - (is (= x 3) "X is ~s, should be 3." x) - ;; XXX: cygwin quirk: sigchld isn't called for suspend/resume on - ;; cygwin (but they work - process is suspended/resumed) - #+cygwin - (is (= x 1) "X is ~s, should be 1." x)))) 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 46d787b84..04f23b502 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 04f23b502..2ef1e7b4e 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 2ef1e7b4e..b5e7c5e01 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 b5e7c5e01..d74a735ab 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 d74a735ab..898fa7a06 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 7e4fcdee0..a5fc15e18 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 898fa7a06..b608c3746 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 a5fc15e18..04dd0c651 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 67625893c..33a961bac 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 000000000..3f47d8376 --- /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 000000000..a2ee473d3 --- /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 a2ee473d3..f0848a864 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 f0848a864..3c2f2feae 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 37f1c2c76..712ac4213 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 3c2f2feae..4b055bfa6 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.