From d49f49ee0033ae4c1411eb5f6ed284e884f5041f Mon Sep 17 00:00:00 2001 From: Christopher Albert Date: Mon, 18 May 2026 23:39:49 +0200 Subject: [PATCH 1/2] perf: spawn Fortran compile commands directly --- src/filesystem_utilities.c | 87 ++++++++++++++++++++++++++++++++ src/fpm_compiler.F90 | 60 ++++++++++++++++++++-- src/fpm_filesystem.F90 | 100 ++++++++++++++++++++++++++++++++++++- 3 files changed, 242 insertions(+), 5 deletions(-) diff --git a/src/filesystem_utilities.c b/src/filesystem_utilities.c index 73f0c8aaa9..e362fe81d7 100644 --- a/src/filesystem_utilities.c +++ b/src/filesystem_utilities.c @@ -1,6 +1,18 @@ #include #include +#ifndef _WIN32 +#include +#include +#include +#include +#include +#include +#include + +extern char **environ; +#endif + #if defined(__APPLE__) && !defined(__aarch64__) && !defined(__ppc__) && !defined(__i386__) DIR * opendir$INODE64( const char * dirName ); struct dirent * readdir$INODE64( DIR * dir ); @@ -29,3 +41,78 @@ struct dirent *c_readdir(DIR *dirp) { return readdir(dirp); } + +int c_run_argv(const char *joined, int argc, const char *redirect) +{ +#ifdef _WIN32 + (void)joined; + (void)argc; + (void)redirect; + return -1; +#else + char **argv = NULL; + const char *p = joined; + pid_t pid; + int spawn_status; + int wait_status; + int i; + int use_redirect = redirect != NULL && redirect[0] != '\0'; + posix_spawn_file_actions_t actions; + posix_spawn_file_actions_t *actions_ptr = NULL; + + if (argc < 1) { + return 0; + } + + argv = calloc((size_t)argc + 1, sizeof(char *)); + if (argv == NULL) { + return -1; + } + + for (i = 0; i < argc; ++i) { + argv[i] = (char *)p; + p += strlen(p) + 1; + } + + if (use_redirect) { + if (posix_spawn_file_actions_init(&actions) != 0) { + free(argv); + return -1; + } + actions_ptr = &actions; + if (posix_spawn_file_actions_addopen(&actions, STDOUT_FILENO, redirect, + O_WRONLY | O_CREAT | O_TRUNC, 0666) != 0 || + posix_spawn_file_actions_adddup2(&actions, STDOUT_FILENO, STDERR_FILENO) != 0) { + posix_spawn_file_actions_destroy(&actions); + free(argv); + return -1; + } + } + + spawn_status = posix_spawnp(&pid, argv[0], actions_ptr, NULL, argv, environ); + if (use_redirect) { + posix_spawn_file_actions_destroy(&actions); + } + free(argv); + + if (spawn_status != 0) { + return spawn_status; + } + + do { + spawn_status = waitpid(pid, &wait_status, 0); + } while (spawn_status < 0 && errno == EINTR); + + if (spawn_status < 0) { + return -1; + } + + if (WIFEXITED(wait_status)) { + return WEXITSTATUS(wait_status); + } + if (WIFSIGNALED(wait_status)) { + return 128 + WTERMSIG(wait_status); + } + return -1; +#endif +} diff --git a/src/fpm_compiler.F90 b/src/fpm_compiler.F90 index 711f13aae3..cc62e34b8c 100644 --- a/src/fpm_compiler.F90 +++ b/src/fpm_compiler.F90 @@ -40,7 +40,7 @@ module fpm_compiler OS_UNKNOWN, & library_filename use fpm_filesystem, only: join_path, basename, get_temp_filename, delete_file, unix_path, & - & getline, run + & getline, run, run_argv use fpm_strings, only: split, string_cat, string_t, str_ends_with, str_begins_with_str, & & string_array_contains, lower, add_strings use fpm_error, only: error_t, fatal_error, fpm_stop @@ -1427,8 +1427,11 @@ subroutine compile_fortran(self, input, output, args, log_file, stat, table, dry logical, optional, intent(in) :: dry_run character(len=:), allocatable :: command + character(len=:), allocatable :: parts(:) + type(string_t), allocatable :: argv(:) type(error_t), allocatable :: error - logical :: mock + logical :: mock, tokenized + integer :: i ! Initialize intent(out) status so the mock path with no table returns ! a defined value. @@ -1440,10 +1443,41 @@ subroutine compile_fortran(self, input, output, args, log_file, stat, table, dry ! Set command command = self%fc // " -c " // input // " " // args // " -o " // output + tokenized = .true. + !$omp critical(fpm_shlex_split) + parts = sh_split(self%fc, join_spaced=.false., keep_quotes=.false., success=tokenized) + !$omp end critical(fpm_shlex_split) + if (tokenized) then + do i = 1, size(parts) + if (len_trim(parts(i)) == 0) cycle + call add_strings(argv, string_t(clean_shlex_token(parts(i)))) + end do + call add_strings(argv, string_t("-c")) + call add_strings(argv, string_t(input)) + end if + if (tokenized .and. len_trim(args) > 0) then + !$omp critical(fpm_shlex_split) + parts = sh_split(args, join_spaced=.true., keep_quotes=.true., success=tokenized) + !$omp end critical(fpm_shlex_split) + if (tokenized) then + do i = 1, size(parts) + if (len_trim(parts(i)) == 0) cycle + call add_strings(argv, string_t(clean_shlex_token(parts(i)))) + end do + end if + end if + if (tokenized) then + call add_strings(argv, string_t("-o")) + call add_strings(argv, string_t(output)) + end if ! Execute command if (.not.mock) then - call run(command, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) + if (tokenized) then + call run_argv(argv, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) + else + call run(command, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) + end if if (stat/=0) return endif @@ -1453,6 +1487,26 @@ subroutine compile_fortran(self, input, output, args, log_file, stat, table, dry stat = merge(-1,0,allocated(error)) endif +contains + + function clean_shlex_token(token) result(clean) + character(len=*), intent(in) :: token + character(len=:), allocatable :: clean + + integer :: j + + clean = "" + do j = 1, len_trim(token) + select case (token(j:j)) + case ("'", '"') + cycle + case default + clean = clean//token(j:j) + end select + end do + clean = trim(adjustl(clean)) + end function clean_shlex_token + end subroutine compile_fortran diff --git a/src/fpm_filesystem.F90 b/src/fpm_filesystem.F90 index 6b22f498f9..5a2f848096 100644 --- a/src/fpm_filesystem.F90 +++ b/src/fpm_filesystem.F90 @@ -8,7 +8,7 @@ module fpm_filesystem OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD use fpm_environment, only: separator, get_env, os_is_unix use fpm_strings, only: f_string, replace, string_t, split, split_lines_first_last, dilate, add_strings, & - str_begins_with_str + str_begins_with_str, string_cat use iso_c_binding, only: c_char, c_ptr, c_int, c_null_char, c_associated, c_f_pointer use fpm_error, only : fpm_stop, error_t, fatal_error implicit none @@ -16,7 +16,7 @@ module fpm_filesystem public :: basename, canon_path, dirname, is_dir, join_path, number_of_rows, list_files, get_local_prefix, & mkdir, exists, get_temp_filename, windows_path, unix_path, getline, delete_file, fileopen, fileclose, & filewrite, warnwrite, parent_dir, is_hidden_file, read_lines, read_lines_expanded, which, run, & - os_delete_dir, is_absolute_path, get_home, execute_and_read_output, get_dos_path + run_argv, os_delete_dir, is_absolute_path, get_home, execute_and_read_output, get_dos_path #ifndef FPM_BOOTSTRAP interface @@ -49,6 +49,13 @@ function c_is_dir(path) result(r) bind(c, name="c_is_dir") character(kind=c_char), intent(in) :: path(*) integer(kind=c_int) :: r end function c_is_dir + + function c_run_argv(joined, argc, redirect) result(r) bind(c, name="c_run_argv") + import c_char, c_int + character(kind=c_char), intent(in) :: joined(*), redirect(*) + integer(kind=c_int), intent(in), value :: argc + integer(kind=c_int) :: r + end function c_run_argv end interface #endif @@ -1060,6 +1067,95 @@ subroutine run(cmd,echo,exitstat,verbose,redirect) end subroutine run +subroutine run_argv(args,echo,exitstat,verbose,redirect) + type(string_t), intent(in) :: args(:) + logical,intent(in),optional :: echo + integer, intent(out),optional :: exitstat + logical, intent(in), optional :: verbose + character(*), intent(in), optional :: redirect + + character(:), allocatable :: command + character(:), allocatable :: joined + character(:), allocatable :: redirect_file + character(:), allocatable :: line + character(len=256) :: iomsg + logical :: echo_local, verbose_local + integer :: stat, fh, iostat, i + + command = string_cat(args, " ") + + if(present(echo))then + echo_local=echo + else + echo_local=.true. + end if + + if(present(verbose))then + verbose_local=verbose + else + verbose_local=.true. + end if + + if (present(redirect)) then + redirect_file = redirect + else + if(verbose_local)then + redirect_file = "" + else + if (os_is_unix()) then + redirect_file = "/dev/null" + else + redirect_file = "NUL" + end if + end if + end if + + if(echo_local) print *, '+ ', command + + if (size(args) < 1) then + stat = 0 +#ifndef FPM_BOOTSTRAP + elseif (os_is_unix()) then + joined = "" + do i = 1, size(args) + joined = joined//args(i)%s//c_null_char + end do + stat = c_run_argv(joined//c_null_char, int(size(args), c_int), & + redirect_file//c_null_char) +#endif + else + call run(command, echo=.false., verbose=verbose_local, redirect=redirect_file, exitstat=stat) + end if + + if (stat < 0) then + call run(command, echo=.false., verbose=verbose_local, redirect=redirect_file, exitstat=stat) + end if + + if (verbose_local.and.present(redirect)) then + + open(newunit=fh,file=redirect,status='old',iostat=iostat,iomsg=iomsg) + if(iostat == 0)then + do + call getline(fh, line, iostat) + if (iostat /= 0) exit + write(*,'(A)') trim(line) + end do + else + write(*,'(A)') trim(iomsg) + endif + + close(fh) + + end if + + if (present(exitstat)) then + exitstat = stat + elseif (stat /= 0) then + call fpm_stop(stat,'*run_argv*: Command '//command//' returned a non-zero status code') + end if + +end subroutine run_argv + !> Delete directory using system OS remove directory commands subroutine os_delete_dir(is_unix, dir, echo) logical, intent(in) :: is_unix From e4670a501899d1781687b173905719bd59ea7bfb Mon Sep 17 00:00:00 2001 From: Christopher Albert Date: Thu, 4 Jun 2026 00:07:11 +0200 Subject: [PATCH 2/2] feat: exec compiler via argv on Windows too Extend the argv-based Fortran compile spawn to Windows so it no longer falls back to the shell there. Tokenize with the OS-native lexer (ms_split on Windows, sh_split on Unix) so backslash paths and quoting survive, route run_argv through c_run_argv on both platforms, and add a CreateProcessA path with per-process stdout/stderr redirect. The shell run remains as a fallback when the spawn returns a negative status. Windows std handles are only overridden when redirecting, to avoid stripping the child console; out-of-range child exit codes are clamped positive so they are not mistaken for the spawn-failure sentinel. --- src/filesystem_utilities.c | 154 ++++++++++++++++++++++++++++++++++++- src/fpm_compiler.F90 | 60 ++++++++++----- src/fpm_filesystem.F90 | 6 +- 3 files changed, 195 insertions(+), 25 deletions(-) diff --git a/src/filesystem_utilities.c b/src/filesystem_utilities.c index e362fe81d7..f398119a2b 100644 --- a/src/filesystem_utilities.c +++ b/src/filesystem_utilities.c @@ -13,6 +13,12 @@ extern char **environ; #endif +#ifdef _WIN32 +#include +#include +#include +#endif + #if defined(__APPLE__) && !defined(__aarch64__) && !defined(__ppc__) && !defined(__i386__) DIR * opendir$INODE64( const char * dirName ); struct dirent * readdir$INODE64( DIR * dir ); @@ -42,13 +48,153 @@ struct dirent *c_readdir(DIR *dirp) return readdir(dirp); } +#ifdef _WIN32 +/* Quote one argv token using the CommandLineToArgvW rules so that + CreateProcess reconstructs the exact token. Caller frees the result. */ +static char *win_quote_arg(const char *arg) +{ + size_t len = strlen(arg); + size_t i; + int needs = (len == 0); + char *out; + char *q; + + for (i = 0; i < len; ++i) { + char c = arg[i]; + if (c == ' ' || c == '\t' || c == '\n' || c == '\v' || c == '"') { + needs = 1; + break; + } + } + + if (!needs) { + out = (char *)malloc(len + 1); + if (out) memcpy(out, arg, len + 1); + return out; + } + + out = (char *)malloc(2 * len + 3); + if (!out) return NULL; + q = out; + *q++ = '"'; + for (i = 0; i < len;) { + size_t nbs = 0; + size_t k; + while (i < len && arg[i] == '\\') { ++nbs; ++i; } + if (i == len) { + for (k = 0; k < 2 * nbs; ++k) *q++ = '\\'; + break; + } else if (arg[i] == '"') { + for (k = 0; k < 2 * nbs + 1; ++k) *q++ = '\\'; + *q++ = '"'; + ++i; + } else { + for (k = 0; k < nbs; ++k) *q++ = '\\'; + *q++ = arg[i++]; + } + } + *q++ = '"'; + *q = '\0'; + return out; +} +#endif + int c_run_argv(const char *joined, int argc, const char *redirect) { #ifdef _WIN32 - (void)joined; - (void)argc; - (void)redirect; - return -1; + const char *p = joined; + int i; + int use_redirect = redirect != NULL && redirect[0] != '\0'; + const char **argv = NULL; + char *cmd = NULL; + size_t cap = 1, n = 0; + char apppath[MAX_PATH]; + char *appname = NULL; + DWORD found; + HANDLE hout = INVALID_HANDLE_VALUE; + SECURITY_ATTRIBUTES sa; + STARTUPINFOA si; + PROCESS_INFORMATION pi; + BOOL ok; + int result; + + if (argc < 1) return 0; + + argv = (const char **)calloc((size_t)argc + 1, sizeof(char *)); + if (argv == NULL) return -1; + for (i = 0; i < argc; ++i) { + argv[i] = p; + p += strlen(p) + 1; + } + + /* Reassemble a properly quoted command line for CreateProcess. */ + cmd = (char *)malloc(cap); + if (cmd == NULL) { free((void *)argv); return -1; } + cmd[0] = '\0'; + for (i = 0; i < argc; ++i) { + char *qa = win_quote_arg(argv[i]); + size_t ql; + size_t need; + if (qa == NULL) { free(cmd); free((void *)argv); return -1; } + ql = strlen(qa); + need = n + ql + 2; + if (need > cap) { + char *t; + cap = need * 2; + t = (char *)realloc(cmd, cap); + if (t == NULL) { free(qa); free(cmd); free((void *)argv); return -1; } + cmd = t; + } + if (i > 0) cmd[n++] = ' '; + memcpy(cmd + n, qa, ql); + n += ql; + cmd[n] = '\0'; + free(qa); + } + + /* Resolve the program through PATH with a default .exe extension. */ + found = SearchPathA(NULL, argv[0], ".exe", MAX_PATH, apppath, NULL); + if (found > 0 && found < MAX_PATH) appname = apppath; + + ZeroMemory(&si, sizeof(si)); + si.cb = sizeof(si); + ZeroMemory(&pi, sizeof(pi)); + + /* Only override the child's std handles when redirecting. Setting + STARTF_USESTDHANDLES with the (often non-inheritable) console handles + can strip the child's console, so leave them alone otherwise and let + the child inherit the parent console normally. */ + if (use_redirect) { + ZeroMemory(&sa, sizeof(sa)); + sa.nLength = sizeof(sa); + sa.bInheritHandle = TRUE; + hout = CreateFileA(redirect, GENERIC_WRITE, FILE_SHARE_READ, &sa, + CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL); + if (hout == INVALID_HANDLE_VALUE) { free(cmd); free((void *)argv); return -1; } + si.dwFlags |= STARTF_USESTDHANDLES; + si.hStdInput = GetStdHandle(STD_INPUT_HANDLE); + si.hStdOutput = hout; + si.hStdError = hout; + } + + ok = CreateProcessA(appname, cmd, NULL, NULL, use_redirect, 0, NULL, NULL, &si, &pi); + if (!ok) { + result = -1; + } else { + DWORD code = 1; + WaitForSingleObject(pi.hProcess, INFINITE); + GetExitCodeProcess(pi.hProcess, &code); + CloseHandle(pi.hProcess); + CloseHandle(pi.hThread); + /* Keep a real (possibly high-bit) exit code positive so the caller + does not mistake it for the stat < 0 spawn-failure sentinel. */ + result = (code > 0x7fffffff) ? 1 : (int)code; + } + + if (hout != INVALID_HANDLE_VALUE) CloseHandle(hout); + free(cmd); + free((void *)argv); + return result; #else char **argv = NULL; const char *p = joined; diff --git a/src/fpm_compiler.F90 b/src/fpm_compiler.F90 index cc62e34b8c..214dd915ba 100644 --- a/src/fpm_compiler.F90 +++ b/src/fpm_compiler.F90 @@ -38,6 +38,7 @@ module fpm_compiler OS_FREEBSD, & OS_OPENBSD, & OS_UNKNOWN, & + os_is_unix, & library_filename use fpm_filesystem, only: join_path, basename, get_temp_filename, delete_file, unix_path, & & getline, run, run_argv @@ -1427,11 +1428,9 @@ subroutine compile_fortran(self, input, output, args, log_file, stat, table, dry logical, optional, intent(in) :: dry_run character(len=:), allocatable :: command - character(len=:), allocatable :: parts(:) type(string_t), allocatable :: argv(:) type(error_t), allocatable :: error logical :: mock, tokenized - integer :: i ! Initialize intent(out) status so the mock path with no table returns ! a defined value. @@ -1441,30 +1440,19 @@ subroutine compile_fortran(self, input, output, args, log_file, stat, table, dry mock = .false. if (present(dry_run)) mock = dry_run - ! Set command + ! Set command (shell fallback string) and build the argv token list. The + ! command is split with the OS-native lexer (POSIX on Unix, Windows rules + ! otherwise) so quoting and backslash paths survive on both platforms. command = self%fc // " -c " // input // " " // args // " -o " // output + tokenized = .true. - !$omp critical(fpm_shlex_split) - parts = sh_split(self%fc, join_spaced=.false., keep_quotes=.false., success=tokenized) - !$omp end critical(fpm_shlex_split) + call split_append(argv, self%fc, .false., .false., tokenized) if (tokenized) then - do i = 1, size(parts) - if (len_trim(parts(i)) == 0) cycle - call add_strings(argv, string_t(clean_shlex_token(parts(i)))) - end do call add_strings(argv, string_t("-c")) call add_strings(argv, string_t(input)) end if if (tokenized .and. len_trim(args) > 0) then - !$omp critical(fpm_shlex_split) - parts = sh_split(args, join_spaced=.true., keep_quotes=.true., success=tokenized) - !$omp end critical(fpm_shlex_split) - if (tokenized) then - do i = 1, size(parts) - if (len_trim(parts(i)) == 0) cycle - call add_strings(argv, string_t(clean_shlex_token(parts(i)))) - end do - end if + call split_append(argv, args, .true., .true., tokenized) end if if (tokenized) then call add_strings(argv, string_t("-o")) @@ -1489,6 +1477,40 @@ subroutine compile_fortran(self, input, output, args, log_file, stat, table, dry contains + !> Split a command fragment into argv tokens with the OS-native lexer and + !> append them to argv. fortran-shlex is not reentrant, so the split runs + !> in a critical region. join_spaced/keep_quotes apply to the POSIX lexer; + !> the Windows lexer already returns final argv tokens. + subroutine split_append(argv, str, join_spaced, keep_quotes, ok) + type(string_t), allocatable, intent(inout) :: argv(:) + character(len=*), intent(in) :: str + logical, intent(in) :: join_spaced, keep_quotes + logical, intent(inout) :: ok + + character(len=:), allocatable :: parts(:) + integer :: k + + if (.not.ok) return + + !$omp critical(fpm_shlex_split) + if (os_is_unix()) then + parts = sh_split(str, join_spaced=join_spaced, keep_quotes=keep_quotes, success=ok) + else + parts = ms_split(str, success=ok) + end if + !$omp end critical(fpm_shlex_split) + if (.not.ok) return + + do k = 1, size(parts) + if (len_trim(parts(k)) == 0) cycle + if (os_is_unix()) then + call add_strings(argv, string_t(clean_shlex_token(parts(k)))) + else + call add_strings(argv, string_t(trim(parts(k)))) + end if + end do + end subroutine split_append + function clean_shlex_token(token) result(clean) character(len=*), intent(in) :: token character(len=:), allocatable :: clean diff --git a/src/fpm_filesystem.F90 b/src/fpm_filesystem.F90 index 5a2f848096..91d18b8ba2 100644 --- a/src/fpm_filesystem.F90 +++ b/src/fpm_filesystem.F90 @@ -1115,18 +1115,20 @@ subroutine run_argv(args,echo,exitstat,verbose,redirect) if (size(args) < 1) then stat = 0 #ifndef FPM_BOOTSTRAP - elseif (os_is_unix()) then + else joined = "" do i = 1, size(args) joined = joined//args(i)%s//c_null_char end do stat = c_run_argv(joined//c_null_char, int(size(args), c_int), & redirect_file//c_null_char) -#endif +#else else call run(command, echo=.false., verbose=verbose_local, redirect=redirect_file, exitstat=stat) +#endif end if + ! Fall back to the shell if the argv spawn was unavailable or failed (stat < 0). if (stat < 0) then call run(command, echo=.false., verbose=verbose_local, redirect=redirect_file, exitstat=stat) end if