1d345bfd0f
A built binary dropped its deps.edn :jolt/native declarations and its
resource roots, so an FFI+resources app (ring-app) failed at runtime:
sockets/sqlite gave 'no entry for socket' and io/resource returned nil.
The buildsmoke fixture is pure compute, so neither path was exercised.
The launcher now loads required + :process native libs before the app's
top-level forms (a library's defcfn resolves its foreign-procedure symbols
at top-level eval during startup, so the libs must be loaded first);
optional libs load in the scheme-start launcher, where a missing lib is
caught rather than aborting the heap build.
deps.edn :jolt/build {:embed [dirs]} bakes those dirs' files into the heap
(register-embedded-resource! at heap build), so io/resource serves them with
no files on disk. Non-embedded resources resolve at runtime against JOLT_PWD,
and io/file reads (e.g. config.edn) stay external.
build-binary now takes the encoded natives, embed dirs, and project paths
from cmd-build; deps/resolve-project surfaces them. Buildsmoke fixture grows
an embedded resource + a :process native to cover both paths.
167 lines
8.8 KiB
Scheme
167 lines
8.8 KiB
Scheme
;; ffi.ss — the runtime side of jolt's foreign-function interface (jolt.ffi).
|
|
;;
|
|
;; A jolt LIBRARY binds native code itself: it loads a shared object and declares
|
|
;; typed foreign functions, then exposes a Clojure API. The TYPED CALL is lowered
|
|
;; at compile time to a Chez `foreign-procedure` by the backend (the
|
|
;; `jolt.ffi/foreign-fn` special form) — this file provides everything that does
|
|
;; NOT need compile-time types: loading libraries, allocating/reading/writing
|
|
;; foreign memory, and string/pointer marshaling. All exposed under `jolt.ffi`.
|
|
;;
|
|
;; A foreign pointer is a Chez machine address (an exact integer / uptr), the same
|
|
;; representation `void*` arguments and results use, so pointers flow between
|
|
;; foreign-fn calls and these helpers transparently.
|
|
|
|
;; --- loading shared objects --------------------------------------------------
|
|
;; (jolt.ffi/load-library name) loads a .so/.dylib by name (resolved by the OS
|
|
;; loader against the standard search paths). A library typically calls this once
|
|
;; at load with a platform-specific name. (load-library) with no name (or #f)
|
|
;; loads the running process's own symbols (libc, sockets).
|
|
(define (ffi-load-library . args)
|
|
(if (or (null? args) (jolt-nil? (car args)))
|
|
(begin (load-shared-object #f) jolt-nil)
|
|
(begin (load-shared-object (jolt-str-render-one (car args))) jolt-nil)))
|
|
|
|
(define (ffi-loaded? name)
|
|
(guard (e (#t #f)) (load-shared-object (jolt-str-render-one name)) #t))
|
|
|
|
;; --- foreign type keywords ---------------------------------------------------
|
|
;; The keyword type names jolt.ffi accepts (in foreign-fn signatures and the
|
|
;; memory accessors) map to Chez foreign types. Kept in one place so the backend
|
|
;; (compile-time, for foreign-procedure) and these accessors (runtime, for
|
|
;; foreign-ref/set!) agree.
|
|
(define (ffi-type->chez kw)
|
|
(let ((n (if (keyword-t? kw) (keyword-t-name kw) (jolt-str-render-one kw))))
|
|
(cond
|
|
((string=? n "int") 'int)
|
|
((string=? n "uint") 'unsigned-int)
|
|
((string=? n "long") 'long)
|
|
((string=? n "ulong") 'unsigned-long)
|
|
((string=? n "int64") 'integer-64)
|
|
((string=? n "uint64") 'unsigned-64)
|
|
((string=? n "size_t") 'size_t)
|
|
((string=? n "ssize_t") 'ssize_t)
|
|
((string=? n "iptr") 'iptr)
|
|
((string=? n "uptr") 'uptr)
|
|
((string=? n "double") 'double)
|
|
((string=? n "float") 'float)
|
|
((or (string=? n "pointer") (string=? n "void*")) 'void*)
|
|
((string=? n "string") 'string)
|
|
((string=? n "void") 'void)
|
|
((or (string=? n "uint8") (string=? n "u8") (string=? n "byte")) 'unsigned-8)
|
|
((string=? n "char") 'char)
|
|
(else (error #f (string-append "jolt.ffi: unknown foreign type :" n))))))
|
|
|
|
;; --- foreign memory ----------------------------------------------------------
|
|
;; alloc returns a pointer (integer address). The caller frees it. read/write take
|
|
;; a type keyword and an optional byte offset.
|
|
(define (ffi-alloc nbytes) (foreign-alloc (jnum->exact nbytes)))
|
|
(define (ffi-free ptr) (foreign-free (jnum->exact ptr)) jolt-nil)
|
|
(define (ffi-read ptr ty . off)
|
|
(foreign-ref (ffi-type->chez ty) (jnum->exact ptr) (if (pair? off) (jnum->exact (car off)) 0)))
|
|
(define (ffi-write ptr ty off val)
|
|
(foreign-set! (ffi-type->chez ty) (jnum->exact ptr) (jnum->exact off) val) jolt-nil)
|
|
;; sizeof a foreign type (for laying out structs / arrays).
|
|
(define (ffi-sizeof ty) (foreign-sizeof (ffi-type->chez ty)))
|
|
(define (ffi-null? ptr) (and (number? ptr) (= (jnum->exact ptr) 0)))
|
|
(define ffi-null 0)
|
|
|
|
;; --- buffer I/O (known length) ----------------------------------------------
|
|
;; read n bytes at ptr as a string (UTF-8, falling back to latin1 for invalid
|
|
;; sequences) — for a socket recv buffer and similar fixed-length reads.
|
|
(define (ffi-read-bytes ptr n)
|
|
(let* ((n (jnum->exact n)) (p (jnum->exact ptr)) (bv (make-bytevector n)))
|
|
(do ((i 0 (+ i 1))) ((= i n)) (bytevector-u8-set! bv i (foreign-ref 'unsigned-8 p i)))
|
|
(guard (e (#t (list->string (map integer->char (bytevector->u8-list bv))))) (utf8->string bv))))
|
|
;; write a string's UTF-8 bytes into ptr (no NUL terminator); return the count.
|
|
(define (ffi-write-bytes ptr s)
|
|
(let* ((bv (string->utf8 (jolt-str-render-one s))) (n (bytevector-length bv)) (p (jnum->exact ptr)))
|
|
(do ((i 0 (+ i 1))) ((= i n)) (foreign-set! 'unsigned-8 p i (bytevector-u8-ref bv i)))
|
|
n))
|
|
(def-var! "jolt.ffi" "read-bytes" ffi-read-bytes)
|
|
(def-var! "jolt.ffi" "write-bytes" ffi-write-bytes)
|
|
|
|
;; --- byte-array buffer I/O (binary-faithful) --------------------------------
|
|
;; Move raw bytes between a jolt byte-array (jolt-array kind 'byte) and foreign
|
|
;; memory, byte-exact (no UTF-8 / latin1 decode) — for socket recv/send and the
|
|
;; zlib / OpenSSL buffers an HTTP client passes through. read-array returns a
|
|
;; fresh byte-array of n bytes; write-array copies a byte-array's bytes into ptr
|
|
;; and returns the count.
|
|
(define (ffi-read-array ptr n)
|
|
(let* ((n (jnum->exact n)) (p (jnum->exact ptr)) (v (make-vector n 0)))
|
|
(do ((i 0 (+ i 1))) ((= i n)) (vector-set! v i (foreign-ref 'unsigned-8 p i)))
|
|
(make-jolt-array v 'byte)))
|
|
(define (ffi-write-array ptr arr)
|
|
(let* ((v (jolt-array-vec arr)) (n (vector-length v)) (p (jnum->exact ptr)))
|
|
(do ((i 0 (+ i 1))) ((= i n)) (foreign-set! 'unsigned-8 p i (bitwise-and (exact (vector-ref v i)) #xff)))
|
|
n))
|
|
(def-var! "jolt.ffi" "read-array" ffi-read-array)
|
|
(def-var! "jolt.ffi" "write-array" ffi-write-array)
|
|
|
|
;; --- string / bytevector marshaling ------------------------------------------
|
|
;; A C string result already comes back as a jolt string (the `string` foreign
|
|
;; type). For a `void*` that points at a NUL-terminated C string, read it here.
|
|
(define (ffi-ptr->string ptr)
|
|
(if (ffi-null? ptr) jolt-nil
|
|
(let ((p (jnum->exact ptr)))
|
|
(let loop ((i 0) (acc '()))
|
|
(let ((b (foreign-ref 'unsigned-8 p i)))
|
|
(if (= b 0) (utf8->string (u8-list->bytevector (reverse acc)))
|
|
(loop (+ i 1) (cons b acc))))))))
|
|
;; Copy a jolt string's UTF-8 bytes into a freshly alloc'd NUL-terminated buffer;
|
|
;; the caller frees it. Returns the pointer.
|
|
(define (ffi-string->ptr s)
|
|
(let* ((bv (string->utf8 (jolt-str-render-one s))) (n (bytevector-length bv))
|
|
(p (foreign-alloc (+ n 1))))
|
|
(do ((i 0 (+ i 1))) ((= i n)) (foreign-set! 'unsigned-8 p i (bytevector-u8-ref bv i)))
|
|
(foreign-set! 'unsigned-8 p n 0)
|
|
p))
|
|
|
|
;; --- callbacks: receive calls FROM C ----------------------------------------
|
|
;; jolt.ffi/foreign-callable lowers to (jolt-ffi-register-callable! (foreign-callable …)).
|
|
;; A foreign-callable code object must be LOCKED (so the collector neither moves
|
|
;; nor reclaims it) and RETAINED while C may still call through its entry point.
|
|
;; Register it keyed by that entry-point address (a jolt pointer integer) — which
|
|
;; is what the caller hands to C; free-callable unlocks and drops it. A callback
|
|
;; left registered lives for the process (the GTK-signal-handler common case).
|
|
(define ffi-callable-table (make-eqv-hashtable)) ; entry-point addr -> code object
|
|
(define (jolt-ffi-register-callable! co)
|
|
(lock-object co)
|
|
(let ((addr (foreign-callable-entry-point co)))
|
|
(hashtable-set! ffi-callable-table addr co)
|
|
addr))
|
|
(define (ffi-free-callable addr)
|
|
(let* ((a (jnum->exact addr)) (co (hashtable-ref ffi-callable-table a #f)))
|
|
(when co (unlock-object co) (hashtable-delete! ffi-callable-table a))
|
|
jolt-nil))
|
|
|
|
;; --- native libraries for a standalone binary -------------------------------
|
|
;; `jolt build` bakes a project's deps.edn :jolt/native declarations into the
|
|
;; launcher, which loads them at startup (load-shared-object isn't part of the
|
|
;; saved heap, so it must run in the built process, not at heap build). process?
|
|
;; loads the running binary's own symbols (libc sockets); otherwise try each
|
|
;; platform candidate in turn and fail unless the spec is optional.
|
|
(define (jolt-build-load-native cands optional? process?)
|
|
(if process?
|
|
(begin (load-shared-object #f) #t)
|
|
(let loop ((cs cands))
|
|
(cond
|
|
((null? cs)
|
|
(unless optional?
|
|
(error 'jolt-build "required native library not found" cands))
|
|
#f)
|
|
((guard (e (#t #f)) (load-shared-object (car cs)) #t) #t)
|
|
(else (loop (cdr cs)))))))
|
|
|
|
;; --- expose under jolt.ffi ---------------------------------------------------
|
|
(def-var! "jolt.ffi" "free-callable" ffi-free-callable)
|
|
(def-var! "jolt.ffi" "load-library" ffi-load-library)
|
|
(def-var! "jolt.ffi" "loaded?" (lambda (n) (if (ffi-loaded? n) #t #f)))
|
|
(def-var! "jolt.ffi" "alloc" ffi-alloc)
|
|
(def-var! "jolt.ffi" "free" ffi-free)
|
|
(def-var! "jolt.ffi" "read" ffi-read)
|
|
(def-var! "jolt.ffi" "write" ffi-write)
|
|
(def-var! "jolt.ffi" "sizeof" ffi-sizeof)
|
|
(def-var! "jolt.ffi" "null?" (lambda (p) (if (ffi-null? p) #t #f)))
|
|
(def-var! "jolt.ffi" "null" ffi-null)
|
|
(def-var! "jolt.ffi" "ptr->string" ffi-ptr->string)
|
|
(def-var! "jolt.ffi" "string->ptr" ffi-string->ptr)
|