diff --git a/Makefile b/Makefile index 9ea6289aef30..ee98f2cdcd62 100644 --- a/Makefile +++ b/Makefile @@ -1134,6 +1134,7 @@ endif @echo "::endgroup::" clean: clean-stage1 clean-stage2 clean-stage3 + rm -f $(BUILD_DIR)/bin/ghc-throttle$(EXE_EXT) $(BUILD_DIR)/bin/ghc-throttle-status$(EXE_EXT) @echo "Not removing stage0 (cabal), use clean-stage0 to remove cabal too." clean-stage1: @@ -1167,6 +1168,42 @@ export SKIP_PERF_TESTS # --- Test Suite Helper Tool Paths & Flags (Hadrian parity light) --- # We approximate Hadrian's test invocation without depending on Hadrian. +# _ _ _ _ _ _ +# __ _| |__ ___ | |_| |__ _ __ ___ | |_| |_| | ___ +# / _` | '_ \ / __|____ | __| '_ \| '__/ _ \| __| __| |/ _ \ +# | (_| | | | | (_|_____|| |_| | | | | | (_) | |_| |_| | __/ +# \__, |_| |_|\___| \__|_| |_|_| \___/ \__|\__|_|\___| +# |___/ + +# GHC_THROTTLE_JOBS — max concurrent GHC processes (default: max(1, min(ncpus/2, 256))) +GHC_THROTTLE_JOBS ?= $(shell n=$$(( $(CPUS) / 2 )); n=$$(( n > 0 ? n : 1 )); echo $$(( n < 256 ? n : 256 ))) + +# Platform-conditional source selection for ghc-throttle. +# Use $(OS) which is set to "Windows_NT" on all Windows flavours +# (MSYS2, MinGW, native cmd), matching utils/ghc-throttle/Makefile. +ifeq ($(OS),Windows_NT) +GHC_THROTTLE_SRC := utils/ghc-throttle/ghc-throttle-win.c +GHC_THROTTLE_STATUS_SRC := utils/ghc-throttle/ghc-throttle-status-win.c +else +GHC_THROTTLE_SRC := utils/ghc-throttle/ghc-throttle.c +GHC_THROTTLE_STATUS_SRC := utils/ghc-throttle/ghc-throttle-status.c +endif + +.PHONY: ghc-throttle +ghc-throttle: $(GHC_THROTTLE_SRC) ## Build the GHC concurrency limiter + @mkdir -p $(BUILD_DIR)/bin + $(CC) -O2 -Wall -Wextra -pedantic $(CFLAGS) $(CPPFLAGS) $(LDFLAGS) -o $(BUILD_DIR)/bin/ghc-throttle$(EXE_EXT) $< + @echo "Built $(BUILD_DIR)/bin/ghc-throttle$(EXE_EXT) (default max jobs: $(GHC_THROTTLE_JOBS), override with GHC_THROTTLE_JOBS)" + @echo "Usage:" + @echo " export GHC_THROTTLE_GHC=\$$(which ghc-9.8.4)" + @echo " export GHC_THROTTLE_JOBS=$(GHC_THROTTLE_JOBS)" + @echo " make CABAL_ARGS=\"--with-compiler=\$$PWD/$(BUILD_DIR)/bin/ghc-throttle$(EXE_EXT)\" stage1" + +.PHONY: ghc-throttle-status +ghc-throttle-status: $(GHC_THROTTLE_STATUS_SRC) ## Build the throttle status tool + @mkdir -p $(BUILD_DIR)/bin + $(CC) -O2 -Wall -Wextra -pedantic $(CFLAGS) $(CPPFLAGS) $(LDFLAGS) -o $(BUILD_DIR)/bin/ghc-throttle-status$(EXE_EXT) $< + # $(CURDIR) is needed because the test recipe runs $(MAKE) -C testsuite/tests, # so relative paths would resolve from the wrong directory. This matters both # for CI and local `make test` invocations. diff --git a/utils/ghc-throttle/Makefile b/utils/ghc-throttle/Makefile new file mode 100644 index 000000000000..bd8a48de814c --- /dev/null +++ b/utils/ghc-throttle/Makefile @@ -0,0 +1,45 @@ +# utils/ghc-throttle/Makefile — Build ghc-throttle and status tool +# +# ghc-throttle is a transparent GHC concurrency limiter. +# POSIX (Linux, macOS, FreeBSD): uses flock() + exec() +# Windows: uses named mutexes + CreateProcess() +# +# This Makefile is for standalone builds in this directory. The top-level +# Makefile has its own targets that build into _build/bin/. + +CC ?= cc +CFLAGS ?= -O2 -Wall -Wextra -pedantic + +# Platform detection: select source files and executable extension. +ifeq ($(OS),Windows_NT) + THROTTLE_SRC := ghc-throttle-win.c + STATUS_SRC := ghc-throttle-status-win.c + EXE_EXT := .exe +else + THROTTLE_SRC := ghc-throttle.c + STATUS_SRC := ghc-throttle-status.c + EXE_EXT := +endif + +.PHONY: all clean help + +## ── Build ────────────────────────────────────────────────────────── + +all: ghc-throttle$(EXE_EXT) ghc-throttle-status$(EXE_EXT) ## Build both tools + +ghc-throttle$(EXE_EXT): $(THROTTLE_SRC) ## Build the GHC concurrency limiter + $(CC) $(CFLAGS) -o $@ $< + +ghc-throttle-status$(EXE_EXT): $(STATUS_SRC) ## Build the slot status reporter + $(CC) $(CFLAGS) -o $@ $< + +## ── Maintenance ──────────────────────────────────────────────────── + +clean: ## Remove built binaries + rm -f ghc-throttle ghc-throttle.exe ghc-throttle-status ghc-throttle-status.exe + +## ── Help ─────────────────────────────────────────────────────────── + +help: ## Show this help + @grep -E '^[a-zA-Z_-]+:.*## .*$$' $(MAKEFILE_LIST) | \ + awk 'BEGIN {FS = ":.*## "}; {printf " \033[36m%-24s\033[0m %s\n", $$1, $$2}' diff --git a/utils/ghc-throttle/ghc-throttle-status-win.c b/utils/ghc-throttle/ghc-throttle-status-win.c new file mode 100644 index 000000000000..20825bec63ce --- /dev/null +++ b/utils/ghc-throttle/ghc-throttle-status-win.c @@ -0,0 +1,165 @@ +/* + * ghc-throttle-status: Report current ghc-throttle slot usage (Windows) + * + * Licensed under the Apache License, Version 2.0. + * + * Probes named mutexes to report which slots are currently held. + * Unlike the POSIX version which scans lock files, Windows named mutexes + * cannot be enumerated — we probe slots 0..max_jobs-1 by name. + * + * Usage: + * ghc-throttle-status — probe default slot count + * ghc-throttle-status --help — show usage + * + * Note: Windows does not provide a way to determine which PID holds a + * named mutex, so holder information is not available. + */ + +#define WIN32_LEAN_AND_MEAN +#include +#include +#include +#include + +#define MAX_SLOTS 256 +#define MUTEX_NAME_BUF 64 + +/* -------------------------------------------------------------------------- + * CPU count detection + * -------------------------------------------------------------------------- */ + +static int get_ncpus(void) +{ + SYSTEM_INFO si; + GetSystemInfo(&si); + return (int)si.dwNumberOfProcessors > 0 ? (int)si.dwNumberOfProcessors : 2; +} + +/* -------------------------------------------------------------------------- + * Concurrency limit (needed to know how many slots to probe) + * -------------------------------------------------------------------------- */ + +static int get_max_jobs(void) +{ + const char *env = getenv("GHC_THROTTLE_JOBS"); + if (env && *env) { + char *end; + long val = strtol(env, &end, 10); + if (*end == '\0' && val > 0 && val <= MAX_SLOTS) + return (int)val; + fprintf(stderr, + "ghc-throttle-status: ignoring invalid GHC_THROTTLE_JOBS=%s\n", + env); + } + /* Default: half the CPUs, clamped to [1, MAX_SLOTS]. */ + int n = get_ncpus() / 2; + if (n <= 0) return 1; + return n <= MAX_SLOTS ? n : MAX_SLOTS; +} + +/* -------------------------------------------------------------------------- + * Help + * -------------------------------------------------------------------------- */ + +static void print_usage(void) +{ + printf("ghc-throttle-status: Report current ghc-throttle slot usage\n" + "\n" + "Usage:\n" + " ghc-throttle-status Show slot status\n" + " ghc-throttle-status --help|-h Show this help\n" + "\n" + "Environment:\n" + " GHC_THROTTLE_JOBS Max slots to probe (default: ncpus / 2)\n" + "\n" + "Note: On Windows, named mutexes are used instead of lock files.\n" + " PID-of-holder detection is not available.\n"); +} + +/* -------------------------------------------------------------------------- + * Slot probing + * -------------------------------------------------------------------------- */ + +int main(int argc, char *argv[]) +{ + if (argc > 1 && + (strcmp(argv[1], "--help") == 0 || strcmp(argv[1], "-h") == 0)) + { + print_usage(); + return 0; + } + + int max_jobs = get_max_jobs(); + int held = 0; + int nslots = 0; + + /* locked: 0 = free, 1 = locked, 2 = unknown (probe error) */ + struct slot_info { + int number; + int locked; + } slots[MAX_SLOTS]; + + for (int i = 0; i < max_jobs; i++) { + char name[MUTEX_NAME_BUF]; + _snprintf(name, sizeof(name), "Local\\ghc-throttle-slot-%d", i); + name[sizeof(name) - 1] = '\0'; + + /* Try to open the existing mutex (don't create one). + * Need SYNCHRONIZE for WaitForSingleObject and MUTEX_MODIFY_STATE + * for ReleaseMutex (when we acquire a free slot and release it). */ + HANDLE h = OpenMutexA(SYNCHRONIZE | MUTEX_MODIFY_STATE, FALSE, name); + if (h == NULL) { + DWORD err = GetLastError(); + if (err == ERROR_FILE_NOT_FOUND) { + /* Mutex doesn't exist — slot has never been used. */ + slots[nslots].number = i; + slots[nslots].locked = 0; + nslots++; + } else { + /* Other errors (e.g., access denied) — record as unknown. */ + fprintf(stderr, "ghc-throttle-status: cannot probe slot %d: " + "error %lu\n", i, (unsigned long)err); + slots[nslots].number = i; + slots[nslots].locked = 2; /* unknown */ + nslots++; + } + continue; + } + + /* Mutex exists — check if it's held by trying a zero-timeout wait. */ + DWORD result = WaitForSingleObject(h, 0); + slots[nslots].number = i; + + if (result == WAIT_OBJECT_0 || result == WAIT_ABANDONED) { + /* We acquired it — it was free. Release immediately. */ + ReleaseMutex(h); + slots[nslots].locked = 0; + } else if (result == WAIT_TIMEOUT) { + /* Mutex is held by another process. */ + slots[nslots].locked = 1; + held++; + } else { + /* WAIT_FAILED or unexpected result — record as unknown. */ + fprintf(stderr, "ghc-throttle-status: WaitForSingleObject slot %d " + "failed: %lu\n", i, (unsigned long)GetLastError()); + slots[nslots].locked = 2; /* unknown */ + } + + CloseHandle(h); + nslots++; + } + + printf("GHC Throttle: %d/%d slots in use [named mutexes]\n", + held, max_jobs); + for (int i = 0; i < nslots; i++) { + if (slots[i].locked == 1) { + printf(" slot.%-3d locked\n", slots[i].number); + } else if (slots[i].locked == 2) { + printf(" slot.%-3d unknown (probe failed)\n", slots[i].number); + } else { + printf(" slot.%-3d free\n", slots[i].number); + } + } + + return 0; +} diff --git a/utils/ghc-throttle/ghc-throttle-status.c b/utils/ghc-throttle/ghc-throttle-status.c new file mode 100644 index 000000000000..67caf317f8e8 --- /dev/null +++ b/utils/ghc-throttle/ghc-throttle-status.c @@ -0,0 +1,403 @@ +/* + * ghc-throttle-status: Report current ghc-throttle slot usage + * + * Licensed under the Apache License, Version 2.0. + * + * Scans the lock directory and reports which slots are currently held, + * and by which PID (where available). + * + * Usage: + * ghc-throttle-status — auto-detect lock dir + * ghc-throttle-status /path/to/dir — explicit lock dir + * ghc-throttle-status --help — show usage + */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#ifdef __APPLE__ +#include +#endif + +#ifdef __linux__ +#include /* makedev() */ +#endif + +#define PATH_BUF 4096 +#define MAX_SLOTS 256 + +#ifdef __APPLE__ +#include +#endif + +/* -------------------------------------------------------------------------- + * CPU count and configured capacity + * + * The status tool needs to know the configured max_jobs to report total + * capacity, even when not all slot files exist yet (they are created + * lazily by ghc-throttle on first use). + * -------------------------------------------------------------------------- */ + +static int get_ncpus(void) +{ +#ifdef __APPLE__ + int ncpu = 0; + size_t len = sizeof(ncpu); + if (sysctlbyname("hw.ncpu", &ncpu, &len, NULL, 0) == 0 && ncpu > 0) + return ncpu; +#else + long n = sysconf(_SC_NPROCESSORS_ONLN); + if (n > 0) + return (int)n; +#endif + return 2; +} + +static int get_max_jobs(void) +{ + const char *env = getenv("GHC_THROTTLE_JOBS"); + if (env && *env) { + char *end; + long val = strtol(env, &end, 10); + if (*end == '\0' && val > 0 && val <= MAX_SLOTS) + return (int)val; + fprintf(stderr, + "ghc-throttle-status: ignoring invalid GHC_THROTTLE_JOBS=%s\n", + env); + } + /* Default: half the CPUs, clamped to [1, MAX_SLOTS]. */ + int n = get_ncpus() / 2; + if (n <= 0) return 1; + return n <= MAX_SLOTS ? n : MAX_SLOTS; +} + +/* -------------------------------------------------------------------------- + * PID-of-lock-holder detection (best-effort) + * + * There is no portable way to get the PID that holds a flock. On Linux + * we can use /proc/locks; on macOS we simply report "unknown". + * -------------------------------------------------------------------------- */ + +#ifdef __linux__ +/* Cached /proc/locks entries for efficient batch lookup. + * Parsing /proc/locks once avoids repeated full scans when + * multiple slots are held. */ +struct lock_entry { + dev_t dev; + unsigned long long ino; + pid_t pid; +}; + +static struct lock_entry *lock_cache = NULL; +static int lock_cache_n = 0; + +static void load_lock_cache(void) +{ + FILE *fp = fopen("/proc/locks", "r"); + if (!fp) + return; + + char line[512]; + int cap = 64; + lock_cache = malloc(sizeof(struct lock_entry) * (size_t)cap); + if (!lock_cache) { fclose(fp); return; } + + while (fgets(line, sizeof(line), fp)) { + if (!strstr(line, "FLOCK")) + continue; + + pid_t pid = 0; + unsigned int maj = 0, min = 0; + unsigned long long lock_ino = 0; + + /* Example: "1: FLOCK ADVISORY WRITE 12345 08:01:654321 0 EOF" + * Use %llu for inode to avoid truncation on 32-bit platforms + * where ino_t may be 64-bit but unsigned long is 32-bit. */ + if (sscanf(line, "%*d: FLOCK %*s %*s %d %x:%x:%llu", + &pid, &maj, &min, &lock_ino) == 4) { + if (lock_cache_n >= cap) { + cap *= 2; + struct lock_entry *tmp = realloc(lock_cache, + sizeof(struct lock_entry) * (size_t)cap); + if (!tmp) break; + lock_cache = tmp; + } + lock_cache[lock_cache_n].dev = makedev(maj, min); + lock_cache[lock_cache_n].ino = lock_ino; + lock_cache[lock_cache_n].pid = pid; + lock_cache_n++; + } + } + fclose(fp); +} + +static pid_t find_lock_holder_linux(dev_t dev, ino_t ino) +{ + unsigned long long target_ino = (unsigned long long)ino; + for (int i = 0; i < lock_cache_n; i++) { + if (lock_cache[i].ino == target_ino && lock_cache[i].dev == dev) + return lock_cache[i].pid; + } + return 0; +} +#endif /* __linux__ */ + +static pid_t find_lock_holder(const char *path) +{ + struct stat st; + if (stat(path, &st) != 0) + return 0; + +#ifdef __linux__ + return find_lock_holder_linux(st.st_dev, st.st_ino); +#else + return 0; /* macOS: no easy way without lsof */ +#endif +} + +/* Get the command name for a PID (best-effort). */ +static int get_proc_name(pid_t pid, char *buf, size_t bufsz) +{ +#ifdef __APPLE__ + char pathbuf[PROC_PIDPATHINFO_MAXSIZE]; + if (proc_pidpath(pid, pathbuf, sizeof(pathbuf)) > 0) { + /* Extract basename. */ + const char *base = strrchr(pathbuf, '/'); + snprintf(buf, bufsz, "%s", base ? base + 1 : pathbuf); + return 0; + } +#elif defined(__linux__) + char cmdline_path[64]; + snprintf(cmdline_path, sizeof(cmdline_path), "/proc/%d/comm", (int)pid); + FILE *fp = fopen(cmdline_path, "r"); + if (fp) { + if (fgets(buf, (int)bufsz, fp)) { + /* Strip trailing newline. */ + size_t len = strlen(buf); + if (len > 0 && buf[len - 1] == '\n') + buf[len - 1] = '\0'; + fclose(fp); + return 0; + } + fclose(fp); + } +#else + (void)pid; + (void)buf; + (void)bufsz; +#endif + return -1; +} + +/* -------------------------------------------------------------------------- + * Lock directory detection + * -------------------------------------------------------------------------- */ + +/* Returns 0 on success, -1 if the path was truncated. */ +static int get_lock_dir(char *buf, size_t bufsz, const char *arg) +{ + int n; + if (arg) { + n = snprintf(buf, bufsz, "%s", arg); + } else { + const char *env = getenv("GHC_THROTTLE_DIR"); + if (env && *env) + n = snprintf(buf, bufsz, "%s", env); + else + n = snprintf(buf, bufsz, "/tmp/ghc-throttle-%u", (unsigned)getuid()); + } + if (n < 0 || (size_t)n >= bufsz) { + fprintf(stderr, "ghc-throttle-status: lock dir path too long\n"); + return -1; + } + return 0; +} + +/* -------------------------------------------------------------------------- + * Help + * -------------------------------------------------------------------------- */ + +static void print_usage(void) +{ + printf("ghc-throttle-status: Report current ghc-throttle slot usage\n" + "\n" + "Usage:\n" + " ghc-throttle-status Show slot status (auto-detect lock dir)\n" + " ghc-throttle-status Show slot status for given lock dir\n" + " ghc-throttle-status --help|-h Show this help\n" + "\n" + "Environment:\n" + " GHC_THROTTLE_DIR Lock directory (default: /tmp/ghc-throttle-$UID)\n"); +} + +/* -------------------------------------------------------------------------- + * Slot scanning + * -------------------------------------------------------------------------- */ + +int main(int argc, char *argv[]) +{ + /* Handle --help / -h. */ + if (argc > 1 && + (strcmp(argv[1], "--help") == 0 || strcmp(argv[1], "-h") == 0)) + { + print_usage(); + return 0; + } + + char lock_dir[PATH_BUF]; + if (get_lock_dir(lock_dir, sizeof(lock_dir), argc > 1 ? argv[1] : NULL) != 0) + return 1; + + DIR *dp = opendir(lock_dir); + if (!dp) { + if (errno == ENOENT) { + printf("GHC Throttle: no lock directory at %s (no active sessions)\n", + lock_dir); + return 0; + } + fprintf(stderr, "ghc-throttle-status: cannot open %s: %s\n", + lock_dir, strerror(errno)); + return 1; + } + +#ifdef __linux__ + /* Parse /proc/locks once upfront so lock-holder lookups are O(1). */ + load_lock_cache(); +#endif + + /* Collect slot info: we need to know total and held counts. */ + struct slot_info { + int number; + int locked; + pid_t holder; + char proc_name[128]; + } slots[MAX_SLOTS]; + int nslots = 0; + + struct dirent *ent; + while ((ent = readdir(dp)) != NULL) { + /* Parse "slot.NNN" with strtol for overflow safety (the directory + * may be user-supplied, so filenames are untrusted input). */ + if (strncmp(ent->d_name, "slot.", 5) != 0) + continue; + char *end; + long slot_long = strtol(ent->d_name + 5, &end, 10); + if (end == ent->d_name + 5 || *end != '\0') + continue; /* no digits or trailing garbage */ + if (slot_long < 0 || slot_long >= MAX_SLOTS) + continue; /* ignore out-of-range slot numbers */ + int slot_num = (int)slot_long; + if (nslots >= MAX_SLOTS) + break; + + char path[PATH_BUF]; + int pn = snprintf(path, sizeof(path), "%s/%s", lock_dir, ent->d_name); + if (pn < 0 || (size_t)pn >= sizeof(path)) + continue; /* path truncated, skip */ + + /* Verify it's a regular file before opening — in a user-supplied lock + * directory, a slot entry could be a FIFO or device that would block + * or cause side effects on open(). */ + { + struct stat fst; + if (lstat(path, &fst) != 0 || !S_ISREG(fst.st_mode)) + continue; + } + + /* Use O_RDWR for the flock probe — some BSD/macOS kernels require + * a writable fd for LOCK_EX even with LOCK_NB. */ + int fd = open(path, O_RDWR); + if (fd < 0) + continue; + + struct slot_info *si = &slots[nslots]; + si->number = slot_num; + si->proc_name[0] = '\0'; + + /* Try non-blocking lock to see if it's held. */ + if (flock(fd, LOCK_EX | LOCK_NB) == 0) { + /* We got it — slot was free. Unlock immediately. */ + flock(fd, LOCK_UN); + si->locked = 0; + si->holder = 0; + } else if (errno == EWOULDBLOCK || errno == EAGAIN) { + /* Slot is held by someone else. */ + si->locked = 1; + si->holder = find_lock_holder(path); + if (si->holder > 0) + get_proc_name(si->holder, si->proc_name, sizeof(si->proc_name)); + } else { + /* Unexpected flock error (ENOLCK, etc.) — skip this slot. */ + close(fd); + continue; + } + close(fd); + nslots++; + } + closedir(dp); + + /* Sort by slot number for stable output. */ + for (int i = 0; i < nslots - 1; i++) + for (int j = i + 1; j < nslots; j++) + if (slots[j].number < slots[i].number) { + struct slot_info tmp = slots[i]; + slots[i] = slots[j]; + slots[j] = tmp; + } + + /* Count held slots within the configured range only. */ + int max_jobs = get_max_jobs(); + int held = 0; + for (int j = 0; j < nslots; j++) + if (slots[j].locked && slots[j].number < max_jobs) + held++; + printf("GHC Throttle: %d/%d slots in use [%s]\n", held, max_jobs, lock_dir); + + /* Print all configured slots. For slots with existing lock files, use + * the probed status; for slots without files yet (lazily created), show + * as free. */ + for (int s = 0; s < max_jobs; s++) { + /* Find this slot in the scanned results. */ + struct slot_info *si = NULL; + for (int j = 0; j < nslots; j++) { + if (slots[j].number == s) { + si = &slots[j]; + break; + } + } + if (si && si->locked) { + if (si->holder > 0) { + if (si->proc_name[0]) + printf(" slot.%-3d locked (PID %d, %s)\n", + s, (int)si->holder, si->proc_name); + else + printf(" slot.%-3d locked (PID %d)\n", + s, (int)si->holder); + } else { + printf(" slot.%-3d locked\n", s); + } + } else { + printf(" slot.%-3d free\n", s); + } + } + /* Also show any slots beyond max_jobs that have existing files. */ + for (int j = 0; j < nslots; j++) { + if (slots[j].number >= max_jobs && slots[j].locked) { + printf(" slot.%-3d locked (beyond configured max)\n", + slots[j].number); + } + } + +#ifdef __linux__ + free(lock_cache); +#endif + return 0; +} diff --git a/utils/ghc-throttle/ghc-throttle-win.c b/utils/ghc-throttle/ghc-throttle-win.c new file mode 100644 index 000000000000..5563d28e2d79 --- /dev/null +++ b/utils/ghc-throttle/ghc-throttle-win.c @@ -0,0 +1,503 @@ +/* + * ghc-throttle: Transparent GHC concurrency limiter (Windows) + * + * Licensed under the Apache License, Version 2.0. + * + * Windows implementation using named mutexes. Unlike the POSIX version + * (which uses flock + exec), Windows cannot replace the current process + * image, so we hold the mutex while the child GHC runs via CreateProcess. + * + * Named mutexes are kernel objects that are automatically released when the + * owning process exits — crash-safe like flock() on POSIX. + * + * Environment variables: + * GHC_THROTTLE_GHC — path to the real GHC binary + * GHC_THROTTLE_JOBS — max concurrent GHC processes (default: ncpus / 2) + * GHC_THROTTLE_DEBUG — if set to "1", print diagnostics to stderr + */ + +#define WIN32_LEAN_AND_MEAN +#include +#include +#include +#include + +/* Maximum number of concurrency slots we ever allow. */ +#define MAX_SLOTS 256 + +/* Size of path buffers. */ +#define PATH_BUF 4096 + +/* Maximum length for a mutex name (Local\ghc-throttle-slot-NNN). */ +#define MUTEX_NAME_BUF 64 + +static int debug_enabled = 0; + +#define DBG(...) do { \ + if (debug_enabled) { \ + fprintf(stderr, "ghc-throttle[%lu]: ", (unsigned long)GetCurrentProcessId()); \ + fprintf(stderr, __VA_ARGS__); \ + fprintf(stderr, "\n"); \ + } \ +} while (0) + +/* -------------------------------------------------------------------------- + * CPU count detection + * -------------------------------------------------------------------------- */ + +static int get_ncpus(void) +{ + SYSTEM_INFO si; + GetSystemInfo(&si); + return (int)si.dwNumberOfProcessors > 0 ? (int)si.dwNumberOfProcessors : 2; +} + +/* -------------------------------------------------------------------------- + * Concurrency limit + * -------------------------------------------------------------------------- */ + +static int get_max_jobs(void) +{ + const char *env = getenv("GHC_THROTTLE_JOBS"); + if (env && *env) { + char *end; + long val = strtol(env, &end, 10); + if (*end == '\0' && val > 0 && val <= MAX_SLOTS) + return (int)val; + fprintf(stderr, "ghc-throttle: ignoring invalid GHC_THROTTLE_JOBS=%s\n", + env); + } + /* Default: half the CPUs, clamped to [1, MAX_SLOTS]. */ + int n = get_ncpus() / 2; + if (n <= 0) return 1; + return n <= MAX_SLOTS ? n : MAX_SLOTS; +} + +/* -------------------------------------------------------------------------- + * Query flag detection + * -------------------------------------------------------------------------- */ + +static int is_query_flag(const char *arg) +{ + return strcmp(arg, "--version") == 0 + || strcmp(arg, "--numeric-version") == 0 + || strcmp(arg, "--info") == 0 + || strcmp(arg, "--supported-extensions") == 0 + || strcmp(arg, "--supported-languages") == 0 + || strcmp(arg, "--show-options") == 0 + || strncmp(arg, "--print-", 8) == 0; +} + +static int should_bypass(int argc, char *argv[]) +{ + for (int i = 1; i < argc; i++) { + /* Stop scanning at end-of-options marker. */ + if (strcmp(argv[i], "--") == 0) + break; + if (is_query_flag(argv[i])) + return 1; + if (strcmp(argv[i], "-jsem") == 0 || + strncmp(argv[i], "-jsem=", 6) == 0) + return 1; + } + return 0; +} + +/* -------------------------------------------------------------------------- + * Slot acquisition via named mutexes + * + * Uses Local\ prefix so the namespace is per-logon-session (roughly + * matching the per-UID semantics of the POSIX flock version). + * -------------------------------------------------------------------------- */ + +static HANDLE acquired_mutex = NULL; + +static void acquire_slot(int max_jobs) +{ + char name[MUTEX_NAME_BUF]; + HANDLE h; + + /* Fast path: try each slot without blocking. + * ERROR_ALREADY_EXISTS only tells us whether *this* call created the + * mutex vs. opened an existing one — it does not indicate contention. + * Instead, open/create the mutex and do a zero-timeout wait to test + * availability. */ + for (int i = 0; i < max_jobs; i++) { + _snprintf(name, sizeof(name), "Local\\ghc-throttle-slot-%d", i); + name[sizeof(name) - 1] = '\0'; + + h = CreateMutexA(NULL, FALSE, name); + if (h == NULL) + continue; + + DWORD result = WaitForSingleObject(h, 0); + if (result == WAIT_OBJECT_0 || result == WAIT_ABANDONED) { + /* Got the mutex without blocking — slot acquired. */ + DBG("acquired slot %d (fast path)", i); + acquired_mutex = h; + return; + } + if (result == WAIT_FAILED) { + DBG("WaitForSingleObject slot %d failed: %lu", + i, (unsigned long)GetLastError()); + } + /* WAIT_TIMEOUT or WAIT_FAILED — try next slot. */ + CloseHandle(h); + } + + /* Slow path: block on a deterministic slot based on PID. */ + int slot = (int)(GetCurrentProcessId() % (DWORD)max_jobs); + _snprintf(name, sizeof(name), "Local\\ghc-throttle-slot-%d", slot); + name[sizeof(name) - 1] = '\0'; + + h = CreateMutexA(NULL, FALSE, name); + if (h == NULL) { + fprintf(stderr, "ghc-throttle: CreateMutex(%s) failed: %lu\n", + name, (unsigned long)GetLastError()); + return; /* proceed unthrottled */ + } + + DBG("blocking on slot %d (slow path)", slot); + + DWORD result = WaitForSingleObject(h, INFINITE); + if (result == WAIT_OBJECT_0 || result == WAIT_ABANDONED) { + DBG("acquired slot %d (slow path)", slot); + acquired_mutex = h; + } else { + fprintf(stderr, "ghc-throttle: WaitForSingleObject failed: %lu\n", + (unsigned long)GetLastError()); + CloseHandle(h); + /* proceed unthrottled */ + } +} + +/* -------------------------------------------------------------------------- + * Command-line construction + * + * Windows requires a flat command-line string. Each argument is wrapped in + * double quotes with internal quotes and backslashes escaped. + * -------------------------------------------------------------------------- */ + +/* Windows command-line quoting follows the CommandLineToArgvW convention: + * - Wrap each argument in double quotes + * - Backslashes are literal UNLESS followed by a double quote + * - A run of N backslashes before a " becomes 2N+1 characters: N*2 backslashes + \" + * - A run of N backslashes at the end of the argument becomes 2N (before closing ") + * See: https://learn.microsoft.com/en-us/cpp/c-language/parsing-c-command-line-arguments */ + +/* Compute the length needed for a quoted argument (including quotes and space). */ +static size_t quoted_len(const char *arg) +{ + size_t len = 3; /* opening quote, closing quote, trailing space or NUL */ + size_t nbs = 0; /* backslash run length */ + for (const char *p = arg; *p; p++) { + if (*p == '\\') { + nbs++; + len++; + } else if (*p == '"') { + len += nbs + 2; /* double the backslashes + escaped quote */ + nbs = 0; + } else { + nbs = 0; + len++; + } + } + len += nbs; /* double trailing backslashes before closing quote */ + return len; +} + +/* Write a quoted argument to dst, return pointer past the last written char. */ +static char *quote_arg(char *dst, const char *arg) +{ + *dst++ = '"'; + size_t nbs = 0; + for (const char *p = arg; *p; p++) { + if (*p == '\\') { + nbs++; + *dst++ = '\\'; + } else if (*p == '"') { + /* Double the backslashes preceding this quote, then escape it. */ + for (size_t i = 0; i < nbs; i++) + *dst++ = '\\'; + *dst++ = '\\'; + *dst++ = '"'; + nbs = 0; + } else { + nbs = 0; + *dst++ = *p; + } + } + /* Double trailing backslashes before the closing quote. */ + for (size_t i = 0; i < nbs; i++) + *dst++ = '\\'; + *dst++ = '"'; + return dst; +} + +static char *build_cmdline(int argc, char *argv[]) +{ + size_t total = 0; + for (int i = 0; i < argc; i++) { + size_t q = quoted_len(argv[i]); + if (total + q < total) /* overflow check */ + return NULL; + total += q; + } + if (total + (size_t)argc < total) /* overflow check */ + return NULL; + total += (size_t)argc; /* spaces between args + NUL */ + + char *cmdline = malloc(total); + if (!cmdline) + return NULL; + + char *p = cmdline; + for (int i = 0; i < argc; i++) { + if (i > 0) + *p++ = ' '; + p = quote_arg(p, argv[i]); + } + *p = '\0'; + return cmdline; +} + +/* -------------------------------------------------------------------------- + * Real GHC discovery + * + * Priority: + * 1. GHC_THROTTLE_GHC environment variable + * 2. + ".real" suffix (using GetModuleFileName) + * 3. PATH search with self-exclusion (case-insensitive path comparison) + * -------------------------------------------------------------------------- */ + +static int file_exists(const char *path) +{ + DWORD attrs = GetFileAttributesA(path); + return attrs != INVALID_FILE_ATTRIBUTES && + !(attrs & FILE_ATTRIBUTE_DIRECTORY); +} + +/* Normalize a path for comparison — resolves to full path. */ +static int get_full_path(const char *path, char *buf, size_t bufsz) +{ + DWORD len = GetFullPathNameA(path, (DWORD)bufsz, buf, NULL); + return (len > 0 && len < (DWORD)bufsz) ? 0 : -1; +} + +static const char *search_path_for_ghc(const char *name, const char *self_full) +{ + static char found[PATH_BUF]; + const char *path_env = getenv("PATH"); + if (!path_env) + return NULL; + + size_t plen = strlen(path_env); + char *buf = malloc(plen + 1); + if (!buf) + return NULL; + memcpy(buf, path_env, plen + 1); + + /* PATH separator on Windows is ';'. Use manual tokenization instead + * of strtok_s which may not be available in MinGW. */ + for (char *p = buf; *p != '\0'; ) { + /* Find the next ';' or end of string. */ + char *sep = strchr(p, ';'); + if (sep) + *sep = '\0'; + + if (*p != '\0') { /* skip empty entries */ + int n = _snprintf(found, sizeof(found), "%s\\%s", p, name); + if (n > 0 && (size_t)n < sizeof(found) && file_exists(found)) { + /* Self-exclusion: compare normalized paths (case-insensitive). */ + char candidate_full[PATH_BUF]; + if (get_full_path(found, candidate_full, sizeof(candidate_full)) == 0 && + _stricmp(candidate_full, self_full) != 0) + { + free(buf); + return found; + } + } + } + + if (sep) + p = sep + 1; + else + break; + } + free(buf); + return NULL; +} + +static const char *find_real_ghc(const char *argv0) +{ + /* 1. Explicit environment variable. */ + const char *env = getenv("GHC_THROTTLE_GHC"); + if (env && *env) { + DBG("using GHC_THROTTLE_GHC=%s", env); + return env; + } + + /* Resolve our own absolute path using GetModuleFileName. */ + static char self_path[PATH_BUF]; + DWORD len = GetModuleFileNameA(NULL, self_path, sizeof(self_path)); + const char *resolved = (len > 0 && len < sizeof(self_path)) ? self_path : NULL; + + /* 2. .real — look for the real binary next to us. */ + static char real_path[PATH_BUF]; + const char *base_for_real = resolved ? resolved : argv0; + int n = _snprintf(real_path, sizeof(real_path), "%s.real", base_for_real); + if (n > 0 && (size_t)n < sizeof(real_path) && file_exists(real_path)) { + DBG("found %s", real_path); + return real_path; + } + /* Also try with .exe.real → .real.exe mapping. */ + { + size_t blen = strlen(base_for_real); + if (blen > 4 && _stricmp(base_for_real + blen - 4, ".exe") == 0) { + n = _snprintf(real_path, sizeof(real_path), "%.*s.real.exe", + (int)(blen - 4), base_for_real); + if (n > 0 && (size_t)n < sizeof(real_path) && file_exists(real_path)) { + DBG("found %s", real_path); + return real_path; + } + } + } + + /* 3. PATH search with self-exclusion. + * Use the resolved path's basename (from GetModuleFileName) since it + * always includes the .exe suffix. argv0 may omit it in MSYS/MinGW. */ + if (resolved) { + char self_full[PATH_BUF]; + if (get_full_path(resolved, self_full, sizeof(self_full)) == 0) { + const char *base = strrchr(resolved, '\\'); + if (!base) + base = strrchr(resolved, '/'); + const char *name = base ? base + 1 : resolved; + const char *found = search_path_for_ghc(name, self_full); + if (found) { + DBG("found %s via PATH search", found); + return found; + } + } + } + + return NULL; +} + +/* -------------------------------------------------------------------------- + * main + * -------------------------------------------------------------------------- */ + +int main(int argc, char *argv[]) +{ + if (argc < 1 || !argv[0]) { + fprintf(stderr, "ghc-throttle: argv[0] is NULL\n"); + return 127; + } + + const char *dbg = getenv("GHC_THROTTLE_DEBUG"); + if (dbg && dbg[0] == '1') + debug_enabled = 1; + + /* Detect recursion: if we've already been through ghc-throttle once, + * the sentinel will be set. This catches all discovery paths. */ + const char *active = getenv("GHC_THROTTLE_ACTIVE"); + if (active && active[0] == '1') { + fprintf(stderr, + "ghc-throttle: recursion detected — the resolved GHC " + "appears to be ghc-throttle itself.\n"); + return 127; + } + + const char *real_ghc = find_real_ghc(argv[0]); + if (!real_ghc) { + fprintf(stderr, + "ghc-throttle: cannot find real GHC.\n" + " Set GHC_THROTTLE_GHC or install as ghc.exe with ghc.exe.real alongside.\n"); + return 127; + } + + if (!should_bypass(argc, argv)) { + int max_jobs = get_max_jobs(); + DBG("max_jobs=%d", max_jobs); + acquire_slot(max_jobs); + } else { + DBG("bypassing throttle (query flag or -jsem)"); + } + + /* Set a sentinel to detect recursion if we accidentally spawn ourselves. + * If this fails, abort — without the sentinel, a misconfigured real_ghc + * path could cause infinite recursion. */ + if (!SetEnvironmentVariableA("GHC_THROTTLE_ACTIVE", "1")) { + fprintf(stderr, "ghc-throttle: SetEnvironmentVariable failed: %lu\n", + (unsigned long)GetLastError()); + return 127; + } + + /* Build the command line. argv[0] is replaced with the real GHC path. */ + argv[0] = (char *)real_ghc; + char *cmdline = build_cmdline(argc, argv); + if (!cmdline) { + fprintf(stderr, "ghc-throttle: out of memory building command line\n"); + if (acquired_mutex) { + ReleaseMutex(acquired_mutex); + CloseHandle(acquired_mutex); + } + return 127; + } + + /* Launch the real GHC as a child process. + * Unlike POSIX exec(), the wrapper stays alive holding the mutex. + * The mutex is released automatically when this process exits. */ + STARTUPINFOA si; + PROCESS_INFORMATION pi; + ZeroMemory(&si, sizeof(si)); + si.cb = sizeof(si); + ZeroMemory(&pi, sizeof(pi)); + + DBG("exec: %s", cmdline); + + /* bInheritHandles=TRUE: build systems redirect stdin/stdout/stderr via + * inheritable handles, so the child must inherit them for piped I/O to + * work correctly in CI and build system contexts. */ + if (!CreateProcessA(NULL, cmdline, NULL, NULL, TRUE, 0, NULL, NULL, &si, &pi)) { + fprintf(stderr, "ghc-throttle: CreateProcess failed: %lu\n", + (unsigned long)GetLastError()); + free(cmdline); + if (acquired_mutex) { + ReleaseMutex(acquired_mutex); + CloseHandle(acquired_mutex); + } + return 127; + } + free(cmdline); + + /* Wait for GHC to finish. The mutex is held throughout. */ + DWORD wait_result = WaitForSingleObject(pi.hProcess, INFINITE); + DWORD exit_code = 127; + + if (wait_result == WAIT_OBJECT_0) { + if (!GetExitCodeProcess(pi.hProcess, &exit_code)) + exit_code = 1; + } else { + fprintf(stderr, "ghc-throttle: WaitForSingleObject failed: %lu\n", + (unsigned long)GetLastError()); + TerminateProcess(pi.hProcess, 1); + /* Wait for termination to complete before releasing the mutex, + * otherwise the concurrency slot is freed while GHC may still + * be running briefly during teardown. */ + WaitForSingleObject(pi.hProcess, 5000); + exit_code = 1; + } + + CloseHandle(pi.hProcess); + CloseHandle(pi.hThread); + + /* Explicitly release and close the mutex for clean teardown. */ + if (acquired_mutex) { + ReleaseMutex(acquired_mutex); + CloseHandle(acquired_mutex); + } + + return (int)exit_code; +} diff --git a/utils/ghc-throttle/ghc-throttle.c b/utils/ghc-throttle/ghc-throttle.c new file mode 100644 index 000000000000..8362c6e3e931 --- /dev/null +++ b/utils/ghc-throttle/ghc-throttle.c @@ -0,0 +1,481 @@ +/* + * ghc-throttle: Transparent GHC concurrency limiter + * + * Licensed under the Apache License, Version 2.0. + * + * A drop-in wrapper that limits the number of concurrent GHC processes using + * flock()-based slot reservation. flock() locks survive exec(), so after + * acquiring a slot the wrapper exec()s the real GHC — zero runtime overhead. + * When GHC exits (normally, via signal, or crash) the kernel closes the fd + * and releases the lock automatically. No cleanup logic required. + * + * IMPORTANT: The lock directory MUST be on a local filesystem. flock() + * semantics on NFS are emulated via fcntl() and may not survive exec(). + * + * Deployment: + * Option A — rename real ghc to ghc.real, install this as ghc. + * Option B — set GHC_THROTTLE_GHC and use --with-compiler. + * + * Environment variables: + * GHC_THROTTLE_GHC — path to the real GHC binary + * GHC_THROTTLE_JOBS — max concurrent GHC processes (default: ncpus / 2) + * GHC_THROTTLE_DIR — lock directory (default: /tmp/ghc-throttle-$UID) + * GHC_THROTTLE_DEBUG — if set to "1", print diagnostics to stderr + */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#ifdef __APPLE__ +#include +#include /* _NSGetExecutablePath */ +#elif defined(__FreeBSD__) +#include /* sysctl, KERN_PROC_PATHNAME */ +#endif + +/* Maximum number of concurrency slots we ever allow. */ +#define MAX_SLOTS 256 + +/* Size of path buffers. */ +#define PATH_BUF 4096 + +static int debug_enabled = 0; + +#define DBG(...) do { \ + if (debug_enabled) { \ + fprintf(stderr, "ghc-throttle[%d]: ", (int)getpid()); \ + fprintf(stderr, __VA_ARGS__); \ + fprintf(stderr, "\n"); \ + } \ +} while (0) + +/* -------------------------------------------------------------------------- + * CPU count detection + * -------------------------------------------------------------------------- */ + +static int get_ncpus(void) +{ +#ifdef __APPLE__ + int ncpu = 0; + size_t len = sizeof(ncpu); + if (sysctlbyname("hw.ncpu", &ncpu, &len, NULL, 0) == 0 && ncpu > 0) + return ncpu; +#else + long n = sysconf(_SC_NPROCESSORS_ONLN); + if (n > 0) + return (int)n; +#endif + return 2; /* safe fallback */ +} + +/* -------------------------------------------------------------------------- + * Concurrency limit + * -------------------------------------------------------------------------- */ + +static int get_max_jobs(void) +{ + const char *env = getenv("GHC_THROTTLE_JOBS"); + if (env && *env) { + char *end; + long val = strtol(env, &end, 10); + if (*end == '\0' && val > 0 && val <= MAX_SLOTS) + return (int)val; + fprintf(stderr, "ghc-throttle: ignoring invalid GHC_THROTTLE_JOBS=%s\n", + env); + } + /* Default: half the CPUs, clamped to [1, MAX_SLOTS]. */ + int n = get_ncpus() / 2; + if (n <= 0) return 1; + return n <= MAX_SLOTS ? n : MAX_SLOTS; +} + +/* -------------------------------------------------------------------------- + * Lock directory + * -------------------------------------------------------------------------- */ + +/* Returns 0 on success, -1 if the lock directory could not be created. + * On failure the caller should skip acquire_slot() and proceed unthrottled. */ +static int get_lock_dir(char *buf, size_t bufsz) +{ + int n; + const char *env = getenv("GHC_THROTTLE_DIR"); + if (env && *env) { + n = snprintf(buf, bufsz, "%s", env); + } else { + n = snprintf(buf, bufsz, "/tmp/ghc-throttle-%u", (unsigned)getuid()); + } + if (n < 0 || (size_t)n >= bufsz) { + fprintf(stderr, "ghc-throttle: lock dir path too long\n"); + return -1; + } + /* Ensure the directory exists (mkdir -p equivalent for one level). */ + if (mkdir(buf, 0700) != 0) { + if (errno != EEXIST) { + fprintf(stderr, "ghc-throttle: cannot create lock dir %s: %s\n", + buf, strerror(errno)); + return -1; + } + /* Verify the existing path is a directory we own with safe + * permissions, not a symlink planted by another user in /tmp. */ + struct stat st; + if (lstat(buf, &st) != 0 || + !S_ISDIR(st.st_mode) || + st.st_uid != getuid()) + { + fprintf(stderr, "ghc-throttle: %s: not a directory owned by us\n", + buf); + return -1; + } + /* Reject directories without exactly 0700 permissions to prevent + * other users from interfering with our lock files. */ + if ((st.st_mode & 07777) != 0700) { + fprintf(stderr, + "ghc-throttle: %s: unsafe permissions %04o (expected 0700)\n", + buf, (unsigned)(st.st_mode & 07777)); + return -1; + } + } + return 0; +} + +/* -------------------------------------------------------------------------- + * Query flag detection + * + * GHC invocations like --version, --info, --numeric-version are instant + * queries that don't compile anything. Throttling these is wasteful — + * build systems call them during configuration and they should not block + * on compilation slots. + * -------------------------------------------------------------------------- */ + +static int is_query_flag(const char *arg) +{ + return strcmp(arg, "--version") == 0 + || strcmp(arg, "--numeric-version") == 0 + || strcmp(arg, "--info") == 0 + || strcmp(arg, "--supported-extensions") == 0 + || strcmp(arg, "--supported-languages") == 0 + || strcmp(arg, "--show-options") == 0 + || strncmp(arg, "--print-", 8) == 0; +} + +/* Check if this invocation should bypass throttling entirely. */ +static int should_bypass(int argc, char *argv[]) +{ + for (int i = 1; i < argc; i++) { + /* Stop scanning at end-of-options marker. Everything after "--" + * is a positional argument and should not trigger bypass. */ + if (strcmp(argv[i], "--") == 0) + break; + /* Query flags — no compilation work. */ + if (is_query_flag(argv[i])) + return 1; + /* -jsem — build system already manages concurrency via jobserver. + * Handles both "-jsem " and "-jsem=" forms. */ + if (strcmp(argv[i], "-jsem") == 0 || + strncmp(argv[i], "-jsem=", 6) == 0) + return 1; + } + return 0; +} + +/* -------------------------------------------------------------------------- + * Slot acquisition + * + * Fast path: non-blocking scan across all N lock files. + * Slow path: block on slot (pid % N) to distribute waiters. + * -------------------------------------------------------------------------- */ + +static void acquire_slot(const char *lock_dir, int max_jobs) +{ + char path[PATH_BUF]; + int fd; + + /* Fast path: try each slot without blocking. */ + for (int i = 0; i < max_jobs; i++) { + int n = snprintf(path, sizeof(path), "%s/slot.%d", lock_dir, i); + if (n < 0 || (size_t)n >= sizeof(path)) + continue; /* path truncated, skip this slot */ + + /* + * IMPORTANT: Do NOT add O_CLOEXEC here. The entire correctness model + * depends on this fd surviving across exec() so that the flock is held + * by the real GHC process. When GHC exits, the kernel closes the fd + * and releases the lock automatically. + */ + fd = open(path, O_RDWR | O_CREAT, 0600); + if (fd < 0) + continue; + if (flock(fd, LOCK_EX | LOCK_NB) == 0) { + DBG("acquired slot %d (fast path)", i); + return; /* fd stays open, survives exec */ + } + close(fd); + } + + /* Slow path: block on a deterministic slot based on PID. + * Same O_CLOEXEC caveat as fast path — do NOT add it. */ + int slot = (int)(getpid() % max_jobs); + { + int n = snprintf(path, sizeof(path), "%s/slot.%d", lock_dir, slot); + if (n < 0 || (size_t)n >= sizeof(path)) + return; /* path truncated, proceed unthrottled */ + } + fd = open(path, O_RDWR | O_CREAT, 0600); + if (fd < 0) { + fprintf(stderr, "ghc-throttle: cannot open %s: %s\n", + path, strerror(errno)); + return; /* proceed unthrottled rather than failing the build */ + } + + DBG("blocking on slot %d (slow path)", slot); + + /* Retry flock on EINTR — signals can interrupt the blocking wait. */ + while (flock(fd, LOCK_EX) != 0) { + if (errno == EINTR) + continue; + fprintf(stderr, "ghc-throttle: flock(%s) failed: %s\n", + path, strerror(errno)); + close(fd); + return; /* proceed unthrottled */ + } + DBG("acquired slot %d (slow path)", slot); + /* fd stays open, survives exec */ +} + +/* -------------------------------------------------------------------------- + * Real GHC discovery + * + * Priority: + * 1. GHC_THROTTLE_GHC environment variable + * 2. + ".real" suffix (using resolved absolute path) + * 3. PATH search with self-exclusion (skip entries resolving to same inode) + * -------------------------------------------------------------------------- */ + +/* Check that path is a regular executable file (not a directory or device). */ +static int is_regular_executable(const char *path) +{ + struct stat st; + return stat(path, &st) == 0 && S_ISREG(st.st_mode) && + access(path, X_OK) == 0; +} + +/* Resolve a path to its device + inode for identity comparison. */ +static int get_identity(const char *path, dev_t *dev, ino_t *ino) +{ + struct stat st; + if (stat(path, &st) != 0) + return -1; + *dev = st.st_dev; + *ino = st.st_ino; + return 0; +} + +/* Search PATH for a binary named `name`, skipping entries that resolve to the + * same binary as ourselves (self_dev:self_ino). This allows ghc-throttle + * installed as e.g. "ghc-9.14" to find the real "ghc-9.14" in PATH. */ +static const char *search_path_for_ghc(const char *name, + dev_t self_dev, ino_t self_ino) +{ + static char found[PATH_BUF]; + const char *path_env = getenv("PATH"); + if (!path_env) + return NULL; + + /* Work on a mutable copy of PATH. */ + size_t plen = strlen(path_env); + char *buf = malloc(plen + 1); + if (!buf) + return NULL; + memcpy(buf, path_env, plen + 1); + + char *saveptr = NULL; + for (char *dir = strtok_r(buf, ":", &saveptr); + dir != NULL; + dir = strtok_r(NULL, ":", &saveptr)) + { + int n = snprintf(found, sizeof(found), "%s/%s", dir, name); + if (n < 0 || (size_t)n >= sizeof(found)) + continue; /* path truncated, skip */ + if (access(found, X_OK) != 0) + continue; + /* Verify it's a regular file, not a directory (access(X_OK) succeeds + * on directories where the user has search permission). */ + { + struct stat cst; + if (stat(found, &cst) != 0 || !S_ISREG(cst.st_mode)) + continue; + } + dev_t d; + ino_t i; + if (get_identity(found, &d, &i) == 0 && + (d != self_dev || i != self_ino)) + { + free(buf); + return found; + } + } + free(buf); + return NULL; +} + +static const char *find_real_ghc(const char *argv0) +{ + /* 1. Explicit environment variable. */ + const char *env = getenv("GHC_THROTTLE_GHC"); + if (env && *env) { + DBG("using GHC_THROTTLE_GHC=%s", env); + return env; + } + + /* Resolve our own absolute path early — needed for both the ".real" + * suffix check and the PATH self-exclusion. When argv[0] is a bare + * name (e.g. "ghc"), appending ".real" to it would look for "ghc.real" + * in CWD instead of next to the actual binary. Using /proc/self/exe + * (Linux) or _NSGetExecutablePath (macOS) gives us the true location. */ + static char self_path[PATH_BUF]; + const char *resolved = NULL; +#ifdef __linux__ + { + ssize_t len = readlink("/proc/self/exe", self_path, sizeof(self_path) - 1); + /* Reject if readlink filled the entire buffer — the path may be + * truncated. PATH_BUF (4096) is typically >= PATH_MAX on + * supported platforms, but the truncation check is still needed + * since PATH_MAX is not always a compile-time constant. */ + if (len > 0 && (size_t)len < sizeof(self_path) - 1) { + self_path[len] = '\0'; + resolved = self_path; + } + } +#elif defined(__APPLE__) + { + uint32_t self_size = sizeof(self_path); + if (_NSGetExecutablePath(self_path, &self_size) == 0) + resolved = self_path; + } +#elif defined(__FreeBSD__) + { + int mib[4] = { CTL_KERN, KERN_PROC, KERN_PROC_PATHNAME, -1 }; + size_t len = sizeof(self_path); + if (sysctl(mib, 4, self_path, &len, NULL, 0) == 0 && len > 0) + resolved = self_path; + } +#endif + + /* 2. .real — look for the real binary next to us. + * Prefer the resolved absolute path so this works even when argv[0] + * is a bare name like "ghc" found via PATH. */ + static char real_path[PATH_BUF]; + const char *base_for_real = resolved ? resolved : argv0; + int n = snprintf(real_path, sizeof(real_path), "%s.real", base_for_real); + if (n > 0 && (size_t)n < sizeof(real_path) && + is_regular_executable(real_path)) { + DBG("found %s", real_path); + return real_path; + } + + /* 3. PATH search with self-exclusion. */ + dev_t self_dev; + ino_t self_ino; + int have_self = 0; + if (resolved) + have_self = (get_identity(resolved, &self_dev, &self_ino) == 0); + if (!have_self) + have_self = (get_identity(argv0, &self_dev, &self_ino) == 0); + + if (have_self) { + /* Use the basename of argv[0] so ghc-throttle installed as e.g. + * "ghc-9.14" will search PATH for "ghc-9.14", not just "ghc". */ + const char *base = strrchr(argv0, '/'); + const char *name = base ? base + 1 : argv0; + const char *found = search_path_for_ghc(name, self_dev, self_ino); + if (found) { + DBG("found %s via PATH search", found); + return found; + } + } + + return NULL; +} + +/* -------------------------------------------------------------------------- + * main + * -------------------------------------------------------------------------- */ + +int main(int argc, char *argv[]) +{ + /* Guard against pathological exec with empty argv. */ + if (argc < 1 || !argv[0]) { + fprintf(stderr, "ghc-throttle: argv[0] is NULL\n"); + return 127; + } + + /* Check debug flag early. */ + const char *dbg = getenv("GHC_THROTTLE_DEBUG"); + if (dbg && dbg[0] == '1') + debug_enabled = 1; + + /* Detect recursion: if we've already been through ghc-throttle once, + * the sentinel will be set. This catches all discovery paths (env var, + * .real suffix, PATH search) pointing back to this wrapper. */ + const char *active = getenv("GHC_THROTTLE_ACTIVE"); + if (active && active[0] == '1') { + fprintf(stderr, + "ghc-throttle: recursion detected — the resolved GHC " + "appears to be ghc-throttle itself.\n"); + return 127; + } + + /* Find the real GHC. */ + const char *real_ghc = find_real_ghc(argv[0]); + if (!real_ghc) { + fprintf(stderr, + "ghc-throttle: cannot find real GHC.\n" + " Set GHC_THROTTLE_GHC or install as ghc with ghc.real alongside.\n"); + return 127; + } + + /* Skip throttling for query flags and -jsem invocations. */ + if (!should_bypass(argc, argv)) { + /* Determine concurrency limit. */ + int max_jobs = get_max_jobs(); + DBG("max_jobs=%d", max_jobs); + + /* Prepare lock directory. If creation fails, proceed unthrottled + * rather than spamming errors from acquire_slot. */ + char lock_dir[PATH_BUF]; + if (get_lock_dir(lock_dir, sizeof(lock_dir)) == 0) + acquire_slot(lock_dir, max_jobs); + } else { + DBG("bypassing throttle (query flag or -jsem)"); + } + + /* Set a sentinel to detect recursion if we accidentally exec ourselves. + * If setenv fails (e.g. ENOMEM), abort — without the sentinel, a + * misconfigured real_ghc path could cause infinite recursion. */ + if (setenv("GHC_THROTTLE_ACTIVE", "1", 1) != 0) { + fprintf(stderr, "ghc-throttle: setenv failed: %s\n", strerror(errno)); + return 127; + } + + /* Become the real GHC. argv[0] is replaced so GHC sees its real name. + * Use execv for resolved paths (contains '/'), execvp for bare names + * (e.g., GHC_THROTTLE_GHC=ghc-9.14 without a path). */ + argv[0] = (char *)real_ghc; + if (strchr(real_ghc, '/')) + execv(real_ghc, argv); + else + execvp(real_ghc, argv); + + /* exec failed. */ + fprintf(stderr, "ghc-throttle: exec(%s) failed: %s\n", + real_ghc, strerror(errno)); + return 127; +}