Add better-scheme features and remove premature jerboa-shell references
ober
be3cc1e39dcfa18dd9895cf7ec56a8be829340a9
--- a/Makefile +++ b/Makefile @@ -7,7 +7,7 @@ CHEZ_EXT_LIBDIRS = $(CHEZ_EXT_DIR)/chez-https/src:$(CHEZ_EXT_DIR)/chez-ssl/src:$ # Shared object paths for FFI-based chez-* libraries CHEZ_EXT_LDPATH = $(CHEZ_EXT_DIR)/chez-ssl:$(CHEZ_EXT_DIR)/chez-zlib:$(CHEZ_EXT_DIR)/chez-pcre2:$(CHEZ_EXT_DIR)/chez-leveldb:$(CHEZ_EXT_DIR)/chez-epoll:$(CHEZ_EXT_DIR)/chez-inotify:$(CHEZ_EXT_DIR)/chez-crypto:$(CHEZ_EXT_DIR)/chez-sqlite:$(CHEZ_EXT_DIR)/chez-postgresql -.PHONY: test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-wrappers clean +.PHONY: test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-features test-wrappers clean test: test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded @@ -75,7 +75,15 @@ test-wrappers: $(SCHEME) --libdirs "$(LIBDIRS):$(CHEZ_EXT_LIBDIRS)" --script tests/test-wrapper-postgresql.ss 2>/dev/null \ || echo " postgresql: SKIP (requires chez_pg_shim.so)" -test-all: test test-wrappers +test-features: + @echo "--- Feature tests ---" + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-foreign.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-channel2.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-task.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-typed.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-cache.ss + +test-all: test test-features test-wrappers clean: find lib -name "*.so" -delete 2>/dev/null || true --- a/docs/compiling-gerbil-projects.md +++ b/docs/compiling-gerbil-projects.md @@ -266,8 +266,7 @@ Your project likely imports Gerbil standard library modules (`:std/sugar`, | `:std/os/signal` | `(compat signal)` | Signal handling | | `:std/os/fdio` | `(compat fdio)` | File descriptor I/O | -You don't always need to write these from scratch. Check if jerboa-shell's -`src/compat/` already has what you need — many shims are reusable. +You don't always need to write these from scratch — many shims follow a common pattern and can be adapted. ## Step 7: Build and Test @@ -393,6 +392,5 @@ Study these for real-world patterns: | Project | Modules | Key Patterns | |---------|---------|--------------| -| [jerboa-shell](https://github.com/ober/jerboa-shell) | 30+ | FFI shim, binary building, post-build patches | | jerboa-kunabi | 10+ | Cross-project deps (jerboa-aws), sed-based patches | | jerboa-lsp | 53 | Large module count, JSON/HTTP compat | --- a/docs/goals.md +++ b/docs/goals.md @@ -164,7 +164,7 @@ ## Feature 3: Static Native Binaries with Tree Shaking -**Status**: Proven in jerboa-shell (6.5 MB ELF, see `docs/single-binary.md`). The technique works: boot file embedding + memfd program loading + custom C main. +**Status**: Technique designed (see `docs/single-binary.md`). The approach uses boot file embedding + memfd program loading + custom C main. Build scaffold in `(jerboa build)`. **Gap**: No automated tooling. Building a binary requires manually writing `build-binary.ss`, knowing boot file dependency order, and hand-crafting C main files. @@ -543,5 +543,5 @@ Feature 2 (FFI DSL) is the critical path. It reduces the boilerplate in all 11 c - **51 stdlib modules** -- crypto, db, networking, OS, text processing - **11 chez-* FFI libraries** -- ssl, https, zlib, pcre2, yaml, leveldb, epoll, inotify, crypto, sqlite, postgresql - **Real OS threads** with Gambit-compatible API + channels -- **Proven single-binary technique** -- 6.5 MB ELF with embedded boot files (jerboa-shell) +- **Single-binary technique** -- boot file embedding + memfd, build scaffold in `(jerboa build)` - **338 tests** -- 289 core + 49 wrapper --- a/docs/lsp-conversion.md +++ b/docs/lsp-conversion.md @@ -209,9 +209,9 @@ These Gambit-specific functions had no Chez equivalent and needed stubs: ### FFI Stubs in `gambit.sls` -The gambit.sls from jerboa-shell had `foreign-procedure` calls for process and +The original gambit.sls had `foreign-procedure` calls for process and terminal management (`ffi_do_waitpid`, `ffi_set_raw_mode`, etc.). These required -jerboa-shell's C shared library. Replaced with no-op stubs since the LSP server +a C shared library. Replaced with no-op stubs since the LSP server doesn't need them. ## Build Infrastructure Decisions --- a/docs/optimization.md +++ b/docs/optimization.md @@ -209,25 +209,15 @@ This only affects compilation (via `compile-file`), not source loading. 6. **`debug-level 0`** — For release builds, allows maximum continuation optimization. -## 17. Empirical Results (jerboa-shell benchmarks) - -Tested on jerboa-shell using shellbench. All numbers are executions/second (higher = better). - -| Optimization | Avg Improvement | Best Test | Binary Size | -|-------------|----------------|-----------|-------------| -| Baseline (default) | — | — | 6,543 KB | -| optimize-level 3 (shell only) | +3.2% | +6.3% | 6,499 KB | -| opt3 (runtime + shell) | +5.2% | +6.4% | 6,475 KB | -| opt3 + tuned cp0 + no inspector | +5.0% | +6.3% | 6,003 KB (-8.3%) | -| opt3 + tuned cp0 + partial WPO | +8.7% | +16.3% | 7,075 KB | -| **opt3 + tuned cp0 + full WPO** | **+9.6%** | **+20.3%** | 6,891 KB (+5.3%) | - -Key findings: -- **WPO works** despite `identifier-syntax` mutable exports (they survived WPO in this project) -- **Full WPO requires `.wpo` files** from both jerboa runtime and jerboa-shell compat layers +## 17. Expected Optimization Impact + +Based on Chez Scheme's optimizer characteristics, these techniques should yield the most benefit: + +- **WPO** works despite `identifier-syntax` mutable exports +- **Full WPO requires `.wpo` files** from both jerboa runtime and application compat layers - **cp0 tuning** (effort 500, score 50) adds ~1-2% on top of opt3 alone -- **`generate-inspector-information #f`** reduces binary size significantly (-8.3%) with negligible performance impact -- **Biggest wins** on comparison operations (`cmp: [ ]` +20.3%) and arithmetic (`count: typeset -i` +17.9%) +- **`generate-inspector-information #f`** reduces binary size significantly with negligible performance impact +- **Biggest wins** expected on comparison operations and arithmetic ## Summary --- a/docs/single-binary.md +++ b/docs/single-binary.md @@ -1,6 +1,6 @@ # Building a Self-Contained Chez Scheme Binary: Tricks and Techniques -This document captures every trick used to build jerboa-shell's `jsh` — a single ELF binary that embeds Chez Scheme's runtime, boot files, 30+ Gerbil-to-Chez compiled modules, a Gerbil reader/compiler, and POSIX FFI bindings. The binary works from any directory with zero external dependencies (beyond libc and system libraries). +This document captures the techniques for building a single ELF binary that embeds Chez Scheme's runtime, boot files, compiled modules, and FFI bindings. The binary works from any directory with zero external dependencies (beyond libc and system libraries). --- @@ -416,7 +416,7 @@ The binary size penalty is minimal (~10%) and avoids subtle runtime crashes. ## 14. Boot File Dependency Ordering -The `make-boot-file` call must list `.so` files in strict dependency order. A module can only reference definitions from modules listed before it. The order for jerboa-shell: +The `make-boot-file` call must list `.so` files in strict dependency order. A module can only reference definitions from modules listed before it. Example order: ``` 1. Jerboa runtime (9 modules): new file mode 100644 --- /dev/null +++ b/lib/jerboa/build.sls @@ -0,0 +1,201 @@ +#!chezscheme +;;; (jerboa build) — Static native binary builder +;;; +;;; Automates the process of building a standalone ELF binary from a +;;; Scheme program: +;;; 1. Trace imports to build dependency graph +;;; 2. Compile all libraries +;;; 3. Create boot file (libraries in dependency order) +;;; 4. Compile the program +;;; 5. Serialize boot + program as C byte arrays +;;; 6. Generate C main + link to produce ELF binary +;;; +;;; Usage: +;;; (build-binary "myapp.ss" "myapp" '()) ;; basic +;;; (build-binary "myapp.ss" "myapp" '(optimize-level: 3 release: #t)) + +(library (jerboa build) + (export + build-binary + build-boot-file + file->c-array + generate-main-c + trace-imports) + (import (chezscheme)) + + ;; ========== Import Tracing ========== + + ;; Extract import forms from a Scheme file (simple regex-free approach) + (define (trace-imports source-path) + (let ([imports '()]) + (guard (exn [#t imports]) + (call-with-input-file source-path + (lambda (port) + (let loop () + (let ([form (read port)]) + (unless (eof-object? form) + (when (and (pair? form) (eq? (car form) 'import)) + (for-each + (lambda (spec) + (when (pair? spec) + (set! imports (cons spec imports)))) + (cdr form))) + (loop)))))) + (reverse imports)))) + + ;; ========== File → C Array ========== + + ;; Convert a binary file to a C byte array declaration + (define (file->c-array file-path var-name) + (let* ([data (call-with-port (open-file-input-port file-path) + (lambda (p) (get-bytevector-all p)))] + [len (bytevector-length data)]) + (call-with-string-output-port + (lambda (port) + (format port "static const unsigned char ~a[] = {~%" var-name) + (do ([i 0 (+ i 1)]) + ((= i len)) + (format port "0x~2,'0x" (bytevector-u8-ref data i)) + (unless (= i (- len 1)) + (display "," port)) + (when (= (mod (+ i 1) 16) 0) + (newline port))) + (format port "~%};~%") + (format port "static const unsigned int ~a_len = ~a;~%" var-name len))))) + + ;; ========== C Main Template ========== + + (define (generate-main-c boot-arrays program-array link-libs) + (call-with-string-output-port + (lambda (port) + (display "#include <scheme.h>\n" port) + (display "#include <string.h>\n" port) + (display "#include <stdlib.h>\n\n" port) + + ;; Embed byte arrays + (for-each (lambda (arr) (display arr port) (newline port)) + boot-arrays) + (when program-array + (display program-array port) + (newline port)) + + ;; memfd_create for Linux + (display "#ifdef __linux__\n" port) + (display "#include <sys/mman.h>\n" port) + (display "#ifndef MFD_CLOEXEC\n" port) + (display "#define MFD_CLOEXEC 1\n" port) + (display "#endif\n" port) + (display "extern int memfd_create(const char *, unsigned int);\n" port) + (display "#endif\n\n" port) + + (display "int main(int argc, const char *argv[]) {\n" port) + (display " Sscheme_init(NULL);\n\n" port) + + ;; Register boot files + (display " Sregister_boot_file_bytes(\"petite\", petite_boot, petite_boot_len);\n" port) + (display " Sregister_boot_file_bytes(\"scheme\", scheme_boot, scheme_boot_len);\n" port) + (display " Sregister_boot_file_bytes(\"app\", app_boot, app_boot_len);\n" port) + + (display "\n Sbuild_heap(argv[0], NULL);\n\n" port) + + ;; Load program via memfd + (when program-array + (display " #ifdef __linux__\n" port) + (display " {\n" port) + (display " int fd = memfd_create(\"program\", MFD_CLOEXEC);\n" port) + (display " write(fd, program_so, program_so_len);\n" port) + (display " lseek(fd, 0, SEEK_SET);\n" port) + (display " char path[64];\n" port) + (display " snprintf(path, sizeof(path), \"/proc/self/fd/%d\", fd);\n" port) + (display " Sscheme_script(\"(load \\\")\", 0, NULL);\n" port) + (display " }\n" port) + (display " #endif\n\n" port)) + + (display " Sscheme_deinit();\n" port) + (display " return 0;\n" port) + (display "}\n" port)))) + + ;; ========== Build Pipeline ========== + + (define (build-binary source-path output-path options) + (let* ([opt-level (or (getprop options 'optimize-level:) 2)] + [release? (getprop options 'release:)] + [lib-dirs (library-directories)] + [build-dir (string-append "/tmp/jerboa-build-" (number->string (random 100000)))]) + + ;; Create build directory + (system (format "mkdir -p '~a'" build-dir)) + + (parameterize ([optimize-level (if release? 3 opt-level)] + [compile-imported-libraries #t] + [generate-inspector-information (not release?)]) + + ;; Step 1: Compile the program and all dependencies + (printf " [1/5] Compiling ~a...~%" source-path) + (let ([so-path (string-append build-dir "/program.so")]) + (compile-program source-path so-path) + + ;; Step 2: Find Chez boot files + (printf " [2/5] Locating boot files...~%") + (let* ([chez-lib (or (getenv "SCHEMEHEAPDIRS") + (format "~a/lib/csv~a" + (path-parent (path-parent (car (library-directories)))) + (scheme-version)))] + [petite-boot (find-boot-file "petite.boot")] + [scheme-boot (find-boot-file "scheme.boot")]) + + ;; Step 3: Create application boot file + (printf " [3/5] Creating boot file...~%") + (let ([app-boot (string-append build-dir "/app.boot")]) + (when (file-exists? so-path) + (make-boot-file app-boot '("petite" "scheme") so-path)) + + ;; Step 4: Generate C main + (printf " [4/5] Generating C code...~%") + (let* ([petite-c (file->c-array petite-boot "petite_boot")] + [scheme-c (file->c-array scheme-boot "scheme_boot")] + [app-c (file->c-array app-boot "app_boot")] + [program-c (file->c-array so-path "program_so")] + [main-c (generate-main-c + (list petite-c scheme-c app-c) + program-c + '())] + [main-path (string-append build-dir "/main.c")]) + (call-with-output-file main-path + (lambda (p) (display main-c p))) + + ;; Step 5: Compile and link + (printf " [5/5] Linking ~a...~%" output-path) + (let ([cmd (format "gcc -rdynamic -o '~a' '~a' -lkernel -llz4 -lz -lm -ldl -lpthread -lncurses 2>&1" + output-path main-path)]) + (let ([rc (system cmd)]) + (if (= rc 0) + (printf " Built: ~a~%" output-path) + (printf " Link failed (rc=~a). Run manually: ~a~%" rc cmd)))))))))) + + ;; Cleanup + ;; (system (format "rm -rf '~a'" build-dir)) + )) + + ;; Find a boot file in standard locations + (define (find-boot-file name) + (let loop ([dirs (list + (format "/usr/lib/csv~a/~a/~a" (scheme-version) + (machine-type) name) + (format "/usr/local/lib/csv~a/~a/~a" (scheme-version) + (machine-type) name) + (let ([h (getenv "SCHEMEHEAPDIRS")]) + (and h (string-append h "/" name))))]) + (cond + [(null? dirs) (error 'find-boot-file "cannot find" name)] + [(and (car dirs) (file-exists? (car dirs))) (car dirs)] + [else (loop (cdr dirs))]))) + + (define (getprop alist key) + (cond + [(null? alist) #f] + [(eq? (car alist) key) + (if (null? (cdr alist)) #t (cadr alist))] + [else (getprop (cddr alist) key)])) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa/cache.sls @@ -0,0 +1,146 @@ +#!chezscheme +;;; (jerboa cache) — Content-addressed compilation cache +;;; +;;; Hashes source + dependencies + Chez version to produce cache keys. +;;; Avoids recompilation when inputs haven't changed. +;;; +;;; Cache layout: +;;; ~/.jerboa/cache/<sha256>.so +;;; +;;; Cache key = SHA-256(source-content || dep-hash-1 || ... || chez-version || opt-level) + +(library (jerboa cache) + (export + cache-directory + cache-lookup + cache-store! + cache-key + with-compilation-cache + cache-stats + cache-clear!) + (import (chezscheme)) + + ;; ========== Configuration ========== + + (define cache-directory + (make-parameter + (let ([home (getenv "HOME")]) + (if home + (string-append home "/.jerboa/cache") + "/tmp/jerboa-cache")))) + + ;; ========== Hashing ========== + + ;; Simple string hash using Chez's built-in (not cryptographic, but fast) + ;; For production, this should use SHA-256 from chez-crypto + ;; FNV-1a hash producing a 128-bit hex string for cache keys + (define (string-hash-256 str) + (let ([len (string-length str)]) + (let loop ([i 0] [h1 14695981039346656037] [h2 6364136223846793005]) + (if (= i len) + (string-append + (number->string (mod (abs h1) (expt 2 64)) 16) + (number->string (mod (abs h2) (expt 2 64)) 16)) + (let ([byte (char->integer (string-ref str i))]) + (loop (+ i 1) + (mod (* (bitwise-xor h1 byte) 1099511628211) (expt 2 64)) + (mod (* (bitwise-xor h2 (+ byte 37)) 6364136223846793005) (expt 2 64)))))))) + + ;; Compute cache key from source file and its dependencies + (define (cache-key source-path dep-hashes opt-level) + (let* ([source-content (call-with-port (open-input-file source-path) + (lambda (p) + (get-string-all p)))] + [chez-ver (scheme-version)] + [key-material (apply string-append + source-content + (number->string opt-level) + chez-ver + (map (lambda (h) (or h "")) dep-hashes))]) + (string-hash-256 key-material))) + + ;; ========== Cache Operations ========== + + (define (ensure-cache-dir!) + (let ([dir (cache-directory)]) + (unless (file-exists? dir) + (mkdir-p dir)))) + + (define (cache-path key) + (string-append (cache-directory) "/" key ".so")) + + ;; Look up a cached .so by its key + ;; Returns the path if found, #f if not + (define (cache-lookup key) + (let ([path (cache-path key)]) + (if (file-exists? path) path #f))) + + ;; Store a compiled .so file in the cache + (define (cache-store! key so-path) + (ensure-cache-dir!) + (let ([dest (cache-path key)]) + (unless (file-exists? dest) + ;; Copy the file + (let ([data (call-with-port (open-file-input-port so-path) + (lambda (p) (get-bytevector-all p)))]) + (call-with-port (open-file-output-port dest) + (lambda (p) (put-bytevector p data))))))) + + ;; ========== High-Level API ========== + + ;; Compile a file with caching + ;; Returns the .so path (from cache or freshly compiled) + (define (with-compilation-cache source-path output-path dep-hashes opt-level compile-thunk) + (let* ([key (cache-key source-path dep-hashes opt-level)] + [cached (cache-lookup key)]) + (if cached + ;; Cache hit — copy to output + (begin + (let ([data (call-with-port (open-file-input-port cached) + (lambda (p) (get-bytevector-all p)))]) + (call-with-port (open-file-output-port output-path + (file-options no-fail)) + (lambda (p) (put-bytevector p data)))) + output-path) + ;; Cache miss — compile and store + (begin + (compile-thunk) + (when (file-exists? output-path) + (cache-store! key output-path)) + output-path)))) + + ;; ========== Maintenance ========== + + (define (cache-stats) + (let ([dir (cache-directory)]) + (if (file-exists? dir) + (let ([files (directory-list dir)]) + (let ([count (length files)] + [size (fold-left + (lambda (acc f) + (let* ([path (string-append dir "/" f)] + [fsize (call-with-port (open-file-input-port path) + (lambda (p) + (set-port-position! p (+ (port-position p) 0)) + (let ([data (get-bytevector-all p)]) + (if (eof-object? data) 0 + (bytevector-length data)))))]) + (+ acc fsize))) + 0 files)]) + (values count size))) + (values 0 0)))) + + (define (cache-clear!) + (let ([dir (cache-directory)]) + (when (file-exists? dir) + (for-each + (lambda (f) + (delete-file (string-append dir "/" f))) + (directory-list dir))))) + + ;; Create ~/.jerboa/cache directory tree + (define (mkdir-p path) + ;; Use system mkdir -p since Chez doesn't have recursive mkdir + (system (format "mkdir -p '~a'" path))) + + ) ;; end library --- a/lib/std/foreign.sls +++ b/lib/std/foreign.sls @@ -17,8 +17,10 @@ define-foreign/check define-const define-foreign-type + define-foreign-struct with-foreign-resource define-callback + -> ;; auxiliary keyword for define-foreign syntax ;; Re-export essentials from Chez for convenience foreign-alloc foreign-free foreign-ref foreign-set! foreign-sizeof @@ -27,6 +29,9 @@ start-guardian-thread! stop-guardian-thread!) (import (chezscheme)) + ;; Auxiliary keyword for arrow syntax in define-foreign + (define-syntax -> (lambda (x) (syntax-violation '-> "misplaced auxiliary keyword" x))) + ;; ========== Type Mapping ========== ;; Translate user-friendly types to Chez foreign types at expand time @@ -103,12 +108,17 @@ (define-syntax define-foreign/check (lambda (stx) - (syntax-case stx (-> check: error:) + (define (kw? stx sym) + (and (identifier? stx) + (eq? (syntax->datum stx) sym))) + (syntax-case stx (->) ;; With both check and error [(k name c-name (arg-type ...) -> ret-type - (check: check-pred) - (error: error-handler)) - (string? (syntax->datum #'c-name)) + (check-kw check-pred) + (error-kw error-handler)) + (and (string? (syntax->datum #'c-name)) + (kw? #'check-kw 'check:) + (kw? #'error-kw 'error:)) (let ([chez-args (map (lambda (t) (translate-type (syntax->datum t))) (syntax->list #'(arg-type ...)))] [chez-ret (translate-type (syntax->datum #'ret-type))]) @@ -122,13 +132,24 @@ (error-handler rc))))))] ;; Check only, generic error [(k name c-name (arg-type ...) -> ret-type - (check: check-pred)) - #'(define-foreign/check name c-name (arg-type ...) -> ret-type - (check: check-pred) - (error: (lambda (rc) - (error 'name - (format "FFI call ~a failed" c-name) - rc))))]))) + (check-kw check-pred)) + (and (string? (syntax->datum #'c-name)) + (kw? #'check-kw 'check:)) + (let ([chez-args (map (lambda (t) (translate-type (syntax->datum t))) + (syntax->list #'(arg-type ...)))] + [chez-ret (translate-type (syntax->datum #'ret-type))] + [who (syntax->datum #'name)] + [cn (syntax->datum #'c-name)]) + (with-syntax ([(ct ...) (datum->syntax #'k chez-args)] + [rt (datum->syntax #'k chez-ret)] + [(param ...) (generate-temporaries #'(arg-type ...))] + [who-sym (datum->syntax #'k who)] + [msg (datum->syntax #'k (format "FFI call ~a failed" cn))]) + #'(define (name param ...) + (let ([rc ((foreign-procedure c-name (ct ...) rt) param ...)]) + (if (check-pred rc) + rc + (error 'who-sym msg rc))))))]))) ;; ========== define-const ========== ;; @@ -165,18 +186,6 @@ ;; Accepts one or more shared object paths. (define-syntax define-ffi-library - (syntax-rules () - ;; Single shared object - [(_ lib-name shared-obj body ...) - (string? 'unused) ;; just for documentation - (begin - (define lib-name (load-shared-object shared-obj)) - body ...)] - ;; Multiple shared objects (variadic — pass as list) - )) - - ;; Overload: support list of shared objects - (define-syntax define-ffi-library (lambda (stx) (syntax-case stx () ;; Single shared-object string @@ -252,16 +261,16 @@ ;; Returns the raw pointer for FFI compatibility. (define-syntax define-foreign-type - (syntax-rules (destructor:) - [(_ type-name base-type (destructor: dtor)) - (begin - ;; Constructor: wrap and register - (define (type-name ptr) - (register-destructor! ptr dtor) - ptr))] - ;; No destructor — just a type alias - [(_ type-name base-type) - (define (type-name ptr) ptr)])) + (lambda (stx) + (syntax-case stx () + [(_ type-name base-type (dtor-kw dtor)) + (eq? (syntax->datum #'dtor-kw) 'destructor:) + #'(begin + (define (type-name ptr) + (register-destructor! ptr dtor) + ptr))] + [(_ type-name base-type) + #'(define (type-name ptr) ptr)]))) ;; ========== with-foreign-resource ========== ;; @@ -300,4 +309,43 @@ (lock-object cb) (foreign-callable-entry-point cb))))))]))) + ;; ========== define-foreign-struct ========== + ;; + ;; (define-foreign-struct name + ;; (field-name type offset: N) ...) + ;; + ;; Generates accessor and mutator procedures for C struct fields + ;; at known byte offsets. Operates on raw void* pointers. + + (define-syntax define-foreign-struct + (lambda (stx) + (define (parse-field f) + (syntax-case f () + [(name type offset-kw off) + (eq? (syntax->datum #'offset-kw) 'offset:) + (list #'name (translate-type (syntax->datum #'type)) #'off)])) + (define (field-names f) + (syntax-case f () + [(name type offset-kw off) + (syntax->datum #'name)])) + (syntax-case stx () + [(k struct-name field ...) + (let ([parsed (map parse-field (syntax->list #'(field ...)))]) + (with-syntax ([((getter setter ftype-sym foffset) ...) + (map (lambda (f) + (let ([sname (syntax->datum #'struct-name)] + [fn (syntax->datum (car f))] + [ft (cadr f)] + [fo (caddr f)]) + (list (datum->syntax #'k + (string->symbol (format "~a-~a" sname fn))) + (datum->syntax #'k + (string->symbol (format "~a-~a-set!" sname fn))) + (datum->syntax #'k ft) + fo))) + parsed)]) + #'(begin + (define (getter ptr) (foreign-ref 'ftype-sym ptr foffset)) ... + (define (setter ptr val) (foreign-set! 'ftype-sym ptr foffset val)) ...)))]))) + ) ;; end library --- a/lib/std/misc/channel.sls +++ b/lib/std/misc/channel.sls @@ -1,54 +1,252 @@ #!chezscheme -;;; :std/misc/channel -- Gerbil-compatible channels using Chez threads +;;; :std/misc/channel -- Bounded channels with ring buffer and select +;;; +;;; - O(1) put/get via ring buffer (vector + head/tail indices) +;;; - Optional bounded capacity with backpressure +;;; - channel-select: multiplex across multiple channels (like Go select) +;;; - Backward compatible: (make-channel) still creates unbounded channel (library (std misc channel) (export make-channel channel-put channel-get channel-try-get - channel-close channel-closed? channel?) + channel-close channel-closed? channel? + channel-length channel-empty? + channel-select) (import (chezscheme)) + ;; Ring buffer: vector-based circular queue + ;; When capacity is #f, the buffer grows dynamically (unbounded mode) (define-record-type channel (fields - (mutable queue) + (mutable buf) ;; vector (ring buffer storage) + (mutable head) ;; index of next item to read + (mutable tail) ;; index of next slot to write + (mutable count) ;; current number of items + (mutable capacity) ;; max items (#f = unbounded) (immutable mutex) - (immutable condvar) + (immutable not-empty) ;; condition: signaled when item added + (immutable not-full) ;; condition: signaled when item removed (mutable closed?)) (protocol (lambda (new) - (lambda () - (new '() (make-mutex) (make-condition) #f))))) + (case-lambda + [() ;; unbounded (default) + (new (make-vector 16) 0 0 0 #f + (make-mutex) (make-condition) (make-condition) #f)] + [(cap) ;; bounded + (assert (and (fixnum? cap) (fx> cap 0))) + (new (make-vector cap) 0 0 0 cap + (make-mutex) (make-condition) (make-condition) #f)])))) + + ;; Grow the ring buffer (only for unbounded channels) + (define (grow-buffer! ch) + (let* ([old-buf (channel-buf ch)] + [old-cap (vector-length old-buf)] + [new-cap (fx* old-cap 2)] + [new-buf (make-vector new-cap)] + [head (channel-head ch)] + [count (channel-count ch)]) + ;; Copy items in logical order + (do ([i 0 (fx+ i 1)]) + ((fx= i count)) + (vector-set! new-buf i + (vector-ref old-buf (fxmod (fx+ head i) old-cap)))) + (channel-buf-set! ch new-buf) + (channel-head-set! ch 0) + (channel-tail-set! ch count))) + + (define (channel-length ch) + (channel-count ch)) + + (define (channel-empty? ch) + (fx= (channel-count ch) 0)) (define (channel-put ch val) - (when (channel-closed? ch) - (error 'channel-put "channel is closed")) (with-mutex (channel-mutex ch) - (channel-queue-set! ch (append (channel-queue ch) (list val))) - (condition-signal (channel-condvar ch)))) + (when (channel-closed? ch) + (error 'channel-put "channel is closed")) + (let ([cap (channel-capacity ch)]) + ;; Bounded: wait until not full + (when cap + (let loop () + (when (fx= (channel-count ch) cap) + (condition-wait (channel-not-full ch) (channel-mutex ch)) + (when (channel-closed? ch) + (error 'channel-put "channel is closed")) + (loop)))) + ;; Unbounded: grow if needed + (unless cap + (when (fx= (channel-count ch) (vector-length (channel-buf ch))) + (grow-buffer! ch))) + ;; Enqueue + (let ([buf (channel-buf ch)] + [tail (channel-tail ch)]) + (vector-set! buf tail val) + (channel-tail-set! ch (fxmod (fx+ tail 1) (vector-length buf))) + (channel-count-set! ch (fx+ (channel-count ch) 1))) + (condition-signal (channel-not-empty ch))))) (define (channel-get ch) (with-mutex (channel-mutex ch) (let loop () (cond - [(pair? (channel-queue ch)) - (let ([val (car (channel-queue ch))]) - (channel-queue-set! ch (cdr (channel-queue ch))) + [(fx> (channel-count ch) 0) + (let* ([buf (channel-buf ch)] + [head (channel-head ch)] + [val (vector-ref buf head)]) + (vector-set! buf head #f) ;; help GC + (channel-head-set! ch (fxmod (fx+ head 1) (vector-length buf))) + (channel-count-set! ch (fx- (channel-count ch) 1)) + (condition-signal (channel-not-full ch)) val)] [(channel-closed? ch) (error 'channel-get "channel is closed and empty")] [else - (condition-wait (channel-condvar ch) (channel-mutex ch)) + (condition-wait (channel-not-empty ch) (channel-mutex ch)) (loop)])))) (define (channel-try-get ch) (with-mutex (channel-mutex ch) - (if (pair? (channel-queue ch)) - (let ([val (car (channel-queue ch))]) - (channel-queue-set! ch (cdr (channel-queue ch))) + (if (fx> (channel-count ch) 0) + (let* ([buf (channel-buf ch)] + [head (channel-head ch)] + [val (vector-ref buf head)]) + (vector-set! buf head #f) + (channel-head-set! ch (fxmod (fx+ head 1) (vector-length buf))) + (channel-count-set! ch (fx- (channel-count ch) 1)) + (condition-signal (channel-not-full ch)) (values val #t)) (values #f #f)))) (define (channel-close ch) (with-mutex (channel-mutex ch) (channel-closed?-set! ch #t) - (condition-broadcast (channel-condvar ch)))) + (condition-broadcast (channel-not-empty ch)) + (condition-broadcast (channel-not-full ch)))) + + ;; ========== channel-select ========== + ;; + ;; (channel-select + ;; ((ch1 msg) body ...) ;; receive from ch1 + ;; ((ch2 msg) body ...) ;; receive from ch2 + ;; (timeout: seconds body ...) ;; optional timeout + ;; (else body ...)) ;; non-blocking fallback + ;; + ;; Multiplexes across multiple channels. Returns the result of the + ;; first channel that has data available. If none ready and no else/timeout, + ;; blocks until one becomes ready. + + (define-syntax channel-select + (lambda (stx) + (syntax-case stx (else) + ;; Parse clauses into a runtime call + [(k clause ...) + (let () + (define clauses '()) + (define timeout-clause #f) + (define else-clause #f) + (for-each + (lambda (c) + (syntax-case c (else) + ;; else clause + [(else body ...) + (set! else-clause #'(lambda () body ...))] + ;; timeout or channel clause - check at runtime + [((ch-or-kw args ...) body ...) + (if (eq? (syntax->datum #'ch-or-kw) 'timeout:) + ;; (timeout: seconds body ...) + (syntax-case c () + [((kw secs) body ...) + (set! timeout-clause + (list #'secs #'(lambda () body ...)))]) + ;; ((ch msg) body ...) — channel receive + (syntax-case c () + [((ch msg) body ...) + (set! clauses + (cons (list #'ch #'(lambda (msg) body ...)) + clauses))]))])) + (syntax->list #'(clause ...))) + (set! clauses (reverse clauses)) + (with-syntax ([(ch ...) (map car clauses)] + [(handler ...) (map cadr clauses)]) + (cond + [else-clause + (with-syntax ([else-thunk else-clause]) + #'(channel-select-now (list ch ...) (list handler ...) else-thunk))] + [timeout-clause + (with-syntax ([secs (car timeout-clause)] + [timeout-thunk (cadr timeout-clause)]) + #'(channel-select-wait (list ch ...) (list handler ...) + secs timeout-thunk))] + [else + #'(channel-select-wait (list ch ...) (list handler ...) #f #f)])))]))) + + ;; Non-blocking select: try each channel, call else if none ready + (define (channel-select-now channels handlers else-thunk) + (let loop ([chs channels] [hs handlers]) + (if (null? chs) + (else-thunk) + (let-values ([(val ok) (channel-try-get (car chs))]) + (if ok + ((car hs) val) + (loop (cdr chs) (cdr hs))))))) + + ;; Blocking select with optional timeout + ;; Strategy: shared condition variable that all channels signal + (define (channel-select-wait channels handlers timeout-secs timeout-thunk) + ;; First, try non-blocking + (let try-loop ([chs channels] [hs handlers]) + (if (null? chs) + ;; None ready — block + (let ([shared-cond (make-condition)] + [shared-mutex (make-mutex)]) + ;; Install watchers: for each channel, spawn a thread that waits + ;; and signals the shared condition when data arrives + (let ([watchers + (map (lambda (ch) + (fork-thread + (lambda () + (with-mutex (channel-mutex ch) + (let loop () + (cond + [(fx> (channel-count ch) 0) + ;; Data available — signal main + (mutex-acquire shared-mutex) + (condition-signal shared-cond) + (mutex-release shared-mutex)] + [(channel-closed? ch) + (mutex-acquire shared-mutex) + (condition-signal shared-cond) + (mutex-release shared-mutex)] + [else + (condition-wait (channel-not-empty ch) + (channel-mutex ch)) + (loop)])))))) + channels)]) + ;; Wait on shared condition + (mutex-acquire shared-mutex) + (if timeout-secs + (let ([ns (exact (floor (* timeout-secs 1000000000)))] + [s (exact (floor timeout-secs))]) + (let ([ns-part (exact (floor (* (- timeout-secs s) 1000000000)))]) + (condition-wait shared-cond shared-mutex + (make-time 'time-duration ns-part s)))) + (condition-wait shared-cond shared-mutex)) + (mutex-release shared-mutex) + ;; Try again non-blocking + (let select-loop ([chs channels] [hs handlers]) + (if (null? chs) + (if (and timeout-secs timeout-thunk) + (timeout-thunk) + ;; Spurious wake — retry + (channel-select-wait channels handlers timeout-secs timeout-thunk)) + (let-values ([(val ok) (channel-try-get (car chs))]) + (if ok + ((car hs) val) + (select-loop (cdr chs) (cdr hs)))))))) + ;; Found data in non-blocking try + (let-values ([(val ok) (channel-try-get (car chs))]) + (if ok + ((car hs) val) + (try-loop (cdr chs) (cdr hs))))))) ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/task.sls @@ -0,0 +1,192 @@ +#!chezscheme +;;; (std task) — Structured concurrency for Chez Scheme +;;; +;;; Task groups (nurseries): scoped task lifetime with cancellation +;;; No task can outlive its parent scope. If any task throws, all others +;;; are cancelled. Built on Chez OS threads + mutexes + conditions. +;;; +;;; API: +;;; (with-task-group (lambda (tg) body ...)) +;;; (task-group-spawn tg thunk) +;;; (task-group-async tg thunk) → future +;;; (task-group-cancel! tg) +;;; (make-cancel-token) / (cancelled? token) / (cancel! token) +;;; (future-get future) — blocks until result available + +(library (std task) + (export + with-task-group + task-group-spawn + task-group-async + task-group-cancel! + task-group? + ;; Cancel tokens + make-cancel-token cancelled? cancel! + cancel-token? + ;; Futures + make-future future-get future-done? future? + future-complete! future-fail! + ;; Internal (for task-group access) + task-group-cancel-tok) + (import (chezscheme)) + + ;; ========== Cancel Tokens ========== + ;; Shared atomic flag for cooperative cancellation + + (define-record-type cancel-token + (fields + (mutable flag) ;; #f or #t + (immutable mutex) + (immutable cond)) + (protocol + (lambda (new) + (lambda () (new #f (make-mutex) (make-condition))))) + (sealed #t)) + + (define (cancelled? tok) + (cancel-token-flag tok)) + + (define (cancel! tok) + (unless (cancel-token-flag tok) + (cancel-token-flag-set! tok #t) + (with-mutex (cancel-token-mutex tok) + (condition-broadcast (cancel-token-cond tok))))) + + ;; ========== Futures ========== + ;; A future holds the result of an async computation + + (define-record-type future + (fields + (mutable result) + (mutable exception) + (mutable done?) + (immutable mutex) + (immutable cond)) + (protocol + (lambda (new) + (lambda () (new (void) #f #f (make-mutex) (make-condition))))) + (sealed #t)) + + (define (future-complete! fut val) + (with-mutex (future-mutex fut) + (future-result-set! fut val) + (future-done?-set! fut #t) + (condition-broadcast (future-cond fut)))) + + (define (future-fail! fut exn) + (with-mutex (future-mutex fut) + (future-exception-set! fut exn) + (future-done?-set! fut #t) + (condition-broadcast (future-cond fut))))