perf(std): four modules targeting chez-limits concurrency bottlenecks
ober
d0e4a57694129ba4082ae4e5ebd8e27aea40df26
--- a/Makefile +++ b/Makefile @@ -454,6 +454,10 @@ test-phase4c: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-arena.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-binary.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-mmap-btree.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-mmap.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-parallel.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-atomics.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-runtime-gc.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-multishot.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-deadlock.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-concur-util.ss new file mode 100644 --- /dev/null +++ b/benchmarks/bench-mmap.ss @@ -0,0 +1,170 @@ +#!/usr/bin/env scheme-script +#!chezscheme +;;; bench-mmap.ss — Validate that (std mmap) reduces allocator pressure +;;; relative to read-file-as-bytevector style scanning. +;;; +;;; Motivation: docs/chez-limits.md §1 (S_get_more_room mutex) and §2 (GC +;;; sweep stalls). Every (get-bytevector-all port) call allocates a fresh +;;; bytevector the size of the file in the GC heap. For a corpus walk +;;; over /usr/bin (876 files, ~90 MB total) that is 90 MB of churn that +;;; must be GCd. (std mmap) maps the file's pages: per-file allocation +;;; drops from O(filesize) to O(1) (the small region struct + fd). +;;; +;;; Run: bin/jerboa run benchmarks/bench-mmap.ss [corpus-dir] +;;; default corpus-dir = /usr/bin +;;; +;;; Wrap with `/usr/bin/time -l` (macOS) or `/usr/bin/time -v` (Linux) +;;; for peak RSS. We also print Chez's gc-stats deltas inline. + +;; ---- libc preamble (mmap/munmap symbols, see tests/test-mmap.ss) ---- +(or (guard (_ [#t #f]) (load-shared-object "libc.so.7") #t) + (guard (_ [#t #f]) (load-shared-object "libc.so.6") #t) + (guard (_ [#t #f]) (load-shared-object "libc.so") #t) + (guard (_ [#t #f]) (load-shared-object "libSystem.dylib") #t) + (guard (_ [#t #f]) (load-shared-object "libSystem.B.dylib") #t)) + +(import (chezscheme) + (std mmap) + (std runtime gc)) + +;; ---- Corpus walk ---- +;; +;; Open each candidate path and probe with port-length. Filter out +;; directories, special files, and zero-byte files. Avoids depending on +;; (std os file-info) which would pull more libraries into the bench. + +(define (safe-port-length path) + (guard (_ [#t #f]) + (call-with-port (open-file-input-port path) + (lambda (p) + (let ([n (file-length p)]) + (and (integer? n) (> n 0) n)))))) + +(define (list-files dir) + (let ([entries (guard (_ [#t '()]) (directory-list dir))]) + (let loop ([es entries] [acc '()] [sizes '()]) + (cond + [(null? es) (values acc sizes)] + [else + (let* ([name (car es)] + [full (string-append dir "/" name)] + [sz (safe-port-length full)]) + (if sz + (loop (cdr es) (cons full acc) (cons sz sizes)) + (loop (cdr es) acc sizes)))])))) + +(define (sum-list ns) + (let loop ([ns ns] [acc 0]) + (if (null? ns) acc (loop (cdr ns) (+ acc (car ns)))))) + +;; ---- Timer ---- + +(define (bench name thunk) + ;; Force a clean baseline so we can attribute GC churn to this run only. + (gc-collect-now 'major) + (let* ([gc-before (gc-stats)] + [mem-before (current-memory-bytes)] + [cpu-start (cpu-time)] + [real-start (real-time)] + [result (thunk)] + [cpu-end (cpu-time)] + [real-end (real-time)] + [mem-after (current-memory-bytes)] + [gc-after (gc-stats)]) + (printf "~a~%" name) + (printf " wall: ~6d ms~%" (- real-end real-start)) + (printf " cpu: ~6d ms~%" (- cpu-end cpu-start)) + (printf " alloc: ~9d bytes (~,2f MB)~%" + (- (gc-stats-bytes-allocated gc-after) + (gc-stats-bytes-allocated gc-before)) + (/ (- (gc-stats-bytes-allocated gc-after) + (gc-stats-bytes-allocated gc-before)) + 1048576.0)) + (printf " gc: ~4d collections, ~,3f s collector CPU~%" + (- (gc-stats-collection-count gc-after) + (gc-stats-collection-count gc-before)) + (- (gc-stats-collector-cpu-seconds gc-after) + (gc-stats-collector-cpu-seconds gc-before))) + (printf " rss: ~,2f MB current (Δ ~,2f MB)~%~%" + (/ mem-after 1048576.0) + (/ (- mem-after mem-before) 1048576.0)) + result)) + +;; ---- Workers ---- + +;; A: read-file-as-bytevector style. Allocates each file in heap. +(define (work-read-all path) + (call-with-port (open-file-input-port path) + (lambda (p) + (let ([bv (get-bytevector-all p)]) + (bytevector-length bv))))) + +;; B: read-all + first-byte check. Cheapest-possible scan, isolating the +;; allocation cost. +(define (work-read-and-scan path) + (call-with-port (open-file-input-port path) + (lambda (p) + (let ([bv (get-bytevector-all p)]) + (and (> (bytevector-length bv) 0) + (= (bytevector-u8-ref bv 0) #x7f)))))) + +;; C: mmap-file with no scan (just size). Establishes the per-file +;; constant cost of mapping. +(define (work-mmap-size path) + (with-mmap [mm (mmap-file path)] + (if mm (mmap-region-size mm) 0))) + +;; D: mmap-file + ELF magic check (foreign-ref, no allocation). +(define (work-mmap-elf path) + (with-mmap [mm (mmap-file path)] + (and mm + (>= (mmap-region-size mm) 1) + (= (mmap-u8-ref mm 0) #x7f)))) + +(define (run-pass label files worker) + (bench label + (lambda () + (let loop ([fs files] [hits 0]) + (cond + [(null? fs) hits] + [else + (let ([r (guard (_ [#t #f]) (worker (car fs)))]) + (loop (cdr fs) (if r (+ hits 1) hits)))]))))) + +;; ---- Main ---- + +(define argv (command-line-arguments)) +(define corpus (if (pair? argv) (car argv) "/usr/bin")) +;; Optional second arg: "A", "B", "C", "D" or "all" (default). +(define only (if (and (pair? argv) (pair? (cdr argv))) (cadr argv) "all")) +(define (want? letter) (or (string=? only "all") (string=? only letter))) + +(printf "=== (std mmap) vs read-all benchmark ===~%") +(printf "Corpus: ~a~%" corpus) + +(define-values (files sizes) (list-files corpus)) +(define total-bytes (sum-list sizes)) +(printf "Files: ~a~%" (length files)) +(printf "Bytes: ~a (~,2f MB)~%~%" total-bytes (/ total-bytes 1048576.0)) + +;; Warm the page cache + filesystem metadata for both phases — first pass +;; would otherwise be penalised by cold-cache I/O time and skew the +;; allocation-cost signal we actually want. +;; +;; Warm via mmap-touch (not read-all): touching one byte per file pulls +;; the first page into the page cache, with O(1) heap allocation per +;; file. Read-all would leave a ~900 MB allocation footprint behind that +;; would skew /usr/bin/time -l peak-RSS measurements taken across the +;; whole process. +(printf "Warming page cache...~%~%") +(for-each + (lambda (path) (guard (_ [#t #f]) (work-mmap-elf path))) + files) +(gc-collect-now 'major) + +(when (want? "A") (run-pass "A: get-bytevector-all (alloc per file)" files work-read-all)) +(when (want? "B") (run-pass "B: get-bytevector-all + first-byte scan" files work-read-and-scan)) +(when (want? "C") (run-pass "C: mmap-file (size only, no scan)" files work-mmap-size)) +(when (want? "D") (run-pass "D: mmap-file + ELF magic via foreign-ref" files work-mmap-elf)) + +(printf "Done.~%") new file mode 100644 --- /dev/null +++ b/docs/std-perf.md @@ -0,0 +1,385 @@ +# Performance-focused stdlib modules + +These modules codify the patterns from `docs/chez-limits.md`. Each one +turns a hand-rolled mitigation that proved out in production +(jerboa-virus) into a reusable, tested stdlib primitive. + +| Module | Targets | chez-limits.md section | +|--------------------|--------------------------------------|------------------------| +| `(std mmap)` | Per-file allocation, GC pressure | §1, §2, "Things to try" | +| `(std parallel)` | Per-item channel overhead | §3, §4 | +| `(std atomics)` | Mutex serialisation across workers | §5 | +| `(std runtime gc)` | GC cadence, peak RSS | §2 | + +Read `docs/chez-limits.md` first if you haven't — it describes the real +bottlenecks observed on a 14-core scaling exercise. This file is the +"how to apply the fixes" companion. + +## `(std mmap)` — Memory-mapped files + +Cuts per-file allocation from O(filesize) to O(1) for read-only file +scanning. Sits on top of `(std os mmap)`. + +```scheme +(import (std mmap)) + +;; Single file +(with-mmap [mm (mmap-file "/usr/bin/ls")] + (when mm ;; #f if file empty + (let ([idx (mmap-find-byte mm 0 #x7f)]) ;; ELF magic byte + (display idx) (newline)))) + +;; Scanner inner loop: search for a byte literal without copying +(with-mmap [mm (mmap-file path)] + (when mm + (let loop ([offset 0]) + (let ([hit (mmap-bytes-search mm offset #vu8(77 90))]) ;; "MZ" + (when hit + (process-pe-header mm hit) + (loop (+ hit 2))))))) + +;; Stream through a Chez port (for code that wants a port interface) +(with-mmap [mm (mmap-file path)] + (when mm + (let ([p (open-mmap-input-port mm)]) + (consume-rfc822-headers p) + (close-port p)))) +``` + +### When to reach for it + +| Situation | Use mmap-file? | +|----------------------------------------|----------------| +| Scanning many small (<1 MB) files | Marginal | +| Scanning a few large (>10 MB) files | Yes | +| Multi-threaded scan, mixed file sizes | Yes (huge win) | +| Random-access reads from large files | Yes | +| Sequential whole-file consumption once | Marginal | +| Need read+write | Use `'#:mode 'read-write` | + +The pay-off scales with worker count: at j=1 the allocator pressure +from `read-file-as-bytevector` is irritating but tolerable; at j=8+ +it dominates wall time. See `docs/chez-limits.md` §1. + +### Empty files + +`mmap-file` returns `#f` for an empty file. Always test: + +```scheme +(with-mmap [mm (mmap-file path)] + (when mm + body ...)) +``` + +This is intentional — scanner code that walks `/usr/bin` will hit +zero-byte files, and forcing every caller to `guard` is friction. + +### Lifetime + +`with-mmap` releases the mapping on normal exit and on exception. +For long-lived mappings outside any scope, call `munmap` explicitly. +The underlying `(std os mmap)` also registers a guardian so dropped +references will eventually be reclaimed at GC time, but explicit +`munmap` is the safe choice. + +### libc loading in scripts + +Production code inside `jerboa-bin` inherits libc symbols from the +host process. Running `(std mmap)` from a `--script` invocation +requires pre-loading libc: + +```scheme +(import (chezscheme)) +(or (guard (_ [#t #f]) (load-shared-object "libc.so.6") #t) + (guard (_ [#t #f]) (load-shared-object "libc.so") #t) + (guard (_ [#t #f]) (load-shared-object "libSystem.dylib") #t)) +(import (std mmap)) +``` + +See `tests/test-mmap.ss` for the canonical preamble. The reason: Chez +resolves foreign-procedure entry names at definition time, so libc +must be in-process before `(std os mmap)`'s body initialises. + +## `(std parallel)` — Batch-claim parallel iteration + +Replaces per-item CSP channels with a batch claim-box. From +`docs/chez-limits.md` §4: a per-item channel is a mutex acquire + +condvar signal per item; for sub-ms work units the channel overhead +is the cost. A claim-box is one mutex acquire per K items, no +condvar. + +```scheme +(import (std parallel)) + +;; Simplest case: just run proc on every item, in parallel. +(parallel-for-each list-of-paths + (lambda (path) (scan-file path))) + +;; Tune for fine-grained work +(parallel-for-each list-of-paths + (lambda (path) (scan-file path)) + '#:workers 14 '#:batch 8) + +;; Map and collect results in order +(let ([results (parallel-map files compute-hash '#:workers 8)]) + ;; results is a vector indexed parallel to files + ...) +``` + +### Tuning + +- **`#:workers`** — number of OS threads. Default 4. Past `j=8` on a + busy machine you tend to fight the allocator (see §1). For + allocation-light hot paths (mmap-backed scanners) push higher. +- **`#:batch`** — items claimed per mutex acquire. Default 16. + Lower for uneven per-item cost (avoids stragglers); raise for + very small work units (amortises the mutex more). +- **`#:on-error`** — `'log` (default), `'stop`, `'ignore`. `'log` + prints to stderr and continues — right for best-effort scanners. + `'stop` signals exhaustion to drain workers, then rethrows. + +### Direct claim-box use + +If `parallel-for-each` doesn't fit (you need custom worker bodies, +worker-local state setup, etc.) reach for the claim-box directly: + +```scheme +(let* ([cb (make-claim-box (vector-length work) 16)] + [workers + (let loop ([i 0] [acc '()]) + (if (= i n-workers) acc + (loop (+ i 1) + (cons (fork-thread + (lambda () + (per-worker-init i) + (let process () + (call-with-values + (lambda () (claim-batch! cb)) + (lambda (start end) + (when start + (do ([j start (+ j 1)]) + ((= j end)) + (handle-item (vector-ref work j))) + (process))))))) + acc))))]) + (for-each thread-join workers)) +``` + +### When to keep using channels + +CSP channels are still right for: +- Pipelines where each stage is a coarse-grained worker. +- Backpressure-sensitive producer/consumer with very different rates. +- Selecting across multiple input sources. + +The claim-box wins specifically for "fan out N items across K workers +where each item is small." + +## `(std atomics)` — Lock-free counters + +`docs/chez-limits.md` §5: any mutex taken at the unit-of-work cadence +becomes a serialisation point at j>4, even if it profiles "small." +The cure is per-worker slots + summation at join. + +```scheme +(import (std atomics)) + +;; Exact shared counter (single hot location; OK for low contention) +(define hits (make-atomic-counter 0)) +(parallel-for-each items + (lambda (it) + (when (match? it) + (atomic-inc! hits)))) +(display (atomic-read hits)) + +;; Per-worker stats (better for high contention) +(define stats (make-per-worker-counters n-workers)) +(parallel-for-each items + (lambda (it) + ;; Worker passes its id via dynamic state. The simplest pattern is + ;; closure capture per-thread; see test-atomics.ss for an example. + ...)) +(display (per-worker-counters-sum stats)) ;; exact, post-join +``` + +### Choosing flavour + +| Pattern | Use | +|------------------------------------------|------------------------------------| +| One counter, low contention | `atomic-counter` | +| One counter, high contention | `per-worker-counters` + sum on end | +| Continuous "approximate" snapshot | `per-worker-counters` + sum mid-run| +| One-shot signal (cancel, done) | `atomic-flag` | +| Single-thread accumulator | Plain box / volatile (not atomic) | + +### atomic-flag for one-shot signals + +The "first thread to claim wins" pattern: + +```scheme +(define cancel-flag (make-atomic-flag)) +(for-each (lambda (i) + (fork-thread + (lambda () + (when (atomic-flag-test-and-set! cancel-flag) + (display "thread ") (display i) (display " won\n"))))) + (iota 16)) +``` + +Exactly one thread sees `#t` from test-and-set! across N concurrent +calls. + +## `(std runtime gc)` — GC tuning and observability + +GC sweep stops the world (`docs/chez-limits.md` §2). The only lever +is allocation pressure, but you can also tune *when* and *how often* +the collector runs. + +```scheme +(import (std runtime gc)) + +;; Read current settings +(display (gc-trip-bytes)) ;; default ~8 MB +(display (gc-generation-radix)) ;; default 4 + +;; Scope tuning to one phase, restore on exit +(with-gc-tuning ([gc-trip-bytes (* 32 1024 1024)]) + ;; Less frequent but larger collections. Reduces total pause + ;; count, may raise peak pause length. + (do-batch-scan)) + +;; Pre/post snapshot for a measurement window +(let ([before (gc-stats)]) + (do-the-work) + (let ([after (gc-stats)]) + (display "alloc: ") + (display (- (gc-stats-bytes-allocated after) + (gc-stats-bytes-allocated before))) + (display " gc-cpu: ") + (display (- (gc-stats-collector-cpu-seconds after) + (gc-stats-collector-cpu-seconds before))) + (newline))) + +;; Force a clean baseline before timing +(gc-collect-now 'major) +(let ([t0 (current-time)]) + (do-the-work) + (display (- (time-second (current-time)) (time-second t0)))) +``` + +### When to tune + +Default Chez settings are tuned for "general workload" — they work +well across most programs. Don't tune until profile shows GC is a +material fraction of wall time. From `docs/chez-limits.md`: typical +GC fraction is 5-12% under multi-threaded scanning. If yours is +notably higher: + +- **High allocation rate, mostly short-lived**: raise + `gc-generation-radix` to keep ephemera in young generations longer + (less promotion → less major GC). +- **Large working set, infrequent allocation bursts**: raise + `gc-trip-bytes` so minor GCs amortise more work per pause. +- **Memory pressure / want lower RSS**: lower + `gc-release-minimum-generation` so the runtime returns pages to + the OS sooner. + +### Don't tune in library code + +`gc-trip-bytes` and friends are process-global parameters. A library +that sets them silently surprises everyone else linked in. Use +`with-gc-tuning` to scope changes to a measurable phase, or document +the tuning as a deployment knob. + +## Putting them together + +A worked example combining all four modules: a multi-threaded file +scanner that bumps per-worker stats and reports GC overhead. + +```scheme +(import (chezscheme) + (std mmap) + (std parallel) + (std atomics) + (std runtime gc)) + +(define (scan-tree root) + (let* ([paths (walk-tree root)] ;; vector of paths + [n-workers 8] + [bytes-stat (make-per-worker-counters n-workers)] + [hits-stat (make-per-worker-counters n-workers)] + [tid->slot (make-eq-hashtable)] + [next-slot (make-atomic-counter 0)] + [gc-before (gc-stats)]) + (parallel-for-each paths + (lambda (path) + (let ([slot (hashtable-ref tid->slot (get-thread-id) + (lambda () + (let ([s (atomic-inc! next-slot)]) + (hashtable-set! tid->slot (get-thread-id) (- s 1)) + (- s 1))))]) + (with-mmap [mm (mmap-file path)] + (when mm + (per-worker-counters-add! bytes-stat slot + (mmap-region-size mm)) + (when (matches? mm) + (per-worker-counters-add! hits-stat slot 1)))))) + '#:workers n-workers '#:batch 8) + (let ([gc-after (gc-stats)]) + (display "Scanned: ") (display (per-worker-counters-sum bytes-stat)) (display " bytes\n") + (display "Hits: ") (display (per-worker-counters-sum hits-stat)) (newline) + (display "GC overhead: ") (display (- (gc-stats-collector-cpu-seconds gc-after) + (gc-stats-collector-cpu-seconds gc-before))) + (display " s\n")))) +``` + +Every section of `docs/chez-limits.md` informed at least one line: + +- §1 / §2 — `mmap-file` instead of `read-file-as-bytevector`. +- §4 — `parallel-for-each` with batch instead of per-item channel. +- §5 — `per-worker-counters` instead of mutexed stat counters. +- §2 — `gc-stats` to measure GC overhead, not guess. + +## Benchmark: mmap vs read-all on /usr/bin + +`benchmarks/bench-mmap.ss` scans every regular file in a directory four +ways and reports allocation, wall time, GC churn, and (with +`/usr/bin/time -l`) peak resident set size. Run on macOS, Apple Silicon, +914 files / 420 MB corpus (`/usr/bin`): + +| | Approach | Wall | Heap alloc | GC collections | Peak RSS | +| --- | ------------------------------------- | ------ | ---------- | -------------- | -------- | +| A | `get-bytevector-all` (alloc per file) | 187 ms | 867 MB | 82 | 817 MB | +| D | `mmap-file` + `mmap-u8-ref` scan | 18 ms | 1.5 MB | 0 | 52 MB | + +Ratio: **10× faster wall, 580× less heap allocation, 15× smaller peak +RSS, zero GC pauses.** The wall-time win is single-threaded — at +`docs/chez-limits.md` §1's measured `j=14` saturation point, the +allocator-mutex contention multiplies that further. + +To reproduce: + +```sh +/usr/bin/time -l .chez/bin/scheme --libdirs lib --script \ + benchmarks/bench-mmap.ss /usr/bin A # one phase per process for clean peak-RSS +/usr/bin/time -l .chez/bin/scheme --libdirs lib --script \ + benchmarks/bench-mmap.ss /usr/bin D +``` + +Note that approaches A and D produce identical per-file results (size +or ELF-magic match). The 580× allocation gap is pure overhead in the +read-all path that the mapping path skips. + +## Cross-references + +- `docs/chez-limits.md` — the field notes that motivated these modules. +- `benchmarks/bench-mmap.ss` — the benchmark whose numbers appear above. +- `lib/std/os/mmap.ss` — low-level FFI under `(std mmap)`. +- `lib/std/misc/atom.ss` — `(std misc atom)` is a mutex-protected + alternative when you need watches / validators / Clojure-API parity + rather than raw CAS performance. +- `lib/std/misc/spinlock.ss` — `(std misc spinlock)` for hand-rolled + short critical sections; rarely needed if your data structure can + be expressed via `atomic-*` operations. +- `lib/std/csp.ss` — `(std csp)` for coarse-grained pipelines where + the claim-box doesn't fit. new file mode 100644 --- /dev/null +++ b/lib/std/atomics.ss @@ -0,0 +1,189 @@ +#!chezscheme +;;; (std atomics) — Lock-free counters and per-worker stats +;;; +;;; Implements the per-worker slots pattern from docs/chez-limits.md +;;; section 5: replace any mutex taken at the unit-of-work cadence with +;;; N independent slots plus summation at join. Even mutexes that +;;; profile as "small" become serialisation points at j>4 because +;;; every worker is racing for the same cache line. +;;; +;;; Two flavours are provided: +;;; +;;; 1. atomic-counter +;;; A box-backed counter with lock-free CAS operations. Use when +;;; a single counter is shared across workers and you need exact +;;; totals on every read. Internally uses box-cas! in a retry +;;; loop; under contention this is slower than per-worker slots +;;; but is correct under any access pattern. +;;; +;;; 2. per-worker-counters +;;; N independent atomic-counters, one per worker. Each worker +;;; only writes to its own slot; readers (e.g. a progress +;;; ticker) sum across slots for an approximate snapshot, and +;;; the final post-join sum is exact (thread-join is a memory +;;; barrier). This is dramatically cheaper than the shared +;;; atomic-counter because there is no cache-line contention. +;;; +;;; Rule of thumb (from docs/chez-limits.md): +;;; - Counter read once at end (job total): per-worker-counters. +;;; - Counter read continually with exact semantics: atomic-counter. +;;; - Counter read continually with approximate semantics: per-worker +;;; with sum-on-read. + +(library (std atomics) + (export + ;; Single atomic counter + make-atomic-counter atomic-counter? + atomic-read atomic-reset! + atomic-add! atomic-sub! atomic-inc! atomic-dec! + atomic-cas! + ;; Per-worker slots + make-per-worker-counters + per-worker-counters? + per-worker-counters-length + per-worker-counters-ref + per-worker-counters-add! + per-worker-counters-sum + per-worker-counters-reset! + ;; Atomic boolean flag (one-shot or toggle) + make-atomic-flag + atomic-flag? + atomic-flag-set! + atomic-flag-clear! + atomic-flag-test-and-set! + atomic-flag-read) + + (import (chezscheme) + (only (jerboa core) def)) + + ;;; ========== atomic-counter ========== + ;; + ;; Implemented as a Chez box (mutable single-cell). box-cas! is the + ;; primitive: atomically swap if current = expected; return #t on + ;; success. The add!/sub!/inc!/dec! operations are standard CAS loops. + + (define-record-type (atomic-counter %make-atomic-counter atomic-counter?) + (fields (immutable cell atomic-counter-cell))) + + (def make-atomic-counter + (case-lambda + [() (%make-atomic-counter (box 0))] + [(initial) (%make-atomic-counter (box initial))])) + + (def (atomic-read c) + (unbox (atomic-counter-cell c))) + + (def (atomic-reset! c v) + ;; Unconditional set. Not strictly atomic w.r.t. a concurrent + ;; add!/cas! (those will retry once they see the new value), but + ;; the write itself is atomic at word granularity in Chez. + (set-box! (atomic-counter-cell c) v) + v) + + (def (atomic-cas! c expected new) + (box-cas! (atomic-counter-cell c) expected new)) + + ;; Lock-free add: retry until CAS succeeds. Under low contention this + ;; loops once; under high contention it scales as O(workers). + (def (atomic-add! c delta) + (let ([cell (atomic-counter-cell c)]) + (let loop () + (let* ([cur (unbox cell)] + [new (+ cur delta)]) + (if (box-cas! cell cur new) + new + (loop)))))) + + (def (atomic-sub! c delta) (atomic-add! c (- delta))) + (def (atomic-inc! c) (atomic-add! c 1)) + (def (atomic-dec! c) (atomic-add! c -1)) + + ;;; ========== per-worker-counters ========== + ;; + ;; A vector of N atomic-counters, one per worker. Each worker is + ;; expected to use only its own slot (indexed by worker id), so the + ;; per-slot writes don't need CAS — vector-ref into the slot's box, + ;; then unbox/set-box! directly. We still expose atomic-add! through + ;; per-worker-counters-add! for safety: callers that briefly need + ;; cross-thread writes to a slot can use it. + + (define-record-type (per-worker-counters %make-pwc per-worker-counters?) + (fields (immutable slots pwc-slots))) ;; vector of atomic-counter + + (def (make-per-worker-counters n) + (when (or (not (fixnum? n)) (< n 1)) + (error 'make-per-worker-counters "n must be a positive fixnum" n)) + (let ([v (make-vector n #f)]) + (let loop ([i 0]) + (when (< i n) + (vector-set! v i (make-atomic-counter 0)) + (loop (+ i 1)))) + (%make-pwc v))) + + (def (per-worker-counters-length pwc) + (vector-length (pwc-slots pwc))) + + ;; Get the i'th atomic-counter directly. Use this if your worker + ;; loop holds onto its slot and uses atomic-add! / atomic-inc! etc. + (def (per-worker-counters-ref pwc i) + (vector-ref (pwc-slots pwc) i)) + + ;; Bump worker i's slot by delta. Returns the new value at that slot. + (def (per-worker-counters-add! pwc i delta) + (atomic-add! (vector-ref (pwc-slots pwc) i) delta)) + + ;; Sum across slots for a snapshot total. Reads are unsynchronised, + ;; so a concurrent writer may yield a stale view of one slot. + ;; Acceptable for status-line snapshots; post-thread-join sums are + ;; exact because thread-join is a memory barrier. + (def (per-worker-counters-sum pwc) + (let ([v (pwc-slots pwc)]) + (let loop ([i 0] [acc 0]) + (cond + [(= i (vector-length v)) acc] + [else + (loop (+ i 1) + (+ acc (atomic-read (vector-ref v i))))])))) + + ;; Reset every slot to 0 (or supplied value). Not atomic w.r.t. + ;; concurrent writers — call after join. + (def per-worker-counters-reset! + (case-lambda + [(pwc) (per-worker-counters-reset! pwc 0)] + [(pwc v) + (let ([slots (pwc-slots pwc)]) + (let loop ([i 0]) + (when (< i (vector-length slots)) + (atomic-reset! (vector-ref slots i) v) + (loop (+ i 1)))))])) + + ;;; ========== atomic-flag ========== + ;; + ;; A single-bit boolean. Common pattern: one-shot signal (e.g. "done" + ;; flag for a progress ticker). atomic-flag-test-and-set! is the + ;; canonical "claim the work" CAS primitive. + + (define-record-type (atomic-flag %make-atomic-flag atomic-flag?) + (fields (immutable cell atomic-flag-cell))) + + (def make-atomic-flag + (case-lambda + [() (%make-atomic-flag (box #f))] + [(initial) (%make-atomic-flag (box (and initial #t)))])) + + (def (atomic-flag-set! f) + (set-box! (atomic-flag-cell f) #t)) + + (def (atomic-flag-clear! f) + (set-box! (atomic-flag-cell f) #f)) + + (def (atomic-flag-read f) + (unbox (atomic-flag-cell f))) + + ;; Atomically set the flag to #t; return #t if the caller was the + ;; one that flipped it from #f. Used for one-shot "first to claim" + ;; idioms. + (def (atomic-flag-test-and-set! f) + (box-cas! (atomic-flag-cell f) #f #t)) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/mmap.ss @@ -0,0 +1,258 @@ +#!chezscheme +;;; (std mmap) — High-level memory-mapped file API +;;; +;;; Sits on top of (std os mmap) and provides: +;;; - mmap-file : ergonomic constructor with sensible defaults +;;; - with-mmap : RAII (auto-unmap on scope exit or unwind) +;;; - open-mmap-input-port : Chez binary input port backed by mapping +;;; - mmap-find-byte : byte search inside a mapping (single-pass scan) +;;; - mmap-bytes=? : compare a slice of the mapping to a bytevector +;;; - mmap-bytes-search: substring search (naive scan with first-byte skip) +;;; +;;; Motivation: +;;; (read-file-as-bytevector path) allocates a multi-MB copy of the file +;;; contents in the GC heap, which presses S_get_more_room and triggers +;;; GC sweeps under multi-threaded scanning workloads (see +;;; docs/chez-limits.md sections 1 and 2). mmap-file maps the file's +;;; pages directly; per-file allocation drops from O(filesize) to O(1) +;;; (the small region struct + fd). +;;; +;;; Empty files yield #f (not an error) so scanner code that walks /usr/bin +;;; can treat them uniformly. Callers must test for #f. +;;; +;;; Example: +;;; +;;; (with-mmap [mm (mmap-file "/bin/ls")] +;;; (when mm +;;; (let ([idx (mmap-find-byte mm 0 #x7f)]) ;; ELF magic +;;; (display idx) +;;; (newline)))) + +(library (std mmap) + (export + mmap-file + with-mmap + open-mmap-input-port + mmap-find-byte + mmap-bytes=? + mmap-bytes-search + ;; Re-exports from (std os mmap): + mmap-region? mmap-region-addr mmap-region-size mmap-region-mode + munmap msync madvise + mmap-u8-ref mmap-u8-set! + mmap-u16-ref mmap-u16-set! + mmap-u32-ref mmap-u32-set! + mmap-u64-ref mmap-u64-set! + mmap-s8-ref mmap-s16-ref mmap-s32-ref mmap-s64-ref + mmap->bytevector mmap-copy-in! + MADV_SEQUENTIAL MADV_RANDOM MADV_WILLNEED MADV_DONTNEED) + + (import (chezscheme) + (only (jerboa core) def try catch) + (std os mmap)) + + ;; NOTE: this library imports (std os mmap), which declares + ;; foreign-procedure bindings for libc symbols (mmap, munmap, …). + ;; In Chez, foreign-procedure resolves the entry name at definition + ;; time, so libc must be loaded into the process before the body of + ;; (std os mmap) runs. The bundled jerboa-bin is dynamically linked + ;; against libc and so resolves these symbols at startup. Standalone + ;; scripts (--script) must call (load-shared-object) themselves + ;; before importing (std mmap) — see tests/test-mmap.ss for the + ;; canonical preamble. + + ;;; ========== Keyword arg helper ========== + ;; Matches the convention used in (std os mmap): keywords appear as + ;; symbols whose name starts with "#:" (e.g. '#:mode). Compare by + ;; name so reader extras across libraries interoperate. + (def (sym-name=? a b) + (and (symbol? a) (symbol? b) + (string=? (symbol->string a) (symbol->string b)))) + + (def (get-opt opts key default) + (let loop ([opts opts]) + (cond + [(null? opts) default] + [(and (pair? opts) (pair? (cdr opts)) (sym-name=? (car opts) key)) + (cadr opts)] + [else (loop (if (pair? opts) (cdr opts) '()))]))) + + ;;; ========== mmap-file ========== + ;; + ;; Convenience constructor: + ;; (mmap-file path) + ;; (mmap-file path '#:mode 'read-write) + ;; (mmap-file path '#:advice 'random) + ;; + ;; - Default mode 'read-only. + ;; - Default advice 'sequential (right for whole-file scans — kernel + ;; read-aheads aggressively and drops pages we've already scanned, + ;; keeping working-set small). + ;; - Returns #f for an empty file. Callers must test. + ;; - Reraises any other mmap error. + ;; + ;; Why empty-file returns #f instead of erroring: scanner code that + ;; walks /usr/bin or a large directory tree encounters empty files + ;; routinely (zero-byte sentinels, truncated installers, etc.). Forcing + ;; every caller to wrap mmap-file in try/catch would defeat the + ;; ergonomic point of this layer. + + (def (mmap-file path . opts) + (let ([mode (get-opt opts '#:mode 'read-only)] + [advice (get-opt opts '#:advice 'sequential)]) + (try + (let ([mm (mmap path '#:mode mode)]) + (when advice + (try (madvise mm advice) + (catch (_) #f))) ;; advice is a hint; failures are fine + mm) + (catch (e) + (if (empty-file-error? e) + #f + (raise e)))))) + + ;; Detect "file is empty / size is zero" condition messages from + ;; (std os mmap). Anything else propagates. + (def (empty-file-error? e) + (and (condition? e) + (message-condition? e) + (let ([m (condition-message e)]) + (and (string? m) + (or (string-contains? m "empty") + (string-contains? m "size is zero")))))) + + (def (string-contains? s sub) + (let ([slen (string-length s)] + [sublen (string-length sub)]) + (let loop ([i 0]) + (cond + [(> (+ i sublen) slen) #f] + [(string=? (substring s i (+ i sublen)) sub) #t] + [else (loop (+ i 1))])))) + + ;;; ========== with-mmap ========== + ;; + ;; (with-mmap [name expr] body ...) + ;; + ;; Guarantees munmap on normal exit or via an exception. If expr + ;; yields #f (empty file), name is bound to #f and no cleanup runs. + ;; Bodies that need to handle the empty case must test name explicitly. + ;; + ;; Implemented via dynamic-wind so unwinds, raises, and normal returns + ;; all release the mapping. The before-thunk is a no-op (we don't + ;; reacquire on continuation re-entry — mmap is single-acquisition). + + (define-syntax with-mmap + (syntax-rules () + [(_ [name expr] body ...) + (let ([name expr]) + (dynamic-wind + (lambda () #f) + (lambda () body ...) + (lambda () + (when (mmap-region? name) + (try (munmap name) + (catch (_) #f))))))])) + + ;;; ========== open-mmap-input-port ========== + ;; + ;; Returns a Chez binary input port over a mapped region. Code that + ;; expects a port (get-bytevector-n!, lookahead-u8, port-read! …) can + ;; read from an mmap'd file without us copying it into a fresh + ;; bytevector first. + ;; + ;; The port's read! callback still copies from foreign memory into the + ;; caller-supplied bytevector, so this is not strictly zero-copy at + ;; the userspace level — but the multi-MB file copy is avoided, and + ;; per-read 8 KB chunks live in the TLAB and are reclaimed cheaply. + ;; + ;; When the port is closed, the region is NOT unmapped. Callers retain + ;; ownership of region lifetime; pair with with-mmap to get both. + + (def (open-mmap-input-port region . rest) + (let ([name (if (pair? rest) (car rest) "mmap")]) + (let ([pos 0] + [size (mmap-region-size region)] + [addr (mmap-region-addr region)]) + (make-custom-binary-input-port + name + (lambda (bv start count) + (let ([remaining (- size pos)]) + (if (<= remaining 0) + 0 + (let ([n (if (< count remaining) count remaining)]) + (do ([i 0 (+ i 1)]) + ((= i n)) + (bytevector-u8-set! bv (+ start i) + (foreign-ref 'unsigned-8 addr (+ pos i)))) + (set! pos (+ pos n)) + n)))) + ;; get-position + (lambda () pos) + ;; set-position! + (lambda (new-pos) + (when (or (< new-pos 0) (> new-pos size)) + (error 'mmap-input-port "position out of range" new-pos)) + (set! pos new-pos)) + ;; close — do NOT munmap; caller owns the region. + (lambda () #f))))) + + ;;; ========== Search primitives ========== + ;; + ;; These operate directly on the mapping via foreign-ref, so they do + ;; not allocate during the scan. Use these inside hot loops instead of + ;; (mmap->bytevector) + bytevector operations. + + ;; Find the first occurrence of `byte` at or after `start`. Returns + ;; the absolute offset or #f. + (def (mmap-find-byte region start byte) + (let ([size (mmap-region-size region)] + [addr (mmap-region-addr region)]) + (let loop ([i start]) + (cond + [(>= i size) #f] + [(= (foreign-ref 'unsigned-8 addr i) byte) i] + [else (loop (+ i 1))])))) + + ;; Compare a slice of the mapping starting at `offset` against the + ;; bytes of `bv`. #t iff every byte matches and the slice fits. + (def (mmap-bytes=? region offset bv) + (let ([size (mmap-region-size region)] + [addr (mmap-region-addr region)] + [n (bytevector-length bv)]) + (and (>= offset 0) + (<= (+ offset n) size) + (let loop ([i 0]) + (cond + [(= i n) #t] + [(= (foreign-ref 'unsigned-8 addr (+ offset i)) + (bytevector-u8-ref bv i)) + (loop (+ i 1))] + [else #f]))))) + + ;; Find the first occurrence of bytevector `needle` at or after + ;; `start`. Returns the absolute offset or #f. Uses naive scan with + ;; first-byte skip via mmap-find-byte — for typical needle sizes