Add FreeBSD Guile verification harness

2026-04-01 07:55:23 +02:00
parent a0eca3b3fe
commit e380e8838d
5 changed files with 409 additions and 0 deletions
--- a/docs/PROGRESS.md
+++ b/docs/PROGRESS.md
@@ -0,0 +1,37 @@
+# Progress
+
+## 2026-04-01 — Phase 1.1 started: Guile verified on FreeBSD amd64
+
+Completed work:
+
+- installed/confirmed `guile3-3.0.10`
+- added a reusable verification harness:
+  - `tests/guile/run-phase1-verification.sh`
+  - `tests/guile/verify-phase1.scm`
+  - `tests/guile/modules/phase1/sample.scm`
+- verified the following on `FreeBSD 15.0-STABLE` amd64:
+  - module loading
+  - deterministic output generation
+  - file I/O
+  - process handling with `primitive-fork`/`waitpid`
+  - loopback TCP sockets
+  - FFI calls into libc
+  - execution of Guix bootstrap-related code from `(guix build make-bootstrap)`
+- wrote the results to `docs/reports/phase1-guile-freebsd.md`
+
+Notable findings:
+
+- `guile3` and `guile-3.0` are present, but there is no unversioned `guile` binary
+- `system*` and `open-pipe*` currently segfault on this host (`exit 139`)
+- despite that crash, the lower-level process primitives needed for further investigation do work
+
+Current assessment:
+
+- Phase 1.1 has a solid amd64 smoke-verification baseline
+- Phase 1.1 is not fully complete yet because `i386` has not been checked and the subprocess crash needs investigation
+
+Next recommended step:
+
+1. investigate and isolate the `system*` / `open-pipe*` crash with a minimal reproducer
+2. decide whether this requires a local Guile patch, a packaging fix, or Guix-side avoidance
+3. once subprocess behavior is understood, continue with Phase 1.2 (minimal native build environment / GNU Hello)
--- a/docs/reports/phase1-guile-freebsd.md
+++ b/docs/reports/phase1-guile-freebsd.md
@@ -0,0 +1,110 @@
+# Phase 1.1: Guile verification on FreeBSD amd64
+
+Date: 2026-04-01
+
+## Scope
+
+This step covers the first item in `docs/PLAN.md`: verify that GNU Guile is usable on FreeBSD as a foundation for the Guix port.
+
+The work in this step is limited to the current host (`FreeBSD 15.0-STABLE` on `amd64`). Cross-architecture verification for `i386` is still outstanding.
+
+## Environment
+
+- Host: `FreeBSD fruixdev 15.0-STABLE stable/15-n282801-29dce45d8c50 GENERIC amd64`
+- FreeBSD version: `15.0-STABLE`
+- Guile package: `guile3-3.0.10`
+- Guile executables present: `/usr/local/bin/guile3`, `/usr/local/bin/guile-3.0`
+- Guix source tree: `~/repos/guix`
+- Guix source revision used for module loading: `62b61c20bcd20d3e8ec251a96e31f283d6a89374`
+
+## Artifacts added
+
+- `tests/guile/run-phase1-verification.sh`
+- `tests/guile/verify-phase1.scm`
+- `tests/guile/modules/phase1/sample.scm`
+
+## Verification command
+
+```sh
+./tests/guile/run-phase1-verification.sh
+```
+
+## Result
+
+The verification suite passes on this FreeBSD amd64 host.
+
+Covered checks:
+
+1. Guile module loading for a local test module
+2. Deterministic Scheme output (`alpha=1;beta=2;gamma=3;sum=14`)
+3. File I/O
+4. Process creation and reaping via `primitive-fork` + `waitpid`
+5. Loopback TCP socket communication
+6. FFI calls through `(system foreign)` using `getpid(2)`
+7. Execution of Guix bootstrap-related code by importing `(guix build make-bootstrap)` and successfully running `copy-linux-headers`
+
+Expected deterministic payload hash:
+
+```text
+7465da3704e9af1a71aaf4be99e62cff2631e410d7fe8b0bfbe3daf095de9b49
+```
+
+Two consecutive runs produced the same deterministic payload.
+
+## Important findings
+
+### 1. Positive: core Guile functionality works
+
+The following are confirmed working on this machine:
+
+- Scheme evaluation
+- module resolution
+- file I/O
+- process management with `primitive-fork`
+- TCP sockets on loopback
+- FFI into libc
+- loading and executing Guix bootstrap module code
+
+This is enough to justify proceeding with the next Guix porting steps on FreeBSD.
+
+### 2. Negative: `system*` and `open-pipe*` currently crash
+
+These commands segfaulted on this host:
+
+```sh
+guile3 -c '(system* "/usr/bin/true")'
+guile3 -c '(use-modules (ice-9 popen)) (open-pipe* OPEN_READ "/usr/bin/true")'
+```
+
+Observed exit status:
+
+```text
+exit:139
+```
+
+This is a significant portability issue because Guix and related tooling commonly rely on subprocess helpers in this area.
+
+### 3. Packaging detail: no unversioned `guile` executable
+
+The FreeBSD package provides `guile3` and `guile-3.0`, but not an unversioned `guile` binary in `PATH`. Any automation should invoke `guile3` or detect one of the provided versioned names.
+
+## Assessment against plan item 1.1
+
+### Achieved now
+
+- Verified Guile availability on FreeBSD amd64
+- Built a reusable verification suite for repeated testing
+- Confirmed module loading, file I/O, processes, sockets, and FFI
+- Confirmed execution of Guix bootstrap-related Scheme code from `make-bootstrap.scm`
+- Confirmed deterministic output for a fixed Scheme workload
+
+### Still missing for full completion of 1.1
+
+- Verification on `i386`
+- Broader bootstrap coverage beyond `copy-linux-headers`
+- Linux vs. FreeBSD output comparison from the same suite
+- Root-cause analysis or workaround for `system*` / `open-pipe*` crashes
+
+## Recommended next step
+
+Before moving deeply into daemon and build-system work, investigate the FreeBSD Guile subprocess crash (`system*` / `open-pipe*`). If it is a Guile-on-FreeBSD issue rather than a local packaging issue, document a minimal reproducer and determine whether Guix can avoid those code paths or needs a local patch.
--- a/tests/guile/modules/phase1/sample.scm
+++ b/tests/guile/modules/phase1/sample.scm
@@ -0,0 +1,25 @@
+(define-module (phase1 sample)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-13)
+  #:export (sample-message deterministic-payload))
+
+(define (sample-message)
+  "sample-module-ok")
+
+(define (deterministic-payload)
+  (let* ((pairs '((gamma . 3) (alpha . 1) (beta . 2)))
+         (sorted (sort pairs (lambda (a b)
+                               (string<? (symbol->string (car a))
+                                         (symbol->string (car b))))))
+         (sum (apply + (map (lambda (pair)
+                              (* (cdr pair) (cdr pair)))
+                            sorted))))
+    (string-append
+     (string-join
+      (map (lambda (pair)
+             (string-append (symbol->string (car pair))
+                            "="
+                            (number->string (cdr pair))))
+           sorted)
+      ";")
+     ";sum=" (number->string sum))))
--- a/tests/guile/run-phase1-verification.sh
+++ b/tests/guile/run-phase1-verification.sh
@@ -0,0 +1,30 @@
+#!/bin/sh
+set -eu
+
+script_dir=$(CDPATH= cd -- "$(dirname "$0")" && pwd)
+repo_root=$(CDPATH= cd -- "$script_dir/../.." && pwd)
+guix_source_dir=${GUIX_SOURCE_DIR:-"$HOME/repos/guix"}
+
+if [ ! -d "$guix_source_dir/guix" ]; then
+  echo "Guix source tree not found at $guix_source_dir" >&2
+  exit 1
+fi
+
+if command -v guile3 >/dev/null 2>&1; then
+  guile_bin=$(command -v guile3)
+elif command -v guile-3.0 >/dev/null 2>&1; then
+  guile_bin=$(command -v guile-3.0)
+else
+  echo "Unable to find guile3 or guile-3.0 in PATH" >&2
+  exit 1
+fi
+
+export GUIX_SOURCE_DIR="$guix_source_dir"
+export GUILE_AUTO_COMPILE=${GUILE_AUTO_COMPILE:-0}
+if [ -n "${GUILE_LOAD_PATH:-}" ]; then
+  export GUILE_LOAD_PATH="$repo_root/tests/guile/modules:$guix_source_dir:$GUILE_LOAD_PATH"
+else
+  export GUILE_LOAD_PATH="$repo_root/tests/guile/modules:$guix_source_dir"
+fi
+
+exec "$guile_bin" -s "$repo_root/tests/guile/verify-phase1.scm" "$@"
--- a/tests/guile/verify-phase1.scm
+++ b/tests/guile/verify-phase1.scm
@@ -0,0 +1,207 @@
+(use-modules (ice-9 format)
+             (ice-9 rdelim)
+             (ice-9 textual-ports)
+             (ice-9 threads)
+             (system foreign)
+             (phase1 sample)
+             (guix build make-bootstrap))
+
+(setvbuf (current-output-port) 'line)
+
+(define %bootstrap-linux-headers
+  '("atalk.h"
+    "errno.h"
+    "falloc.h"
+    "if_addr.h"
+    "if_ether.h"
+    "if_link.h"
+    "ioctl.h"
+    "kernel.h"
+    "limits.h"
+    "neighbour.h"
+    "netlink.h"
+    "param.h"
+    "prctl.h"
+    "posix_types.h"
+    "rtnetlink.h"
+    "socket.h"
+    "stddef.h"
+    "swab.h"
+    "sysctl.h"
+    "sysinfo.h"
+    "types.h"
+    "version.h"))
+
+(define %failures 0)
+
+(define (check name thunk)
+  (catch #t
+    (lambda ()
+      (thunk)
+      (format #t "PASS ~a~%" name))
+    (lambda (key . args)
+      (set! %failures (+ %failures 1))
+      (format #t "FAIL ~a~%" name)
+      (format #t "  key: ~s~%" key)
+      (format #t "  args: ~s~%" args))))
+
+(define (ensure condition message . args)
+  (unless condition
+    (apply error message args)))
+
+(define (read-file path)
+  (call-with-input-file path get-string-all))
+
+(define (write-file path content)
+  (call-with-output-file path
+    (lambda (port)
+      (display content port))))
+
+(define (make-tempdir prefix)
+  (mkdtemp (string-copy (string-append "/tmp/" prefix "-XXXXXX"))))
+
+(define (mkdir-p path)
+  (let loop ((parts (string-split path #\/))
+             (current ""))
+    (when (pair? parts)
+      (let* ((part (car parts))
+             (next (cond
+                     ((string-null? part)
+                      "/")
+                     ((or (string=? current "")
+                          (string=? current "/"))
+                      (string-append current part))
+                     (else
+                      (string-append current "/" part)))))
+        (unless (or (string-null? part)
+                    (file-exists? next))
+          (mkdir next))
+        (loop (cdr parts) next)))))
+
+(define (touch path content)
+  (let ((slash (string-rindex path #\/)))
+    (when slash
+      (mkdir-p (substring path 0 slash)))
+    (write-file path content)))
+
+(define (test-module-system)
+  (ensure (string=? (sample-message) "sample-module-ok")
+          "unexpected module message: ~s"
+          (sample-message)))
+
+(define (test-deterministic-output)
+  (ensure (string=? (deterministic-payload)
+                    "alpha=1;beta=2;gamma=3;sum=14")
+          "unexpected deterministic payload: ~s"
+          (deterministic-payload)))
+
+(define (test-file-io)
+  (let* ((dir (make-tempdir "fruix-guile-fileio"))
+         (path (string-append dir "/payload.txt"))
+         (payload "freebsd-guile-file-io-ok\nline-2\n"))
+    (write-file path payload)
+    (ensure (string=? (read-file path) payload)
+            "file payload mismatch for ~a"
+            path)))
+
+(define (test-processes)
+  (let* ((dir (make-tempdir "fruix-guile-process"))
+         (path (string-append dir "/child.txt")))
+    (force-output (current-output-port))
+    (let ((pid (primitive-fork)))
+    (if (zero? pid)
+        (begin
+          (write-file path "child-process-ok\n")
+          (primitive-exit 0))
+        (let ((status (cdr (waitpid pid))))
+          (ensure (= 0 (status:exit-val status))
+                  "child exited with status ~a"
+                  (status:exit-val status))
+          (ensure (string=? (read-file path) "child-process-ok\n")
+                  "child file payload mismatch"))))))
+
+(define (test-sockets)
+  (let* ((server (socket AF_INET SOCK_STREAM 0)))
+    (setsockopt server SOL_SOCKET SO_REUSEADDR 1)
+    (bind server AF_INET INADDR_LOOPBACK 0)
+    (listen server 1)
+    (let* ((port (sockaddr:port (getsockname server)))
+           (thread (call-with-new-thread
+                     (lambda ()
+                       (let* ((accepted (accept server))
+                              (conn (car accepted))
+                              (line (read-line conn)))
+                         (display line conn)
+                         (newline conn)
+                         (force-output conn)
+                         (close-port conn)
+                         (close-port server))))))
+      (let ((client (socket AF_INET SOCK_STREAM 0)))
+        (connect client AF_INET INADDR_LOOPBACK port)
+        (display "socket-roundtrip-ok" client)
+        (newline client)
+        (force-output client)
+        (ensure (string=? (read-line client) "socket-roundtrip-ok")
+                "socket roundtrip mismatch")
+        (close-port client)
+        (join-thread thread)))))
+
+(define (test-ffi)
+  (let* ((libc (dynamic-link))
+         (ffi-getpid (pointer->procedure int
+                                         (dynamic-func "getpid" libc)
+                                         '())))
+    (ensure (= (getpid) (ffi-getpid))
+            "FFI getpid mismatch: Guile=~a FFI=~a"
+            (getpid)
+            (ffi-getpid))))
+
+(define (test-guix-bootstrap)
+  (let* ((dir (make-tempdir "fruix-guix-bootstrap"))
+         (kernel-headers (string-append dir "/kernel-headers"))
+         (output (string-append dir "/output")))
+    (mkdir-p (string-append kernel-headers "/include/linux/byteorder"))
+    (mkdir-p (string-append kernel-headers "/include/asm"))
+    (mkdir-p (string-append kernel-headers "/include/asm-generic"))
+    (for-each (lambda (header)
+                (touch (string-append kernel-headers "/include/linux/" header)
+                       (string-append "/* " header " */\n")))
+              %bootstrap-linux-headers)
+    (touch (string-append kernel-headers "/include/asm/signal.h") "/* asm */\n")
+    (touch (string-append kernel-headers "/include/asm-generic/errno-base.h") "/* asm-generic */\n")
+    (touch (string-append kernel-headers "/include/linux/byteorder/little_endian.h")
+           "/* byteorder */\n")
+    (let ((sink (open-output-string)))
+      (parameterize ((current-output-port sink)
+                     (current-error-port sink))
+        (ensure (copy-linux-headers output kernel-headers)
+                "copy-linux-headers returned false")))
+    (ensure (file-exists? (string-append output "/include/linux/errno.h"))
+            "missing copied linux header")
+    (ensure (file-exists? (string-append output "/include/asm/signal.h"))
+            "missing copied asm header")
+    (ensure (file-exists? (string-append output "/include/linux/byteorder/little_endian.h"))
+            "missing copied byteorder header")))
+
+(define (run-suite)
+  (format #t "Environment:~%")
+  (format #t "  GUIX_SOURCE_DIR=~a~%" (or (getenv "GUIX_SOURCE_DIR") "<unset>"))
+  (format #t "  GUILE_LOAD_PATH=~a~%" (or (getenv "GUILE_LOAD_PATH") "<unset>"))
+  (check "module-system" test-module-system)
+  (check "deterministic-output" test-deterministic-output)
+  (check "file-io" test-file-io)
+  (check "process-fork/wait" test-processes)
+  (check "loopback-socket" test-sockets)
+  (check "ffi-getpid" test-ffi)
+  (check "guix-build-make-bootstrap/copy-linux-headers" test-guix-bootstrap)
+  (format #t "Summary: ~a failure(s)~%" %failures)
+  (exit %failures))
+
+(define (main args)
+  (if (member "--deterministic-payload" (cdr args))
+      (begin
+        (display (deterministic-payload))
+        (newline))
+      (run-suite)))
+
+(main (command-line))