Add ghc-throttle: transparent GHC concurrency limiter

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.

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}'

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 <windows.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#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;
+}