Migrate 14 more .sls with else-guards and custom record names
ober
2c8ee33d474f3306ee1836284eaf5f5158f9a327
deleted file mode 100644 --- a/lib/std/agent.sls +++ /dev/null @@ -1,288 +0,0 @@ -#!chezscheme -;;; (std agent) — Clojure-style agents (fiber-aware) -;;; -;;; An agent is an asynchronous state cell with a serialized action -;;; queue. You create one with an initial value and then dispatch -;;; actions against it: -;;; -;;; (def a (agent 0)) -;;; (send a + 1) ;; queues (+ 0 1) -> 1; returns a -;;; (send a * 3) ;; queues (* 1 3) -> 3; returns a -;;; (await a) ;; blocks until the queue drains -;;; (agent-value a) ;; => 3 -;;; -;;; FIBER-AWARE DISPATCH -;;; -------------------- -;;; When created inside a fiber runtime, the agent's worker loop runs -;;; as a fiber and the action channel is a fiber-channel. This means -;;; `send` parks instead of blocking, and agent workers cost ~4KB -;;; each instead of an OS thread. -;;; -;;; When created outside a fiber runtime, falls back to OS threads -;;; and (std csp) channels (original behavior). -;;; -;;; Error handling -;;; -------------- -;;; If an action throws, the exception is captured and placed in the -;;; agent's error slot. Subsequent `send` calls raise an error until -;;; `restart-agent` is called to clear the error and optionally reset -;;; the value. This matches Clojure's default `:fail` error mode. -;;; -;;; Shutdown -;;; -------- -;;; `shutdown-agent!` closes the action queue and lets the worker -;;; finish naturally when the queue drains. - -(library (std agent) - (export - agent agent? - send send-off - agent-value agent-error - clear-agent-errors restart-agent - await await-for shutdown-agent! - set-error-handler! set-error-mode! - agent-error-mode agent-error-handler) - - (import (chezscheme) - (std csp) - (std fiber)) - - ;; --- Agent record ------------------------------------------- - - (define-record-type %agent - (fields (mutable val) - (mutable err) - (immutable action-ch) - (immutable fiber-mode?) ;; #t if backed by fiber - (mutable error-mode) ;; 'fail (default) | 'continue - (mutable error-handler)) ;; #f or (a exn) -> ignored - (sealed #t)) - - (define (agent? x) (%agent? x)) - - (define (agent-value a) - (unless (%agent? a) (error 'agent-value "not an agent" a)) - (%agent-val a)) - - (define (agent-error a) - (unless (%agent? a) (error 'agent-error "not an agent" a)) - (%agent-err a)) - - ;; --- Constructor -------------------------------------------- - - (define agent - (case-lambda - [(initial) (agent initial 1024)] - [(initial buf-size) - (let ([rt (current-fiber-runtime)]) - (if rt - ;; Fiber mode: fiber-channel + fiber worker - (let* ([ch (make-fiber-channel buf-size)] - [a (make-%agent initial #f ch #t 'fail #f)]) - (fiber-spawn rt (%make-fiber-worker-loop a ch)) - a) - ;; Thread mode: OS channel + OS thread worker - (let* ([ch (make-channel buf-size)] - [a (make-%agent initial #f ch #f 'fail #f)]) - (fork-thread (%make-thread-worker-loop a ch)) - a)))])) - - ;; --- Error policy helpers ----------------------------------- - - (define (%run-error-handler! a exn) - (let ([h (%agent-error-handler a)]) - (when h - (guard (_ [else #f]) ;; swallow handler exceptions - (h a exn))))) - - (define (%on-action-error! a exn) - (%run-error-handler! a exn) - (case (%agent-error-mode a) - [(continue) #f] ;; drop the error, keep going - [else (%agent-err-set! a exn)])) ;; 'fail — latch the error - - ;; --- Worker loops ------------------------------------------- - - ;; OS-thread worker: blocks on chan-get! - (define (%make-thread-worker-loop a ch) - (lambda () - (let loop () - (let ([action (chan-get! ch)]) - (cond - [(eof-object? action) #f] - [else - (unless (%agent-err a) - (guard (exn [else (%on-action-error! a exn)]) - (let ([new-val (apply (car action) - (%agent-val a) - (cdr action))]) - (%agent-val-set! a new-val)))) - (loop)]))))) - - ;; Fiber worker: parks on fiber-channel-recv - (define (%make-fiber-worker-loop a ch) - (lambda () - (let loop () - (let ([action (fiber-channel-recv ch)]) - (cond - [(eof-object? action) #f] - [else - (unless (%agent-err a) - (guard (exn [else (%on-action-error! a exn)]) - (let ([new-val (apply (car action) - (%agent-val a) - (cdr action))]) - (%agent-val-set! a new-val)))) - (loop)]))))) - - ;; --- Dispatch ----------------------------------------------- - - (define (send a fn . args) - (unless (%agent? a) (error 'send "not an agent" a)) - (unless (procedure? fn) (error 'send "action is not a procedure" fn)) - (when (%agent-err a) - (error 'send - "agent has error; call restart-agent to clear" - (%agent-err a))) - (let ([ch (%agent-action-ch a)]) - (if (%agent-fiber-mode? a) - (begin - (when (fiber-channel-closed? ch) - (error 'send "agent has been shut down" a)) - (fiber-channel-send ch (cons fn args))) - (begin - (when (chan-closed? ch) - (error 'send "agent has been shut down" a)) - (chan-put! ch (cons fn args))))) - a) - - ;; send-off: in Clojure dispatches on unbounded I/O pool. - ;; In Jerboa, agents already have a dedicated worker, so - ;; send and send-off are identical. - (define send-off send) - - ;; --- Error handling ----------------------------------------- - - (define (clear-agent-errors a) - (unless (%agent? a) (error 'clear-agent-errors "not an agent" a)) - (%agent-err-set! a #f) - a) - - (define (restart-agent a new-value) - (unless (%agent? a) (error 'restart-agent "not an agent" a)) - (%agent-err-set! a #f) - (%agent-val-set! a new-value) - a) - - ;; --- Synchronization ---------------------------------------- - - ;; (await a) — block until all currently-queued actions have been - ;; processed. Sends a sentinel action that signals completion. - (define (await a) - (unless (%agent? a) (error 'await "not an agent" a)) - (when (%agent-err a) - (error 'await "agent has error; call restart-agent to clear" - (%agent-err a))) - (let ([ch (%agent-action-ch a)]) - (if (%agent-fiber-mode? a) - ;; Fiber mode: use fiber-channel for sentinel - (begin - (when (fiber-channel-closed? ch) - (error 'await "agent has been shut down" a)) - (let ([done (make-fiber-channel 1)]) - (fiber-channel-send ch - (cons (lambda (v) - (fiber-channel-send done 'done) - v) - '())) - (fiber-channel-recv done) - a)) - ;; Thread mode: use OS channel for sentinel - (begin - (when (chan-closed? ch) - (error 'await "agent has been shut down" a)) - (let ([done (make-channel 1)]) - (chan-put! ch - (cons (lambda (v) - (chan-put! done 'done) - v) - '())) - (chan-get! done) - a))))) - - ;; (shutdown-agent! a) — close the action queue. - (define (shutdown-agent! a) - (unless (%agent? a) (error 'shutdown-agent! "not an agent" a)) - (let ([ch (%agent-action-ch a)]) - (if (%agent-fiber-mode? a) - (fiber-channel-close ch) - (chan-close! ch))) - a) - - ;; (await-for ms a) — like `await` but gives up after ms milliseconds. - ;; Returns #t if the queue drained in time, #f on timeout. - ;; Implemented by sending a marker action and polling for its completion. - (define (await-for ms a) - (unless (%agent? a) (error 'await-for "not an agent" a)) - (unless (and (integer? ms) (>= ms 0)) - (error 'await-for "ms must be a non-negative integer" ms)) - (when (%agent-err a) - (error 'await-for "agent has error; call restart-agent to clear" - (%agent-err a))) - (let ([done-box (list 'pending)] - [ch (%agent-action-ch a)]) - ;; Action that marks completion by mutating the box. - ;; Capture: cons on first slot so the caller can observe via eq?. - (let ([marker (cons (lambda (v) - (set-car! done-box 'done) - v) - '())]) - (if (%agent-fiber-mode? a) - (begin - (when (fiber-channel-closed? ch) - (error 'await-for "agent has been shut down" a)) - (fiber-channel-send ch marker)) - (begin - (when (chan-closed? ch) - (error 'await-for "agent has been shut down" a)) - (chan-put! ch marker)))) - ;; Poll for completion. 5ms steps keeps overhead low. - (let loop ([remaining ms]) - (cond - [(eq? (car done-box) 'done) #t] - [(<= remaining 0) #f] - [else - (sleep (make-time 'time-duration 5000000 0)) - (loop (- remaining 5))])))) - - ;; (set-error-handler! a fn) — install a handler called with - ;; (fn agent exception) each time an action throws. Handler runs - ;; after the action failure and before the latched-error logic. - ;; Pass #f to clear. Handler exceptions are swallowed. - (define (set-error-handler! a fn) - (unless (%agent? a) (error 'set-error-handler! "not an agent" a)) - (unless (or (not fn) (procedure? fn)) - (error 'set-error-handler! "handler must be a procedure or #f" fn)) - (%agent-error-handler-set! a fn) - a) - - ;; (set-error-mode! a mode) — mode is 'fail (default) or 'continue. - ;; In 'continue mode, action errors do not latch, so subsequent sends - ;; proceed (paired with set-error-handler! for observability). - (define (set-error-mode! a mode) - (unless (%agent? a) (error 'set-error-mode! "not an agent" a)) - (unless (memq mode '(fail continue)) - (error 'set-error-mode! "mode must be 'fail or 'continue" mode)) - (%agent-error-mode-set! a mode) - a) - - ;; Accessors (documented surface — useful for assertions/tests). - (define (agent-error-mode a) - (unless (%agent? a) (error 'agent-error-mode "not an agent" a)) - (%agent-error-mode a)) - - (define (agent-error-handler a) - (unless (%agent? a) (error 'agent-error-handler "not an agent" a)) - (%agent-error-handler a)) - -) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/agent.ss @@ -0,0 +1,283 @@ +#!chezscheme +;;; (std agent) — Clojure-style agents (fiber-aware) +;;; +;;; An agent is an asynchronous state cell with a serialized action +;;; queue. You create one with an initial value and then dispatch +;;; actions against it: +;;; +;;; (def a (agent 0)) +;;; (send a + 1) ;; queues (+ 0 1) -> 1; returns a +;;; (send a * 3) ;; queues (* 1 3) -> 3; returns a +;;; (await a) ;; blocks until the queue drains +;;; (agent-value a) ;; => 3 +;;; +;;; FIBER-AWARE DISPATCH +;;; -------------------- +;;; When created inside a fiber runtime, the agent's worker loop runs +;;; as a fiber and the action channel is a fiber-channel. This means +;;; `send` parks instead of blocking, and agent workers cost ~4KB +;;; each instead of an OS thread. +;;; +;;; When created outside a fiber runtime, falls back to OS threads +;;; and (std csp) channels (original behavior). +;;; +;;; Error handling +;;; -------------- +;;; If an action throws, the exception is captured and placed in the +;;; agent's error slot. Subsequent `send` calls raise an error until +;;; `restart-agent` is called to clear the error and optionally reset +;;; the value. This matches Clojure's default `:fail` error mode. +;;; +;;; Shutdown +;;; -------- +;;; `shutdown-agent!` closes the action queue and lets the worker +;;; finish naturally when the queue drains. + +(library (std agent) + (export + agent agent? + send send-off + agent-value agent-error + clear-agent-errors restart-agent + await await-for shutdown-agent! + set-error-handler! set-error-mode! + agent-error-mode agent-error-handler) + + (import (chezscheme) + (std csp) + (std fiber) + (only (jerboa core) def defstruct try catch finally)) + + ;; --- Agent record ------------------------------------------- + + (defstruct %agent (val err action-ch fiber-mode? error-mode error-handler)) + + (def (agent? x) (%agent? x)) + + (def (agent-value a) + (unless (%agent? a) (error 'agent-value "not an agent" a)) + (%agent-val a)) + + (def (agent-error a) + (unless (%agent? a) (error 'agent-error "not an agent" a)) + (%agent-err a)) + + ;; --- Constructor -------------------------------------------- + + (def agent + (case-lambda + [(initial) (agent initial 1024)] + [(initial buf-size) + (let ([rt (current-fiber-runtime)]) + (if rt + ;; Fiber mode: fiber-channel + fiber worker + (let* ([ch (make-fiber-channel buf-size)] + [a (make-%agent initial #f ch #t 'fail #f)]) + (fiber-spawn rt (%make-fiber-worker-loop a ch)) + a) + ;; Thread mode: OS channel + OS thread worker + (let* ([ch (make-channel buf-size)] + [a (make-%agent initial #f ch #f 'fail #f)]) + (fork-thread (%make-thread-worker-loop a ch)) + a)))])) + + ;; --- Error policy helpers ----------------------------------- + + (def (%run-error-handler! a exn) + (let ([h (%agent-error-handler a)]) + (when h + (try (begin ;; swallow handler exceptions + (h a exn)) + (catch (_) #f))))) + + (def (%on-action-error! a exn) + (%run-error-handler! a exn) + (case (%agent-error-mode a) + [(continue) #f] ;; drop the error, keep going + [else (%agent-err-set! a exn)])) ;; 'fail — latch the error + + ;; --- Worker loops ------------------------------------------- + + ;; OS-thread worker: blocks on chan-get! + (def (%make-thread-worker-loop a ch) + (lambda () + (let loop () + (let ([action (chan-get! ch)]) + (cond + [(eof-object? action) #f] + [else + (unless (%agent-err a) + (try (let ([new-val (apply (car action) + (%agent-val a) + (cdr action))]) + (%agent-val-set! a new-val)) + (catch (exn) (%on-action-error! a exn)))) + (loop)]))))) + + ;; Fiber worker: parks on fiber-channel-recv + (def (%make-fiber-worker-loop a ch) + (lambda () + (let loop () + (let ([action (fiber-channel-recv ch)]) + (cond + [(eof-object? action) #f] + [else + (unless (%agent-err a) + (try (let ([new-val (apply (car action) + (%agent-val a) + (cdr action))]) + (%agent-val-set! a new-val)) + (catch (exn) (%on-action-error! a exn)))) + (loop)]))))) + + ;; --- Dispatch ----------------------------------------------- + + (def (send a fn . args) + (unless (%agent? a) (error 'send "not an agent" a)) + (unless (procedure? fn) (error 'send "action is not a procedure" fn)) + (when (%agent-err a) + (error 'send + "agent has error; call restart-agent to clear" + (%agent-err a))) + (let ([ch (%agent-action-ch a)]) + (if (%agent-fiber-mode? a) + (begin + (when (fiber-channel-closed? ch) + (error 'send "agent has been shut down" a)) + (fiber-channel-send ch (cons fn args))) + (begin + (when (chan-closed? ch) + (error 'send "agent has been shut down" a)) + (chan-put! ch (cons fn args))))) + a) + + ;; send-off: in Clojure dispatches on unbounded I/O pool. + ;; In Jerboa, agents already have a dedicated worker, so + ;; send and send-off are identical. + (def send-off send) + + ;; --- Error handling ----------------------------------------- + + (def (clear-agent-errors a) + (unless (%agent? a) (error 'clear-agent-errors "not an agent" a)) + (%agent-err-set! a #f) + a) + + (def (restart-agent a new-value) + (unless (%agent? a) (error 'restart-agent "not an agent" a)) + (%agent-err-set! a #f) + (%agent-val-set! a new-value) + a) + + ;; --- Synchronization ---------------------------------------- + + ;; (await a) — block until all currently-queued actions have been + ;; processed. Sends a sentinel action that signals completion. + (def (await a) + (unless (%agent? a) (error 'await "not an agent" a)) + (when (%agent-err a) + (error 'await "agent has error; call restart-agent to clear" + (%agent-err a))) + (let ([ch (%agent-action-ch a)]) + (if (%agent-fiber-mode? a) + ;; Fiber mode: use fiber-channel for sentinel + (begin + (when (fiber-channel-closed? ch) + (error 'await "agent has been shut down" a)) + (let ([done (make-fiber-channel 1)]) + (fiber-channel-send ch + (cons (lambda (v) + (fiber-channel-send done 'done) + v) + '())) + (fiber-channel-recv done) + a)) + ;; Thread mode: use OS channel for sentinel + (begin + (when (chan-closed? ch) + (error 'await "agent has been shut down" a)) + (let ([done (make-channel 1)]) + (chan-put! ch + (cons (lambda (v) + (chan-put! done 'done) + v) + '())) + (chan-get! done) + a))))) + + ;; (shutdown-agent! a) — close the action queue. + (def (shutdown-agent! a) + (unless (%agent? a) (error 'shutdown-agent! "not an agent" a)) + (let ([ch (%agent-action-ch a)]) + (if (%agent-fiber-mode? a) + (fiber-channel-close ch) + (chan-close! ch))) + a) + + ;; (await-for ms a) — like `await` but gives up after ms milliseconds. + ;; Returns #t if the queue drained in time, #f on timeout. + ;; Implemented by sending a marker action and polling for its completion. + (def (await-for ms a) + (unless (%agent? a) (error 'await-for "not an agent" a)) + (unless (and (integer? ms) (>= ms 0)) + (error 'await-for "ms must be a non-negative integer" ms)) + (when (%agent-err a) + (error 'await-for "agent has error; call restart-agent to clear" + (%agent-err a))) + (let ([done-box (list 'pending)] + [ch (%agent-action-ch a)]) + ;; Action that marks completion by mutating the box. + ;; Capture: cons on first slot so the caller can observe via eq?. + (let ([marker (cons (lambda (v) + (set-car! done-box 'done) + v) + '())]) + (if (%agent-fiber-mode? a) + (begin + (when (fiber-channel-closed? ch) + (error 'await-for "agent has been shut down" a)) + (fiber-channel-send ch marker)) + (begin + (when (chan-closed? ch) + (error 'await-for "agent has been shut down" a)) + (chan-put! ch marker)))) + ;; Poll for completion. 5ms steps keeps overhead low. + (let loop ([remaining ms]) + (cond + [(eq? (car done-box) 'done) #t] + [(<= remaining 0) #f] + [else + (sleep (make-time 'time-duration 5000000 0)) + (loop (- remaining 5))])))) + + ;; (set-error-handler! a fn) — install a handler called with + ;; (fn agent exception) each time an action throws. Handler runs + ;; after the action failure and before the latched-error logic. + ;; Pass #f to clear. Handler exceptions are swallowed. + (def (set-error-handler! a fn) + (unless (%agent? a) (error 'set-error-handler! "not an agent" a)) + (unless (or (not fn) (procedure? fn)) + (error 'set-error-handler! "handler must be a procedure or #f" fn)) + (%agent-error-handler-set! a fn) + a) + + ;; (set-error-mode! a mode) — mode is 'fail (default) or 'continue. + ;; In 'continue mode, action errors do not latch, so subsequent sends + ;; proceed (paired with set-error-handler! for observability). + (def (set-error-mode! a mode) + (unless (%agent? a) (error 'set-error-mode! "not an agent" a)) + (unless (memq mode '(fail continue)) + (error 'set-error-mode! "mode must be 'fail or 'continue" mode)) + (%agent-error-mode-set! a mode) + a) + + ;; Accessors (documented surface — useful for assertions/tests). + (def (agent-error-mode a) + (unless (%agent? a) (error 'agent-error-mode "not an agent" a)) + (%agent-error-mode a)) + + (def (agent-error-handler a) + (unless (%agent? a) (error 'agent-error-handler "not an agent" a)) + (%agent-error-handler a)) + +) ;; end library deleted file mode 100644 --- a/lib/std/build/cross.sls +++ /dev/null @@ -1,336 +0,0 @@ -#!chezscheme -;;; (std build cross) — Cross-Compilation Pipeline -;;; -;;; Target platform records, toolchain detection, and build matrix execution. -;;; Uses (machine-type) for host detection and subprocess for compilation. - -(library (std build cross) - (export - ;; Target platforms - make-target-platform - target-platform? - platform-name - platform-arch - platform-os - platform-abi - - ;; Built-in platforms - platform/x86_64-linux - platform/arm64-linux - platform/riscv64-linux - platform/x86_64-macos - platform/arm64-macos - - ;; Cross-compilation configuration - make-cross-config - cross-config? - cross-config-host - cross-config-target - cross-config-cc - cross-config-sysroot - cross-config-extra-flags - - ;; Detecting current platform - current-platform - detect-platform - - ;; Cross-compilation steps - compile-for-target - link-for-target - - ;; Toolchain detection - find-cross-compiler - cross-compiler-available? - - ;; Build matrix - make-build-matrix - run-build-matrix - build-matrix-results - - ;; Utilities - platform->string - string->platform - platform=? - native-platform?) - - (import (chezscheme)) - - ;; ========== Platform Record ========== - - (define-record-type (%target-platform %make-target-platform target-platform?) - (fields - (immutable name) ;; symbol: 'arm64-linux, 'x86_64-linux, etc. - (immutable arch) ;; symbol: 'arm64, 'riscv64, 'x86_64 - (immutable os) ;; symbol: 'linux, 'macos, 'windows - (immutable abi))) ;; symbol: 'gnu, 'musl, 'none - - (define (make-target-platform name arch os abi) - (%make-target-platform name arch os abi)) - - (define (platform-name p) (%target-platform-name p)) - (define (platform-arch p) (%target-platform-arch p)) - (define (platform-os p) (%target-platform-os p)) - (define (platform-abi p) (%target-platform-abi p)) - - ;; ========== Built-in Platforms ========== - - (define platform/x86_64-linux - (make-target-platform 'x86_64-linux 'x86_64 'linux 'gnu)) - - (define platform/arm64-linux - (make-target-platform 'arm64-linux 'arm64 'linux 'gnu)) - - (define platform/riscv64-linux - (make-target-platform 'riscv64-linux 'riscv64 'linux 'gnu)) - - (define platform/x86_64-macos - (make-target-platform 'x86_64-macos 'x86_64 'macos 'none)) - - (define platform/arm64-macos - (make-target-platform 'arm64-macos 'arm64 'macos 'none)) - - ;; ========== String Utilities ========== - - (define (string-has? str sub) - (let ([slen (string-length str)] - [sublen (string-length sub)]) - (and (<= sublen slen) - (let loop ([i 0]) - (cond - [(> (+ i sublen) slen) #f] - [(string=? (substring str i (+ i sublen)) sub) #t] - [else (loop (+ i 1))]))))) - - ;; ========== Host Detection ========== - - (define (machine-type->arch mt) - (let ([s (symbol->string mt)]) - (cond - [(string-has? s "arm64") 'arm64] - [(string-has? s "arm") 'arm64] - [(string-has? s "a6") 'x86_64] - [(string-has? s "i3") 'x86_64] - [(string-has? s "rv") 'riscv64] - [else 'x86_64]))) - - (define (machine-type->os mt) - (let ([s (symbol->string mt)]) - (cond - [(or (string-has? s "osx") (string-has? s "darwin")) 'macos] - [(or (string-has? s "nt") (string-has? s "win")) 'windows] - [else 'linux]))) - - (define (detect-platform) - ;; Inspect (machine-type) to determine current platform. - (let* ([mt (machine-type)] - [arch (machine-type->arch mt)] - [os (machine-type->os mt)] - [name (string->symbol (string-append (symbol->string arch) "-" (symbol->string os)))]) - (make-target-platform name arch os 'gnu))) - - (define current-platform - ;; Memoized: detect once at load time. - (let ([p #f]) - (lambda () - (unless p (set! p (detect-platform))) - p))) - - ;; ========== Cross-Compilation Config ========== - - (define-record-type (%cross-config %make-cross-config cross-config?) - (fields - (immutable host) ;; target-platform (current machine) - (immutable target) ;; target-platform (compile for) - (immutable cc) ;; string: compiler command - (immutable sysroot) ;; string path or #f - (immutable extra-flags)));; list of strings - - (define (make-cross-config host target cc sysroot extra-flags) - (%make-cross-config host target cc sysroot extra-flags)) - - (define (cross-config-host cfg) (%cross-config-host cfg)) - (define (cross-config-target cfg) (%cross-config-target cfg)) - (define (cross-config-cc cfg) (%cross-config-cc cfg)) - (define (cross-config-sysroot cfg) (%cross-config-sysroot cfg)) - (define (cross-config-extra-flags cfg) (%cross-config-extra-flags cfg)) - - ;; ========== Toolchain Detection ========== - - (define (arch->cross-cc-candidates arch) - ;; Return list of candidate compiler names for cross-compiling to arch. - (case arch - [(arm64) '("aarch64-linux-gnu-gcc" "aarch64-unknown-linux-gnu-gcc")] - [(riscv64) '("riscv64-linux-gnu-gcc" "riscv64-unknown-linux-gnu-gcc")] - [(x86_64) '("x86_64-linux-gnu-gcc" "gcc")] - [else '()])) - - (define (program-in-path? prog) - ;; Check if prog is executable somewhere in PATH. - (guard (exn [#t #f]) - (let ([paths (string-split (or (getenv "PATH") "/usr/bin:/bin") #\:)]) - (let loop ([ps paths]) - (cond - [(null? ps) #f] - [(file-exists? (string-append (car ps) "/" prog)) #t] - [else (loop (cdr ps))]))))) - - (define (string-split str ch) - ;; Split string by character. - (let loop ([i 0] [start 0] [parts '()]) - (cond - [(= i (string-length str)) - (reverse (cons (substring str start i) parts))] - [(char=? (string-ref str i) ch) - (loop (+ i 1) (+ i 1) (cons (substring str start i) parts))] - [else (loop (+ i 1) start parts)]))) - - (define (find-cross-compiler target-arch) - ;; Return first available cross-compiler for target-arch, or #f. - (let loop ([cands (arch->cross-cc-candidates target-arch)]) - (cond - [(null? cands) #f] - [(program-in-path? (car cands)) (car cands)] - [else (loop (cdr cands))]))) - - (define (cross-compiler-available? target-arch) - (and (find-cross-compiler target-arch) #t)) - - ;; ========== Compilation Subprocess ========== - - (define (run-command cmd) - ;; Run shell command, return (exit-code . output-string). - (guard (exn [#t (cons 1 (if (message-condition? exn) - (condition-message exn) - (format "~a" exn)))]) - (let* ([tmp (string-append "/tmp/jerboa-cross-" (number->string (time-second (current-time))) ".out")] - [full (string-append cmd " > " tmp " 2>&1")] - [status (system full)] - [out (guard (exn [#t ""]) - (call-with-input-file tmp - (lambda (port) - (let loop ([lines '()]) - (let ([line (get-line port)]) - (if (eof-object? line) - (apply string-append (reverse lines)) - (loop (cons (string-append line "\n") lines))))))))]) - (guard (exn [#t #f]) (delete-file tmp)) - (cons status out)))) - - (define (compile-for-target config source-file output-dir) - ;; Compile source-file using cross-compiler for config's target. - ;; Returns (list 'ok output-path) or (list 'error msg). - (guard (exn [#t (list 'error (if (message-condition? exn) - (condition-message exn) - (format "~a" exn)))]) - (let* ([cc (cross-config-cc config)] - [flags (cross-config-extra-flags config)] - [sysroot (cross-config-sysroot config)] - [base (path-basename source-file)] - [out (string-append output-dir "/" base ".o")] - [sysroot-flag (if sysroot - (string-append "--sysroot=" sysroot " ") - "")] - [flags-str (apply string-append - (map (lambda (f) (string-append f " ")) flags))] - [cmd (string-append cc " " sysroot-flag flags-str - "-c " source-file " -o " out)]) - (let ([result (run-command cmd)]) - (if (= (car result) 0) - (list 'ok out) - (list 'error (cdr result))))))) - - (define (link-for-target config obj-files output-binary) - ;; Link object files into output-binary using cross-linker. - (guard (exn [#t (list 'error (if (message-condition? exn) - (condition-message exn) - (format "~a" exn)))]) - (let* ([cc (cross-config-cc config)] - [objs (apply string-append - (map (lambda (f) (string-append f " ")) obj-files))] - [cmd (string-append cc " " objs " -o " output-binary)]) - (let ([result (run-command cmd)]) - (if (= (car result) 0) - (list 'ok output-binary) - (list 'error (cdr result))))))) - - (define (path-basename path) - ;; Return last component of path without directory. - (let loop ([i (- (string-length path) 1)]) - (cond - [(< i 0) path] - [(char=? (string-ref path i) #\/) (substring path (+ i 1) (string-length path))] - [else (loop (- i 1))]))) - - ;; ========== Build Matrix ========== - - (define-record-type (%build-matrix %make-build-matrix build-matrix?) - (fields - (immutable source-files) - (immutable platforms) - (mutable results))) ;; alist: platform-name -> (success? output) - - (define (make-build-matrix source-files platforms) - (%make-build-matrix source-files platforms '())) - - (define (build-matrix-results matrix) - (%build-matrix-results matrix)) - - (define (run-build-matrix matrix) - ;; For each platform, attempt to compile all source files. - ;; Does not actually invoke compiler if cross-compiler unavailable. - (let ([results '()]) - (for-each - (lambda (platform) - (let* ([arch (platform-arch platform)] - [cc (or (find-cross-compiler arch) "cc")] - [config (make-cross-config (current-platform) platform cc #f '())] - [platform-results - (map (lambda (src) - (guard (exn [#t (cons src (list 'error - (if (message-condition? exn) - (condition-message exn) - "unknown error")))]) - ;; Simulate compilation without actually running (no real files) - (cons src (list 'simulated (platform-name platform))))) - (%build-matrix-source-files matrix))] - [ok? (every (lambda (r) - (let ([res (cdr r)]) - (not (eq? (car res) 'error)))) - platform-results)]) - (set! results - (cons (cons (platform-name platform) (cons ok? platform-results)) - results)))) - (%build-matrix-platforms matrix)) - (%build-matrix-results-set! matrix (reverse results)) - matrix)) - - (define (every pred lst) - (cond [(null? lst) #t] - [(pred (car lst)) (every pred (cdr lst))] - [else #f])) - - ;; ========== Platform Utilities ========== - - (define (platform->string p) - (symbol->string (platform-name p))) - - (define (string->platform s) - ;; Look up a built-in platform by name string. - (let ([sym (string->symbol s)]) - (cond - [(eq? sym 'x86_64-linux) platform/x86_64-linux] - [(eq? sym 'arm64-linux) platform/arm64-linux] - [(eq? sym 'riscv64-linux) platform/riscv64-linux] - [(eq? sym 'x86_64-macos) platform/x86_64-macos] - [(eq? sym 'arm64-macos) platform/arm64-macos] - [else #f]))) - - (define (platform=? a b) - (and (target-platform? a) - (target-platform? b) - (eq? (platform-name a) (platform-name b)))) - - (define (native-platform? p) - (platform=? p (current-platform))) - -) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/build/cross.ss @@ -0,0 +1,329 @@ +#!chezscheme +;;; (std build cross) — Cross-Compilation Pipeline +;;; +;;; Target platform records, toolchain detection, and build matrix execution. +;;; Uses (machine-type) for host detection and subprocess for compilation. + +(library (std build cross) + (export + ;; Target platforms + make-target-platform + target-platform? + platform-name + platform-arch + platform-os + platform-abi + + ;; Built-in platforms + platform/x86_64-linux + platform/arm64-linux + platform/riscv64-linux + platform/x86_64-macos + platform/arm64-macos + + ;; Cross-compilation configuration + make-cross-config + cross-config? + cross-config-host + cross-config-target + cross-config-cc + cross-config-sysroot + cross-config-extra-flags + + ;; Detecting current platform + current-platform + detect-platform + + ;; Cross-compilation steps + compile-for-target + link-for-target + + ;; Toolchain detection + find-cross-compiler + cross-compiler-available? + + ;; Build matrix + make-build-matrix + run-build-matrix + build-matrix-results + + ;; Utilities + platform->string + string->platform + platform=? + native-platform?) + + (import (chezscheme) + (only (jerboa core) def defstruct try catch finally)) + + ;; ========== Platform Record ========== + + (defstruct %target-platform (name arch os abi)) + (def %make-target-platform make-%target-platform) + (def target-platform? %target-platform?) ;; symbol: 'gnu, 'musl, 'none + + (def (make-target-platform name arch os abi) + (%make-target-platform name arch os abi)) + + (def (platform-name p) (%target-platform-name p)) + (def (platform-arch p) (%target-platform-arch p)) + (def (platform-os p) (%target-platform-os p)) + (def (platform-abi p) (%target-platform-abi p)) + + ;; ========== Built-in Platforms ========== + + (def platform/x86_64-linux + (make-target-platform 'x86_64-linux 'x86_64 'linux 'gnu)) + + (def platform/arm64-linux + (make-target-platform 'arm64-linux 'arm64 'linux 'gnu)) + + (def platform/riscv64-linux + (make-target-platform 'riscv64-linux 'riscv64 'linux 'gnu)) + + (def platform/x86_64-macos