From bdda16a4618acab35ccc762720fd7a31848e162b Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 22:57:02 +0700 Subject: [PATCH] flan run's program dies with flan, and a program killed by a signal ends flan run with 128 plus its number --- bin/main.ml | 10 +++---- lib/build.ml | 14 ++++++++-- lib/dune | 2 +- lib/spawn.ml | 6 +++++ lib/spawn_stubs.c | 58 +++++++++++++++++++++++++++++++++++++++++ test/test_acceptance.ml | 9 +++++++ 6 files changed, 90 insertions(+), 9 deletions(-) create mode 100644 lib/spawn.ml create mode 100644 lib/spawn_stubs.c diff --git a/bin/main.ml b/bin/main.ml index 78ad8cef..324fced9 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -954,11 +954,9 @@ let () = removes the executable and its work directory: the default action would end flan inside the wait with neither removed. SIGINT and SIGQUIT are ignored while the program runs, as [system] does, since - the terminal sends them to the program too. *) - let pid = - Unix.create_process exe (Array.of_list (exe :: prog_args)) - Unix.stdin Unix.stdout Unix.stderr - in + the terminal sends them to the program too. A flan killed outright + takes the program with it ([Spawn.dying]). *) + let pid = Flan.Spawn.dying exe (Array.of_list (exe :: prog_args)) in let caught = ref None in let forward s = Sys.Signal_handle (fun _ -> @@ -972,7 +970,7 @@ let () = let rec wait () = match Unix.waitpid [] pid with | _, Unix.WEXITED c -> c - | _, (Unix.WSIGNALED _ | Unix.WSTOPPED _) -> 255 + | _, (Unix.WSIGNALED s | Unix.WSTOPPED s) -> 128 + Flan.Spawn.host_signal s | exception Unix.Unix_error (Unix.EINTR, _, _) -> wait () in let code = wait () in diff --git a/lib/build.ml b/lib/build.ml index 9b25b1d9..f52fb648 100644 --- a/lib/build.ml +++ b/lib/build.ml @@ -64,8 +64,18 @@ let workdir () = workdir_exit := Some d; let pid = Unix.getpid () in at_exit (fun () -> - if Unix.getpid () = pid then - try Unix.rmdir d with Unix.Unix_error _ -> ()) + if Unix.getpid () = pid then begin + (* The dyn header [compile_c] leaves for every compile in the process + to include, and not a build's own: gone when it is all that is + left, kept beside a failed build's C that includes it. *) + (match Sys.readdir d with + | [| "flan_dyn.h" |] -> + (try Unix.unlink (Filename.concat d "flan_dyn.h") + with Unix.Unix_error _ -> ()) + | _ -> () + | exception Sys_error _ -> ()); + try Unix.rmdir d with Unix.Unix_error _ -> () + end) end; d diff --git a/lib/dune b/lib/dune index c2d5b71a..be79d9f4 100644 --- a/lib/dune +++ b/lib/dune @@ -13,7 +13,7 @@ ; only C the compiler itself is built from. See lib/dynload_stubs.c. (foreign_stubs (language c) - (names dynload_stubs)) + (names dynload_stubs spawn_stubs)) ; No (c_library_flags (-ldl)): since glibc 2.34 dlopen lives in libc itself ; and libdl is a stub, and naming it breaks the merged build -- the partial ; link -output-complete-obj performs cannot resolve -ldl, so `flan dev` in diff --git a/lib/spawn.ml b/lib/spawn.ml new file mode 100644 index 00000000..85baac85 --- /dev/null +++ b/lib/spawn.ml @@ -0,0 +1,6 @@ +(** Starting a program that dies with this process; see spawn_stubs.c. *) + +external dying : string -> string array -> int = "flan_spawn_dying" + +(** The host number of an OCaml signal number. *) +external host_signal : int -> int = "flan_host_signal" diff --git a/lib/spawn_stubs.c b/lib/spawn_stubs.c new file mode 100644 index 00000000..f8ab49a0 --- /dev/null +++ b/lib/spawn_stubs.c @@ -0,0 +1,58 @@ +/* Starting a program that dies with the process that started it. + * + * `flan run` builds a program, runs it and deletes it. A flan killed by + * SIGKILL runs nothing on the way out, so without this the program would go on + * running with nobody waiting for it. On Linux the child asks the kernel for + * SIGKILL when its parent dies, between the fork and the exec; elsewhere it is + * an ordinary fork and exec. + */ + +#include +#include +#include +#include +/* Exported by the runtime, declared only under CAML_INTERNALS. */ +extern int caml_convert_signal_number(int); +#include +#include +#include +#include +#include +#ifdef __linux__ +#include +#endif + +value flan_spawn_dying(value path, value argv) { + CAMLparam2(path, argv); + mlsize_t n = Wosize_val(argv), i; + char **args = malloc((n + 1) * sizeof(char *)); + char *file = strdup(String_val(path)); + pid_t parent = getpid(), pid; + if (args == NULL || file == NULL) caml_failwith("flan_spawn_dying: out of memory"); + for (i = 0; i < n; i++) args[i] = strdup(String_val(Field(argv, i))); + args[n] = NULL; + pid = fork(); + if (pid == 0) { + sigset_t none; + sigemptyset(&none); + sigprocmask(SIG_SETMASK, &none, NULL); +#ifdef __linux__ + prctl(PR_SET_PDEATHSIG, SIGKILL); + /* The parent may have died before the request was made. */ + if (getppid() != parent) _exit(137); +#endif + execv(file, args); + _exit(127); + } + for (i = 0; i < n; i++) free(args[i]); + free(args); + free(file); + if (pid < 0) caml_failwith(strerror(errno)); + CAMLreturn(Val_int(pid)); +} + +/* OCaml numbers the signals it knows by negative constants; a shell's exit + * status wants the host's number. */ +value flan_host_signal(value s) { + return Val_int(caml_convert_signal_number(Int_val(s))); +} diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index dd1821ca..1d8b7ed1 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -7316,6 +7316,15 @@ level "1" (Printf.sprintf "run %s" (Filename.quote nomain)) ~code:1 ~says:[ "has no main"; "(defn main [] i32" ]; Sys.remove nomain; + (* A program killed by a signal ends [flan run] with the shell's + 128 + n for it, SIGSEGV's 139 here, not a flat 255. *) + let killed = Filename.concat scratch "killed.flan" in + Out_channel.with_open_bin killed (fun oc -> + output_string oc + "(declare-c raise [s i32] i32 \"raise\")\n(defn main [] i32 (raise 11))\n"); + cli_case "run of a program killed by a signal exits 128 + n" + (Printf.sprintf "run %s" (Filename.quote killed)) ~code:139 ~says:[]; + Sys.remove killed; (* Every row above that went through the pool has been forked; nothing after this point may look at [failures] until every one of them has