jerbuild binary: ffi-symbols header + pre-link hook + per-source CFLAGS
ober
1420ac4f29b231d6ed60be89bc97b58992adb391
--- a/jerbuild.ss +++ b/jerbuild.ss @@ -1459,6 +1459,85 @@ (error 'jerbuild (format "embed-bytes: failed for ~a -> ~a" source-path header-path))))) +(define (read-ffi-symbol-list path) + ;; One symbol per line. Blank lines and #/; comments ignored. Leading + ;; whitespace stripped. Returns list of strings, source-order preserved. + (call-with-input-file path + (lambda (port) + (let loop ([acc '()]) + (let ([line (get-line port)]) + (cond + [(eof-object? line) (reverse acc)] + [else + (let strip ([i 0]) + (cond + [(= i (string-length line)) (loop acc)] + [(char-whitespace? (string-ref line i)) (strip (+ i 1))] + [else + (let ([trimmed (substring line i (string-length line))]) + (cond + [(or (= (string-length trimmed) 0) + (char=? (string-ref trimmed 0) #\#) + (char=? (string-ref trimmed 0) #\;)) + (loop acc)] + [else (loop (cons trimmed acc))]))]))])))))) + +(define (write-ffi-symbols-header out symbol-list) + ;; Emit obj-dir/ffi_symbols.h: extern decls for each FFI symbol plus a + ;; `register_ffi_symbols()` function that calls Sforeign_symbol on each. + ;; main.c (stock or user override) includes this and calls the function + ;; after Sbuild_heap. The decls use `extern void NAME();` (no prototype) + ;; so any FFI signature is acceptable to Chez at registration. + ;; + ;; Always emitted when (ffi-symbols PATH) is set in .jerbuild, regardless + ;; of whether the user supplies a custom main.c. + (display "/* generated by jerbuild — do not edit.\n" out) + (display " * The includer must #include \"scheme.h\" before this header. */\n" out) + (display "#ifndef JERBUILD_FFI_SYMBOLS_H\n" out) + (display "#define JERBUILD_FFI_SYMBOLS_H\n\n" out) + (for-each (lambda (sym) (fprintf out "extern void ~a();\n" sym)) symbol-list) + (newline out) + (display "static void register_ffi_symbols(void) {\n" out) + (for-each + (lambda (sym) + (fprintf out " Sforeign_symbol(\"~a\", (void *)~a);\n" sym sym)) + symbol-list) + (display "}\n\n" out) + (display "#endif /* JERBUILD_FFI_SYMBOLS_H */\n" out)) + +(define (write-empty-ffi-symbols-header out) + ;; No-op header so the stock main.c can always #include it and call + ;; register_ffi_symbols() unconditionally. + (display "/* generated by jerbuild — no ffi-symbols configured */\n" out) + (display "#ifndef JERBUILD_FFI_SYMBOLS_H\n" out) + (display "#define JERBUILD_FFI_SYMBOLS_H\n" out) + (display "static void register_ffi_symbols(void) { }\n" out) + (display "#endif\n" out)) + +(define (run-hook-commands! label cmds cwd extra-env) + ;; Run each cmd string via sh -c, with cwd set to `cwd` and the given env + ;; pairs ((NAME . VALUE) ...) prefixed. Aborts on first nonzero exit. + (unless (null? cmds) + (printf "==> ~a (~a)\n" label (length cmds)) + (for-each + (lambda (cmd) + (let* ([env-prefix + (apply string-append + (map (lambda (kv) + (format "~a=~a " + (car kv) + (shell-quote (cdr kv)))) + extra-env))] + [full (format "cd ~a && ~a~a" + (shell-quote cwd) env-prefix cmd)]) + (printf " $ ~a\n" cmd) + (let ([rc (system full)]) + (unless (zero? rc) + (error 'jerbuild + (format "~a: command failed (rc=~a): ~a" + label rc cmd)))))) + cmds))) + (define *binary-main-c-template* ;; Generated main.c for the standalone binary. Mirrors the structure of ;; support/build-binary.sh's CMAIN block. @@ -1473,6 +1552,7 @@ #include \"petite_boot.h\" #include \"scheme_boot.h\" #include \"program_boot.h\" +#include \"ffi_symbols.h\" static const char *write_program_tmpfile(void) { static char path[] = \"/tmp/jerboa-prog-XXXXXX\"; @@ -1493,6 +1573,7 @@ int main(int argc, const char *argv[]) { Sregister_boot_file_bytes(\"scheme\", (void *)scheme_boot_data, scheme_boot_size); Sbuild_heap(NULL, NULL); + register_ffi_symbols(); const char *prog_path = write_program_tmpfile(); int status = Sscheme_program(prog_path, argc, argv); @@ -1591,16 +1672,19 @@ int main(int argc, const char *argv[]) { (for-each (lambda (a) (printf " -> ~a\n" a)) archives) archives)))) -(define (compile-c-source src obj-dir cc csv-dir index) - ;; Compile src to obj-dir/extra-<index>-<basename-without-.c>.o +(define (compile-c-source src obj-dir cc csv-dir index extra-cflags) + ;; Compile src to obj-dir/extra-<index>-<basename-without-.c>.o. + ;; extra-cflags: string (raw, appended after -O2) or #f. (let* ([base (path-basename src)] [stem (if (string-ends-with? base ".c") (substring base 0 (- (string-length base) 2)) base)] [out (format "~a/extra-~a-~a.o" obj-dir index stem)] - [cmd (format "~a -I~a -O2 -c ~a -o ~a" + [cflags (if extra-cflags (string-append " " extra-cflags) "")] + [cmd (format "~a -I~a -O2~a -c ~a -o ~a" cc (shell-quote csv-dir) + cflags (shell-quote src) (shell-quote out))]) (printf " ~a\n" cmd) @@ -1624,6 +1708,7 @@ int main(int argc, const char *argv[]) { ;; [--extra-source S.c] (repeatable) ;; [--extra-ldflag F] (repeatable) ;; [--rust-crate Cargo.toml[:features]] (repeatable) + ;; [--main-c FILE] (single) ;; <entry.ss> <output> ;; ;; Builds a standalone executable that bundles Chez + the user's entry script @@ -1634,12 +1719,29 @@ int main(int argc, const char *argv[]) { (let-values ([(extra-archives args) (parse-multi-flag args "--extra-archive")]) (let-values ([(extra-sources args) (parse-multi-flag args "--extra-source")]) (let-values ([(extra-ldflags args) (parse-multi-flag args "--extra-ldflag")]) - (let-values ([(rust-crates rest) (parse-multi-flag args "--rust-crate")]) - (do-binary-build libs cc-arg extra-archives extra-sources - extra-ldflags rust-crates rest)))))))) + (let-values ([(rust-crates args) (parse-multi-flag args "--rust-crate")]) + (let-values ([(main-cs rest) (parse-multi-flag args "--main-c")]) + (let ([main-c-override + (cond + [(null? main-cs) #f] + [else (car (reverse main-cs))])] + ;; Wrap each extra-source path as (path . #f) — no + ;; per-source cflags supported on the CLI; use .jerbuild + ;; for that. + [extra-sources-pairs + (map (lambda (s) (cons s #f)) extra-sources)]) + (do-binary-build libs cc-arg extra-archives + extra-sources-pairs + extra-ldflags rust-crates main-c-override + ;; CLI form: no ffi-symbols, pre-build, or + ;; pre-link — those are config-only. + #f '() '() (current-directory) + rest)))))))))) (define (do-binary-build libs cc-arg extra-archives extra-sources - extra-ldflags rust-crates rest) + extra-ldflags rust-crates main-c-override + ffi-symbols pre-build pre-link config-dir rest) + ;; extra-sources is a list of pairs (abs-path . cflags-or-#f). (when (< (length rest) 2) (error 'jerbuild "binary: usage: jerbuild binary [--libdirs P] [--cc CC] [--extra-archive A] [--extra-source S.c] [--extra-ldflag F] [--rust-crate Cargo.toml[:features]] <entry.ss> <output>")) @@ -1656,6 +1758,11 @@ int main(int argc, const char *argv[]) { [libkernel (format "~a/libkernel.a" csv-dir)] [scheme-h (format "~a/scheme.h" csv-dir)]) + ;; Pre-build hooks run BEFORE existence checks on entry / extra-sources, + ;; since those hooks may be what generates them (e.g. jsh's + ;; jsh-generated.ss + staged coreutils dirs). + (run-hook-commands! "Pre-build" pre-build config-dir '()) + (unless (file-exists? entry) (error 'jerbuild (format "binary: entry not found: ~a" entry))) (for-each @@ -1664,10 +1771,16 @@ int main(int argc, const char *argv[]) { (error 'jerbuild (format "binary: --extra-archive not found: ~a" a)))) extra-archives) (for-each - (lambda (s) - (unless (file-exists? s) - (error 'jerbuild (format "binary: --extra-source not found: ~a" s)))) + (lambda (sp) + (unless (file-exists? (car sp)) + (error 'jerbuild (format "binary: --extra-source not found: ~a" (car sp))))) extra-sources) + (when main-c-override + (unless (file-exists? main-c-override) + (error 'jerbuild (format "binary: --main-c not found: ~a" main-c-override)))) + (when ffi-symbols + (unless (file-exists? ffi-symbols) + (error 'jerbuild (format "binary: (ffi-symbols) file not found: ~a" ffi-symbols)))) (unless (and (file-exists? libkernel) (file-exists? scheme-h) (file-exists? petite-boot) (file-exists? scheme-boot)) (error 'jerbuild @@ -1692,6 +1805,7 @@ int main(int argc, const char *argv[]) { [petite-hdr (format "~a/petite_boot.h" obj-dir)] [scheme-hdr (format "~a/scheme_boot.h" obj-dir)] [program-hdr (format "~a/program_boot.h" obj-dir)] + [ffi-hdr (format "~a/ffi_symbols.h" obj-dir)] [main-c (format "~a/main.c" obj-dir)]) (printf "=== jerbuild binary build ===\n") @@ -1746,21 +1860,54 @@ int main(int argc, const char *argv[]) { (cond [(null? srcs) (reverse acc)] [else - (loop (cdr srcs) - (+ i 1) - (cons (compile-c-source - (car srcs) obj-dir cc csv-dir i) - acc))]))])]) + (let ([sp (car srcs)]) + (loop (cdr srcs) + (+ i 1) + (cons (compile-c-source + (car sp) obj-dir cc csv-dir i (cdr sp)) + acc)))]))])]) (printf "==> [3/5] Embed boots + program as C arrays\n") (embed-bytes-as-c-array petite-boot petite-hdr "petite_boot") (embed-bytes-as-c-array scheme-boot scheme-hdr "scheme_boot") (embed-bytes-as-c-array program-wp-so program-hdr "program_boot") - (printf "==> [4/5] Generate main.c\n") - (call-with-output-file main-c - (lambda (port) (display *binary-main-c-template* port)) - 'replace) + ;; Always emit ffi_symbols.h so main.c (stock or user override) can + ;; #include it unconditionally. With no (ffi-symbols ...) the header + ;; provides an empty register_ffi_symbols() stub. + (cond + [ffi-symbols + (let ([syms (read-ffi-symbol-list ffi-symbols)]) + (printf "==> [4/5] Emit ffi_symbols.h (~a symbol(s) from ~a)\n" + (length syms) ffi-symbols) + (call-with-output-file ffi-hdr + (lambda (port) (write-ffi-symbols-header port syms)) + 'replace))] + [else + (call-with-output-file ffi-hdr + (lambda (port) (write-empty-ffi-symbols-header port)) + 'replace)]) + + (cond + [main-c-override + (printf "==> [4/5] Use user main.c: ~a\n" main-c-override) + (let ([rc (system (format "cp ~a ~a" + (shell-quote main-c-override) + (shell-quote main-c)))]) + (unless (zero? rc) + (error 'jerbuild (format "binary: cp main.c failed (rc=~a)" rc))))] + [else + (printf "==> [4/5] Generate main.c\n") + (call-with-output-file main-c + (lambda (port) (display *binary-main-c-template* port)) + 'replace)]) + + ;; Pre-link hooks: after C compile, before final link. Useful for + ;; archive surgery (e.g. macOS Rust dedup). They see env vars + ;; JERBUILD_OBJ_DIR and JERBUILD_OUTPUT. + (run-hook-commands! "Pre-link" pre-link config-dir + (list (cons "JERBUILD_OBJ_DIR" obj-dir) + (cons "JERBUILD_OUTPUT" output))) (printf "==> [5/5] Compile + link -> ~a\n" output) (let* ([chez-archives @@ -1809,9 +1956,26 @@ int main(int argc, const char *argv[]) { ;; (rust-crates ;; "path/Cargo.toml" ;; ("other/Cargo.toml" features: "crypto,sqlite")) -;; (extra-sources "shim.c" "other.c") ; optional +;; (extra-sources "shim.c" ; optional +;; ("ssh.c" cflags: "-DNO_OPENSSL")) ; per-source CFLAGS ;; (extra-archives "vendor/lib.a") ; optional ;; (extra-ldflags "-framework" "Security") ; optional, raw strings +;; (main-c "support/main.c") ; optional; replaces stock main.c. +;; ; May still use (ffi-symbols ...) — +;; ; user main.c should #include +;; ; "ffi_symbols.h" and call +;; ; register_ffi_symbols() itself. +;; (ffi-symbols "ffi-symbols.list") ; optional; emits ffi_symbols.h in +;; ; obj-dir with extern decls + a +;; ; register_ffi_symbols() function +;; ; that calls Sforeign_symbol() on +;; ; each. Stock main.c includes and +;; ; calls it automatically. +;; (pre-build "stage.sh" "gen.ss") ; optional; sh commands run in the +;; ; .jerbuild dir BEFORE the WPO compile +;; (pre-link "rust-dedup.sh") ; optional; sh commands run AFTER C +;; ; compile but BEFORE final link. +;; ; Env: JERBUILD_OBJ_DIR, JERBUILD_OUTPUT ;; ;; All paths are resolved relative to the .jerbuild file's directory. @@ -1862,17 +2026,32 @@ int main(int argc, const char *argv[]) { [else (error 'jerbuild (format "config: bad rust-crate entry: ~a" form))])) +(define (config-extra-source->spec form base) + ;; Accept "path.c" or ("path.c" cflags: "-DFOO -I/bar"). + ;; Returns a pair (abs-path . cflags-or-#f) for downstream use. + (cond + [(string? form) (cons (resolve-config-path form base) #f)] + [(and (pair? form) (string? (car form))) + (let* ([src (resolve-config-path (car form) base)] + [cflags (find-keyword 'cflags: (cdr form))]) + (cons src cflags))] + [else + (error 'jerbuild (format "config: bad extra-sources entry: ~a" form))])) + (define (load-jerbuild-config path) ;; Returns (values entry output libdirs cc rust-crates - ;; extra-sources extra-archives extra-ldflags). + ;; extra-sources extra-archives extra-ldflags main-c + ;; ffi-symbols pre-build pre-link). + ;; extra-sources entries are pairs (abs-path . cflags-or-#f). (let* ([config-dir (path-dirname path)] [base (if (absolute-path? config-dir) config-dir (format "~a/~a" (current-directory) config-dir))] [forms (read-all-sexps path)] - [entry #f] [output #f] [cc #f] + [entry #f] [output #f] [cc #f] [main-c #f] [ffi-symbols #f] [libdirs '()] [rust-crates '()] [extra-sources '()] - [extra-archives '()] [extra-ldflags '()]) + [extra-archives '()] [extra-ldflags '()] + [pre-build '()] [pre-link '()]) (for-each (lambda (form) (unless (and (pair? form) (symbol? (car form))) @@ -1897,15 +2076,29 @@ int main(int argc, const char *argv[]) { (map (lambda (f) (config-rust-crate->spec f base)) (cdr form)))] [(extra-sources) (set! extra-sources - (map (lambda (p) (resolve-config-path p base)) (cdr form)))] + (map (lambda (p) (config-extra-source->spec p base)) (cdr form)))] [(extra-archives) (set! extra-archives (map (lambda (p) (resolve-config-path p base)) (cdr form)))] [(extra-ldflags) (set! extra-ldflags (cdr form))] + [(main-c) + (unless (= (length form) 2) + (error 'jerbuild "config: (main-c PATH) takes one value")) + (set! main-c (resolve-config-path (cadr form) base))] + [(ffi-symbols) + (unless (= (length form) 2) + (error 'jerbuild "config: (ffi-symbols PATH) takes one value")) + (set! ffi-symbols (resolve-config-path (cadr form) base))] + [(pre-build) + ;; Strings are passed straight to sh -c with cwd=base dir. + ;; No path resolution: commands may start with a script path or `cd`. + (set! pre-build (append pre-build (cdr form)))] + [(pre-link) + (set! pre-link (append pre-link (cdr form)))] [else (error 'jerbuild - (format "config: unknown key ~a in ~a (valid: entry output cc libdirs rust-crates extra-sources extra-archives extra-ldflags)" + (format "config: unknown key ~a in ~a (valid: entry output cc libdirs rust-crates extra-sources extra-archives extra-ldflags main-c ffi-symbols pre-build pre-link)" (car form) path))])) forms) (unless entry @@ -1913,7 +2106,8 @@ int main(int argc, const char *argv[]) { (unless output (error 'jerbuild (format "config: missing required (output PATH) in ~a" path))) (values entry output libdirs cc rust-crates - extra-sources extra-archives extra-ldflags))) + extra-sources extra-archives extra-ldflags main-c + ffi-symbols pre-build pre-link base))) (define (run-build args) ;; jerbuild build [--cc CC] [--config PATH] @@ -1938,12 +2132,14 @@ int main(int argc, const char *argv[]) { (printf "=== jerbuild build ===\n") (printf " Config: ~a\n" config-path) (let-values ([(entry output libdirs cfg-cc rust-crates - extra-sources extra-archives extra-ldflags) + extra-sources extra-archives extra-ldflags main-c + ffi-symbols pre-build pre-link config-dir) (load-jerbuild-config config-path)]) (do-binary-build libdirs (or cc-arg cfg-cc) extra-archives extra-sources extra-ldflags - rust-crates + rust-crates main-c + ffi-symbols pre-build pre-link config-dir (list entry output))))))) ;;;; ============================================================ --- a/support/build-jerbuild.sh +++ b/support/build-jerbuild.sh @@ -352,6 +352,7 @@ int main(int argc, const char *argv[]) { " jerbuild binary [--libdirs <p>] [--cc CC]\n" " [--extra-archive A] [--extra-source S.c]\n" " [--extra-ldflag F] [--rust-crate Cargo.toml[:features]]\n" + " [--main-c FILE]\n" " <entry.ss> <output> # build standalone binary\n" " jerbuild build [--cc CC] [--config PATH] # read .jerbuild, build\n" " jerbuild --jerboa-home # extract+print stdlib path\n"