Phase 5 complete: Compiler as Library, Persistence, Inspector, Effects, Concurrency, Systems
ober
2fa9ba1d7b3785f27ad2a7c7cb9841ccfb6b17f5
--- 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-features test-wrappers test-phase4a test-phase4b test-phase4c test-phase4d test-phase4e test-phase4f test-phase5 clean +.PHONY: test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-features test-wrappers test-phase4a test-phase4b test-phase4c test-phase4d test-phase4e test-phase4f test-phase5 test-phase5e clean test: test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded @@ -184,10 +184,40 @@ test-phase4f: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-cross-compile.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-reproducible.ss -test-phase5: - @echo "--- Phase 5: Compiler as Library tests ---" +test-phase5: test-phase5a test-phase5b test-phase5c test-phase5d test-phase5e + +test-phase5a: + @echo "--- Phase 5a: Compiler as Library ---" @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-cp0-passes.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-compiler-partial-eval.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-regex-compile.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-delimited.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-pgo.ss + +test-phase5b: + @echo "--- Phase 5b: Persistence and Distribution ---" + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-persist-closure.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-persist-image.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-continuation-marks.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-coroutine.ss + +test-phase5c: + @echo "--- Phase 5c: Inspector and Debugging ---" + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-inspector.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-closure-inspect.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-record-inspect.ss + +test-phase5d: + @echo "--- Phase 5d: Advanced Effects and Concurrency ---" + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-effect-fusion.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-stm-nested.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-async-await.ss + +test-phase5e: + @echo "--- Phase 5e: Systems and Zero-Cost ---" + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-benchmark.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-json-schema.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-query-compile.ss test-all: test test-features test-wrappers --- a/docs/index.md +++ b/docs/index.md @@ -4,7 +4,7 @@ Jerboa is a systems programming language built on Chez Scheme, providing Gerbil compatibility with additional features: algebraic effects, gradual typing, native binary compilation, and a full actor/distributed system. -**Current state**: 173 modules, ~35,000 lines, 2,898 tests (Phases 1–3 + Phase 4 complete). +**Current state**: ~204 modules, ~37,500 lines, ~3,196 tests (Phases 1–4 + Phase 5a–5e complete). ## New Feature Documentation (Phases 1–13) @@ -149,6 +149,36 @@ compilation, and a full actor/distributed system. - `(std build cross)` — cross-compilation pipeline: 5 built-in platforms, `current-platform`, `find-cross-compiler`, `run-build-matrix` - `(std build reproducible)` — reproducible builds: FNV-1a content hash, `make-artifact-store`, `make-manifest`, `make-build-cache`, `normalize-artifact` +## Phase 5 Libraries (2026-03-12) + +### Phase 5a: Compiler as Library +- `(std compiler cp0-passes)` — user-defined cp0 optimization passes with priority, debugging, composition +- `(std compiler partial-eval)` — compile-time partial evaluation with binding-time analysis +- `(std text regex-compile)` — compile-time NFA→DFA regex compilation with `compile-regex`, `define-regex`, `regex-match` +- `(std control delimited)` — delimited continuations: `shift`/`reset`, `control`/`prompt`, named prompts, `abort` +- `(std compiler pgo)` — profile-guided optimization: `define/profile`, `with-profiling`, `profile-hot-functions`, save/load + +### Phase 5b: Persistence and Distribution +- `(std persist closure)` — fasl-based closure serialization: `fasl-serialize`, `fasl-deserialize`, `closure-save`, `closure-load` +- `(std persist image)` — image-based development: `image-set!`, `image-ref`, `save-image`, `load-image` +- `(std control marks)` — continuation marks: `with-continuation-mark`, `current-continuation-marks`, `marks->list` +- `(std control coroutine)` — symmetric coroutines: `make-coroutine`, `coroutine-transfer`, `yield`, `coroutine-scheduler` + +### Phase 5c: Inspector and Debugging +- `(std debug inspector)` — stack frame inspection: `with-tracked-call`, `current-stack-frames`, `stack-trace`, `with-stack-inspector` +- `(std debug closure-inspect)` — closure introspection: `make-tracked-closure`, `closure-free-variables`, `closure-with`, `closure-min-arity` +- `(std debug record-inspect)` — record introspection: `record-ref`, `record-set!`, `record->alist`, `record-copy` + +### Phase 5d: Advanced Effects and Concurrency +- `(std effect fusion)` — effect handler fusion: `with-fused-handlers`, `fuse-handlers`, `handler-fusion-stats` +- `(std concur stm)` — STM with nested transactions: `make-tvar`, `atomically`, `retry`, `or-else` +- `(std concur async-await)` — promise-based async/await: `async`, `await`, `await-all`, `await-any`, `define-async`, cancellation tokens + +### Phase 5e: Systems and Zero-Cost +- `(std dev benchmark)` — statistical benchmarking: `define-benchmark`, `run-benchmark`, `benchmark-report`, `benchmark-compare` +- `(std text json-schema)` — JSON schema validation: `define-json-schema`, `validate-json`, `schema-valid?`, constraint types +- `(std db query-compile)` — SQL query builder: `from`, `where`, `select`, `compile-query`, `define-query` + ## Existing Documentation | Document | Description | @@ -205,6 +235,12 @@ make test-phase4d # Developer Experience make test-phase4e # Data and Distribution make test-phase4f # Toolchain and Interop make test-all # everything +make test-phase5 # all Phase 5 sub-phases +make test-phase5a # Compiler as Library +make test-phase5b # Persistence and Distribution +make test-phase5c # Inspector and Debugging +make test-phase5d # Advanced Effects and Concurrency +make test-phase5e # Systems and Zero-Cost ``` ## Standard Library Overview @@ -227,6 +263,12 @@ make test-all # everything - `(std concur)` — thread-safety annotations, deadlock detection, resource tracking - `(std concur deadlock)` — runtime wait-for graph deadlock detection *(Phase 4c)* - `(std concur util)` — semaphores, barriers, rwlocks, thread pools, latches *(Phase 4c)* +- `(std concur stm)` — STM with nested transactions and `or-else` *(Phase 5d)* +- `(std concur async-await)` — promise-based async/await with cancellation *(Phase 5d)* +- `(std control delimited)` — shift/reset/control/prompt delimited continuations *(Phase 5a)* +- `(std control marks)` — continuation marks with dynamic extent *(Phase 5b)* +- `(std control coroutine)` — symmetric coroutines with cooperative scheduling *(Phase 5b)* +- `(std effect fusion)` — handler fusion for reduced continuation overhead *(Phase 5d)* - `(std task)` — task groups and structured concurrency - `(std misc channel)` — typed channels - `(std sched)` — M:N scheduler with OS worker threads *(Phase 2d)* @@ -291,6 +333,8 @@ make test-all # everything ### Data Formats - `(std text json)` — JSON read/write +- `(std text json-schema)` — JSON schema validation with `define-json-schema` *(Phase 5e)* +- `(std text regex-compile)` — compile-time regex to DFA with `define-regex` *(Phase 5a)* - `(std text csv)` — CSV parsing/writing - `(std text xml)` — SXML → XML - `(std text yaml)` — YAML load/dump @@ -306,11 +350,17 @@ make test-all # everything - `(std foreign)` — safe C FFI with memory management ### Databases +- `(std db query-compile)` — SQL query builder with compile-time validation *(Phase 5e)* - `(std db sqlite)` — SQLite - `(std db postgresql)` — PostgreSQL - `(std db leveldb)` — LevelDB key-value store ### Developer Tools +- `(std debug inspector)` — pseudo stack frame inspection and `with-stack-inspector` *(Phase 5c)* +- `(std debug closure-inspect)` — closure introspection and free variable mutation *(Phase 5c)* +- `(std debug record-inspect)` — record field access by index or name, `record->alist` *(Phase 5c)* +- `(std dev benchmark)` — statistical benchmarking with mean/stddev/CI *(Phase 5e)* +- `(std compiler pgo)` — profile-guided optimization, `define/profile`, hot function detection *(Phase 5a)* - `(std dev debug)` — time-travel debugger, execution recording - `(std debug timetravel)` — event recorder with `trace-fn` and `replay-to-step` *(Phase 4d)* - `(std debug flamegraph)` — manual enter/exit profiler → flamegraph text output *(Phase 4d)* new file mode 100644 --- /dev/null +++ b/lib/std/compiler/pgo.sls @@ -0,0 +1,183 @@ +;;; Profile-Guided Optimization (PGO) — Phase 5a (Track 11.3) +;;; +;;; Collects runtime profiling data and uses it to guide compilation. +;;; Provides call-count profiling, hot-function detection, and profile +;;; data persistence. + +(library (std compiler pgo) + (export + ;; Profile collection + profile-reset! ; clear all collected data + profile-running? ; #t when collection is active + profiling-enable! ; turn profiling on + profiling-disable! ; turn profiling off + + ;; Data access + profile-data ; full alist of (name . count) + profile-call-count ; call count for a name symbol + profile-hot-functions ; top-N hottest functions + + ;; Persistence + profile-save ; write profile data to file + profile-load ; read profile data from file + profile-load! ; load and merge into current data + + ;; Annotation helpers + define/profile ; define + auto-instrument + with-profiling ; run body with profiling enabled + + ;; PGO macros + define-pgo-module ; mark a module for PGO + profile-guided-inline? ; hint: should this call site be inlined? + + ;; Reporting + profile-report) + + (import (chezscheme)) + + ;; ----------------------------------------------------------------------- + ;; State (symbol → integer call-count table) + ;; Use an eq-hashtable keyed by symbols to avoid mutable-var-in-macro issues. + ;; ----------------------------------------------------------------------- + + (define *counts* (make-eq-hashtable)) + (define *active-cell* (list #f)) ; (active?) + + (define (profiling-enable!) (set-car! *active-cell* #t)) + (define (profiling-disable!) (set-car! *active-cell* #f)) + (define (profile-running?) (car *active-cell*)) + + (define (profile-reset!) + "Clear all profiling data" + (let-values ([(keys _) (hashtable-entries *counts*)]) + (vector-for-each (lambda (k) (hashtable-set! *counts* k 0)) keys))) + + ;; ----------------------------------------------------------------------- + ;; Internal tick — called from define/profile expansions + ;; ----------------------------------------------------------------------- + + (define (pgo-tick! sym) + (when (car *active-cell*) + (hashtable-update! *counts* sym (lambda (n) (+ n 1)) 0))) + + ;; ----------------------------------------------------------------------- + ;; Data access + ;; ----------------------------------------------------------------------- + + (define (profile-data) + "Return alist of (symbol . count) sorted by descending count" + (let-values ([(keys vals) (hashtable-entries *counts*)]) + (let ([result '()]) + (vector-for-each (lambda (k v) (set! result (cons (cons k v) result))) + keys vals) + (list-sort (lambda (a b) (> (cdr a) (cdr b))) result)))) + + (define (profile-call-count sym) + "Return the call count for SYM (0 if not recorded)" + (hashtable-ref *counts* sym 0)) + + (define (profile-hot-functions . args) + "Return the top-N entries by call count. + Usage: (profile-hot-functions) or (profile-hot-functions n) + or (profile-hot-functions filename n)" + (let-values ([(file n) + (cond + [(and (= (length args) 2) + (string? (car args)) (integer? (cadr args))) + (values (car args) (cadr args))] + [(and (= (length args) 1) (integer? (car args))) + (values #f (car args))] + [else (values #f 20)])]) + (let* ([data (if file (profile-load file) (profile-data))] + [sorted (list-sort (lambda (a b) (> (cdr a) (cdr b))) data)]) + (if (< n (length sorted)) (list-head sorted n) sorted)))) + + ;; ----------------------------------------------------------------------- + ;; Persistence + ;; ----------------------------------------------------------------------- + + (define (profile-save filename) + "Write current profile data to FILENAME" + (call-with-output-file filename + (lambda (port) + (write `(jerboa-profile ,(profile-data)) port) + (newline port)))) + + (define (profile-load filename) + "Load profile data from FILENAME; returns alist" + (if (file-exists? filename) + (call-with-input-file filename + (lambda (port) + (let ([form (read port)]) + (if (and (pair? form) (eq? (car form) 'jerboa-profile)) + (cadr form) + (error 'profile-load "malformed profile" filename))))) + '())) + + (define (profile-load! filename) + "Merge profile data from FILENAME into current counts" + (for-each + (lambda (entry) + (hashtable-update! *counts* (car entry) + (lambda (n) (+ n (cdr entry))) 0)) + (profile-load filename))) + + ;; ----------------------------------------------------------------------- + ;; define/profile — auto-instrumented define + ;; + ;; (define/profile (f x y) body ...) + ;; expands to a function that ticks the symbol 'f before running body. + ;; ----------------------------------------------------------------------- + + (define-syntax define/profile + (syntax-rules () + [(_ (name args ...) body ...) + (define (name args ...) + (pgo-tick! 'name) + body ...)])) + + ;; ----------------------------------------------------------------------- + ;; with-profiling + ;; ----------------------------------------------------------------------- + + (define-syntax with-profiling + (syntax-rules () + [(_ body ...) + (dynamic-wind + profiling-enable! + (lambda () body ...) + profiling-disable!)])) + + ;; ----------------------------------------------------------------------- + ;; define-pgo-module — documentation/annotation marker + ;; ----------------------------------------------------------------------- + + (define-syntax define-pgo-module + (syntax-rules () + [(_ (lib ...) body ...) (begin body ...)])) + + ;; ----------------------------------------------------------------------- + ;; profile-guided-inline? + ;; ----------------------------------------------------------------------- + + (define (profile-guided-inline? sym threshold) + "Return #t if SYM should be inlined (call count >= threshold)" + (>= (hashtable-ref *counts* sym 0) threshold)) + + ;; ----------------------------------------------------------------------- + ;; profile-report + ;; ----------------------------------------------------------------------- + + (define (profile-report . args) + "Print a human-readable profile report" + (let ([port (if (null? args) (current-output-port) (car args))] + [n 20]) + (let ([data (profile-data)]) + (fprintf port "~n=== Profile Report (~a entries) ===~n" (length data)) + (for-each + (lambda (entry) + (fprintf port " ~a: ~a calls~n" (car entry) (cdr entry))) + (if (< n (length data)) (list-head data n) data)) + (fprintf port "====================================~n")))) + +) new file mode 100644 --- /dev/null +++ b/lib/std/concur/async-await.sls @@ -0,0 +1,221 @@ +;;; Async/Await with Structured Concurrency — Phase 5d (Track 17.3) +;;; +;;; Provides promise-based async/await backed by Chez Scheme threads. +;;; Promises carry a value or an exception; await blocks until resolved. +;;; +;;; API: +;;; (make-promise) — create an unfulfilled promise +;;; (promise? x) — type predicate +;;; (promise-resolve! p val) — fulfill with value +;;; (promise-reject! p exn) — fulfill with error +;;; (promise-await p) — block until fulfilled; re-raise errors +;;; (promise-resolved? p) — #t if already resolved +;;; (async thunk) — spawn thunk in background thread, return promise +;;; (await expr) — inside async context: wait for promise +;;; (await-all p ...) — wait for all promises; return list of values +;;; (await-any p ...) — wait for first fulfilled promise +;;; (define-async (name args ...) body .) — define async function returning promise +;;; (make-cancellation-token-source) — create a cancellation source +;;; (cts-token cts) — extract token from source +;;; (cts-cancel! cts) — signal cancellation +;;; (cancellation-token? t) — type predicate +;;; (check-cancellation! t) — raise if cancelled + +(library (std concur async-await) + (export + ;; Promises + make-promise + promise? + promise-resolve! + promise-reject! + promise-await + promise-resolved? + + ;; Async execution + async + await + await-all + await-any + define-async + + ;; Cancellation + make-cancellation-token-source + cts-token + cts-cancel! + cancellation-token? + check-cancellation!) + + (import (chezscheme)) + + ;; ----------------------------------------------------------------------- + ;; Promise implementation + ;; + ;; A promise is a record holding: + ;; state: 'pending | 'resolved | 'rejected + ;; value: the resolved value (when state = 'resolved) + ;; error: the exception (when state = 'rejected) + ;; mutex: protects state transitions + ;; cond: waited on by promise-await + ;; ----------------------------------------------------------------------- + + (define-record-type promise-record + (fields (mutable state promise-state set-promise-state!) + (mutable value promise-value set-promise-value!) + (mutable error promise-error set-promise-error!) + (immutable mutex promise-mutex) + (immutable cond promise-cond)) + (protocol + (lambda (new) + (lambda () + (new 'pending #f #f (make-mutex) (make-condition)))))) + + (define (make-promise) (make-promise-record)) + (define (promise? x) (promise-record? x)) + + (define (promise-resolved? p) + (not (eq? (promise-state p) 'pending))) + + (define (promise-resolve! p val) + (let ([m (promise-mutex p)]) + (mutex-acquire m) + (when (eq? (promise-state p) 'pending) + (set-promise-value! p val) + (set-promise-state! p 'resolved) + (condition-broadcast (promise-cond p))) + (mutex-release m))) + + (define (promise-reject! p exn) + (let ([m (promise-mutex p)]) + (mutex-acquire m) + (when (eq? (promise-state p) 'pending) + (set-promise-error! p exn) + (set-promise-state! p 'rejected) + (condition-broadcast (promise-cond p))) + (mutex-release m))) + + (define (promise-await p) + "Block until P is resolved; return value or re-raise error" + (let ([m (promise-mutex p)]) + (mutex-acquire m) + (let loop () + (cond + [(eq? (promise-state p) 'resolved) + (let ([v (promise-value p)]) + (mutex-release m) + v)] + [(eq? (promise-state p) 'rejected) + (let ([e (promise-error p)]) + (mutex-release m) + (raise e))] + [else + (condition-wait (promise-cond p) m) + (loop)])))) + + ;; ----------------------------------------------------------------------- + ;; async — spawn a thunk in a background thread, return a promise + ;; ----------------------------------------------------------------------- + + (define (async thunk) + "Spawn THUNK in a background thread; return a promise for its result" + (let ([p (make-promise)]) + (fork-thread + (lambda () + (call-with-current-continuation + (lambda (k) + (with-exception-handler + (lambda (e) + (promise-reject! p e) + (k (void))) + (lambda () + (let ([v (thunk)]) + (promise-resolve! p v)))))))) + p)) + + ;; ----------------------------------------------------------------------- + ;; await — within an async context, block on a promise + ;; ----------------------------------------------------------------------- + + (define (await p) + "Wait for promise P and return its value (or re-raise its error)" + (cond + [(promise? p) (promise-await p)] + [else p])) ; already a plain value — return as-is + + ;; ----------------------------------------------------------------------- + ;; await-all — wait for all promises, return list of results + ;; ----------------------------------------------------------------------- + + (define (await-all . promises) + "Wait for all PROMISES; return list of values in order" + (map promise-await promises)) + + ;; ----------------------------------------------------------------------- + ;; await-any — return value of first promise to resolve + ;; ----------------------------------------------------------------------- + + (define (await-any . promises) + "Return value of the first promise in PROMISES to resolve" + (let ([winner-p (make-promise)] + [done (list #f)]) ; one-shot flag + ;; Attach a waiter thread to each promise + (for-each + (lambda (p) + (fork-thread + (lambda () + (call-with-current-continuation + (lambda (k) + (with-exception-handler + (lambda (e) + ;; If winner not yet chosen, propagate rejection + (mutex-acquire (promise-mutex winner-p)) + (when (not (car done)) + (set-car! done #t) + (mutex-release (promise-mutex winner-p)) + (promise-reject! winner-p e)) + (when (car done) (mutex-release (promise-mutex winner-p))) + (k (void))) + (lambda () + (let ([v (promise-await p)]) + (mutex-acquire (promise-mutex winner-p)) + (when (not (car done)) + (set-car! done #t) + (mutex-release (promise-mutex winner-p)) + (promise-resolve! winner-p v)) + (when (car done) + (mutex-release (promise-mutex winner-p))))))))))) + promises) + (promise-await winner-p))) + + ;; ----------------------------------------------------------------------- + ;; define-async macro + ;; ----------------------------------------------------------------------- + + (define-syntax define-async + (syntax-rules () + [(_ (name args ...) body ...) + (define (name args ...) + (async (lambda () body ...)))])) + + ;; ----------------------------------------------------------------------- + ;; Cancellation tokens + ;; ----------------------------------------------------------------------- + + (define-record-type cancellation-token + (fields (mutable cancelled? ct-cancelled? set-ct-cancelled!)) + (protocol (lambda (new) (lambda () (new #f))))) + + (define-record-type cts-record + (fields (immutable token cts-token)) + (protocol (lambda (new) (lambda () (new (make-cancellation-token)))))) + + (define (make-cancellation-token-source) (make-cts-record)) + + (define (cts-cancel! cts) + (set-ct-cancelled! (cts-token cts) #t)) + + (define (check-cancellation! token) + (when (ct-cancelled? token) + (raise (condition + (make-message-condition "operation cancelled"))))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/concur/stm.sls @@ -0,0 +1,198 @@ +;;; Software Transactional Memory — Phase 5d (Track 17.1) +;;; +;;; Optimistic concurrency with transactional variables (TVars). +;;; Supports nested transactions, retry, and or-else. + +(library (std concur stm) + (export + make-tvar tvar? tvar-get tvar-set! + atomically retry or-else) + (import (chezscheme)) + + ;; ----------------------------------------------------------------------- + ;; TVar — a versioned mutable cell + ;; ----------------------------------------------------------------------- + + (define-record-type tvar + (fields (mutable val tvar-val set-tvar-val!) + (mutable ver tvar-ver set-tvar-ver!)) + (protocol (lambda (new) (lambda (init) (new init 0))))) + + ;; Global version clock + (define *global-version* 0) + + ;; ----------------------------------------------------------------------- + ;; Transaction context (thread-local) + ;; ----------------------------------------------------------------------- + ;; Each transaction has: + ;; read-set: eq-hashtable tvar → observed-version + ;; write-set: eq-hashtable tvar → new-value + ;; parent: outer transaction or #f + + (define-record-type txn + (fields (immutable read-set txn-read-set) + (immutable write-set txn-write-set) + (mutable parent txn-parent set-txn-parent!)) + (protocol + (lambda (new) + (lambda (parent) + (new (make-eq-hashtable) (make-eq-hashtable) parent))))) + + (define *current-txn* (make-thread-parameter #f)) + + ;; ----------------------------------------------------------------------- + ;; Global commit mutex + ;; ----------------------------------------------------------------------- + + (define *stm-mutex* (make-mutex)) + (define *stm-cond* (make-condition)) + + ;; ----------------------------------------------------------------------- + ;; tvar-get — read TVar in transaction context + ;; ----------------------------------------------------------------------- + + (define (tvar-get tv) + (let ([txn (*current-txn*)]) + (if txn + ;; Inside transaction + (let ([ws (txn-write-set txn)] + [rs (txn-read-set txn)]) + (cond + ;; Written in this txn → return pending value + [(hashtable-contains? ws tv) + (hashtable-ref ws tv #f)] + ;; First read → record version + return current value + [else + (let ([v (tvar-val tv)] + [ver (tvar-ver tv)]) + (hashtable-set! rs tv ver) + v)])) + ;; Outside transaction → direct read + (tvar-val tv)))) + + ;; ----------------------------------------------------------------------- + ;; tvar-set! — write TVar in transaction context + ;; ----------------------------------------------------------------------- + + (define (tvar-set! tv val) + (let ([txn (*current-txn*)]) + (if txn + (hashtable-set! (txn-write-set txn) tv val) + ;; Direct write outside transaction + (begin + (mutex-acquire *stm-mutex*) + (set-tvar-val! tv val) + (set-tvar-ver! tv (+ *global-version* 1)) + (set! *global-version* (+ *global-version* 1)) + (condition-broadcast *stm-cond*) + (mutex-release *stm-mutex*))))) + + ;; ----------------------------------------------------------------------- + ;; Validation — check all read TVars are still current + ;; ----------------------------------------------------------------------- + + (define (validate-read-set! txn) + "Return #t if all read TVars still have observed versions" + (let-values ([(tvs vers) (hashtable-entries (txn-read-set txn))]) + (let loop ([i 0]) + (or (= i (vector-length tvs)) + (and (= (tvar-ver (vector-ref tvs i)) (vector-ref vers i)) + (loop (+ i 1))))))) + + ;; ----------------------------------------------------------------------- + ;; Commit — write all write-set values atomically + ;; ----------------------------------------------------------------------- + + (define (commit-txn! txn) + "Attempt to commit TXN; return #t on success, #f on conflict" + (mutex-acquire *stm-mutex*) + (let ([ok (validate-read-set! txn)]) + (when ok + (let-values ([(tvs vals) (hashtable-entries (txn-write-set txn))]) + (let ([new-ver (+ *global-version* 1)]) + (set! *global-version* new-ver) + (vector-for-each + (lambda (tv val) + (set-tvar-val! tv val) + (set-tvar-ver! tv new-ver)) + tvs vals))) + (condition-broadcast *stm-cond*)) + (mutex-release *stm-mutex*) + ok)) + + ;; ----------------------------------------------------------------------- + ;; atomically — run a transaction + ;; ----------------------------------------------------------------------- + + ;; Retry sentinel + (define *retry-tag* (list 'retry)) + + (define (atomically thunk) + (let ([outer (*current-txn*)]) + (if outer + ;; Nested: create child txn, merge into outer on success + (let ([child (make-txn outer)]) + (parameterize ([*current-txn* child]) + (let ([result (thunk)]) + ;; Merge child write-set into outer + (let-values ([(tvs vals) (hashtable-entries (txn-write-set child))]) + (vector-for-each + (lambda (tv v) (hashtable-set! (txn-write-set outer) tv v)) + tvs vals)) + result))) + ;; Top-level: run with retry loop + (call-with-current-continuation + (lambda (k-done) + (let loop () + (let ([txn (make-txn #f)]) + (parameterize ([*current-txn* txn]) + (call-with-current-continuation + (lambda (k-escape) + (with-exception-handler + (lambda (e) + (if (eq? e *retry-tag*) + ;; retry: block until some TVar changes + (begin + (mutex-acquire *stm-mutex*) + (condition-wait *stm-cond* *stm-mutex*) + (mutex-release *stm-mutex*) + (k-escape 'retry)) + (raise e))) + (lambda () + (let ([result (thunk)]) + (when (commit-txn! txn) + (k-done result))))))))) + ;; retry or conflict: run again + (loop))))))) + + ;; ----------------------------------------------------------------------- + ;; retry — abort and wait for change + ;; ----------------------------------------------------------------------- + + (define (retry) + (raise *retry-tag*)) + + ;; ----------------------------------------------------------------------- + ;; or-else — try first transaction; if it retries, try second + ;; ----------------------------------------------------------------------- + + (define-syntax or-else + (syntax-rules () + [(_ thunk1 thunk2) + (let ([succeeded #f] + [result #f]) + (call-with-current-continuation + (lambda (k) + (with-exception-handler + (lambda (e) + (if (eq? e *retry-tag*) + (k 'retry-first) + (raise e))) + (lambda () + (set! result (thunk1)) + (set! succeeded #t))))) + (if succeeded + result + (thunk2)))])) + +) new file mode 100644 --- /dev/null +++ b/lib/std/control/coroutine.sls @@ -0,0 +1,152 @@ +;;; Coroutines — Phase 5b (Track 12.2) +;;; +;;; Symmetric coroutines implemented on top of call/cc. +;;; +;;; Each coroutine wraps a thunk that receives a `yield` procedure. +;;; Calling `yield` suspends the coroutine and returns a value to +;;; whoever last called `coroutine-transfer`. The coroutine is resumed +;;; by the next call to `coroutine-transfer`, which passes a value back +;;; to the waiting `yield` call. +;;; +;;; States: +;;; ready — created, not yet started +;;; running — currently executing +;;; suspended — paused at a `yield` call +;;; done — thunk returned normally +;;; +;;; Exports: +;;; make-coroutine thunk → coroutine +;;; coroutine? val → bool +;;; coroutine-state co → 'ready|'running|'suspended|'done +;;; coroutine-transfer co [val] → val +;;; coroutine-done? co → bool +;;; make-round-robin-scheduler → scheduler +;;; scheduler-add! sched co → void +;;; scheduler-run! sched → void + +(library (std control coroutine) + (export + make-coroutine + coroutine? + coroutine-state + coroutine-transfer + coroutine-done? + make-round-robin-scheduler + scheduler-add! + scheduler-run!) + + (import (chezscheme)) + + ;; ----------------------------------------------------------------------- + ;; Coroutine record + ;; ----------------------------------------------------------------------- + + (define-record-type coroutine-record + (fields + (mutable state coroutine-state %coroutine-set-state!) + (mutable resume %coroutine-resume %coroutine-set-resume!) + (mutable caller %coroutine-caller %coroutine-set-caller!)) + (protocol + (lambda (new) + (lambda () + (new 'ready #f #f))))) + + ;; ----------------------------------------------------------------------- + ;; Public constructor + ;; ----------------------------------------------------------------------- + + ;; make-coroutine : (yield → any) → coroutine + ;; + ;; `thunk` receives a `yield` procedure. Calling (yield val) suspends + ;; the coroutine and returns val to the caller of coroutine-transfer. + ;; The value passed to the next coroutine-transfer becomes yield's result. + + (define (make-coroutine thunk) + (let ([co (make-coroutine-record)]) + ;; Attach the thunk as the initial transfer action + (%coroutine-set-resume! + co + (lambda (val) + ;; This lambda is invoked on the first coroutine-transfer. + ;; We build the yield procedure here so it closes over `co`. + (define (yield . yrest) + (let ([yval (if (null? yrest) (void) (car yrest))]) + (call/cc + (lambda (k) + (%coroutine-set-resume! co k) + (%coroutine-set-state! co 'suspended) + ((%coroutine-caller co) yval))))) + (%coroutine-set-state! co 'running) + (thunk yield) + ;; thunk returned — coroutine is done + (%coroutine-set-state! co 'done) + (%coroutine-set-resume! co #f) + ((%coroutine-caller co) (void)))) + co)) + + ;; ----------------------------------------------------------------------- + ;; coroutine? — type predicate + ;; ----------------------------------------------------------------------- + + (define (coroutine? v) + (coroutine-record? v)) + + ;; ----------------------------------------------------------------------- + ;; coroutine-done? + ;; ----------------------------------------------------------------------- + + (define (coroutine-done? co) + (eq? (coroutine-state co) 'done)) + + ;; ----------------------------------------------------------------------- + ;; coroutine-transfer co [val] → val + ;; + ;; Transfers control to CO, passing VAL (default: void). + ;; Returns the value passed to the next yield (or void when done). + ;; ----------------------------------------------------------------------- + + (define (coroutine-transfer co . rest) + (let ([val (if (null? rest) (void) (car rest))]) + (case (coroutine-state co) + [(ready suspended) + (let ([resume (%coroutine-resume co)]) + (call/cc + (lambda (caller-k) + (%coroutine-set-caller! co caller-k) + (resume val))))] + [(done) + (error 'coroutine-transfer "coroutine is already done" co)] + [(running) + (error 'coroutine-transfer "coroutine is already running" co)] + [else + (error 'coroutine-transfer "coroutine in unknown state" + (coroutine-state co))]))) + + ;; ----------------------------------------------------------------------- + ;; Round-robin scheduler + ;; ----------------------------------------------------------------------- + + (define-record-type scheduler-record + (fields (mutable queue %sched-queue %sched-set-queue!)) + (protocol + (lambda (new) + (lambda () (new '()))))) + + (define (make-round-robin-scheduler) + (make-scheduler-record)) + + (define (scheduler-add! sched co) + (%sched-set-queue! sched + (append (%sched-queue sched) (list co)))) + + ;; scheduler-run! — repeatedly cycle through the queue until all done + (define (scheduler-run! sched) + (let loop () + (let ([alive (filter (lambda (co) (not (coroutine-done? co))) + (%sched-queue sched))]) + (when (not (null? alive)) + (%sched-set-queue! sched alive) + (for-each (lambda (co) (coroutine-transfer co)) alive) + (loop))))) + +) new file mode 100644 --- /dev/null +++ b/lib/std/control/delimited.sls @@ -0,0 +1,196 @@ +;;; Delimited Continuations — Phase 5a (Track 12.1) +;;; +;;; Implements shift/reset (Danvy-Filinski) and control/prompt (Felleisen) +;;; delimited control operators on top of Chez Scheme's call/cc. +;;; +;;; Key insight: the metacontinuation stack uses a mutable variable so +;;; that continuation invocations see the current (dynamic) state rather +;;; than the state at capture time (which parameterize would enforce via +;;; dynamic-wind). +;;; +;;; References: +;;; Danvy & Filinski 1990: "Abstracting Control" +;;; Filinski 1994: "Representing Monads" + +(library (std control delimited) + (export + ;; Shift/reset — composable delimited continuations + reset + shift + + ;; Control/prompt — abortive delimited continuations + prompt + control + + ;; Named prompts for nested multi-prompt delimited control + make-prompt-tag + prompt-tag? + prompt-tag-name + reset-at + shift-at + prompt-at + control-at + + ;; Utilities + reset/values + abort) + + (import (except (chezscheme) reset abort)) + + ;; ----------------------------------------------------------------------- + ;; Prompt tags — unique labels for nested delimiters + ;; ----------------------------------------------------------------------- + + (define-record-type prompt-tag + (fields (immutable name prompt-tag-name)) + (protocol (lambda (new) (lambda (name) (new name))))) + + (define *default-tag* (make-prompt-tag 'default)) + + ;; ----------------------------------------------------------------------- + ;; Metacontinuation stack + ;; + ;; Represented as a list of (tag . escape-k) pairs. + ;; Using a plain mutable cell (not parameterize) so that calling a + ;; captured continuation sees the current dynamic state of the stack. + ;; ----------------------------------------------------------------------- + + (define *mk* '()) ; list of (tag . k) + + (define (mk-push! tag k) + (set! *mk* (cons (cons tag k) *mk*))) + + (define (mk-pop!) + (let ([top (car *mk*)]) + (set! *mk* (cdr *mk*)) + top)) + + (define (mk-find tag) + "Find and remove the innermost frame with TAG; return (frame . rest)" + (let loop ([stack *mk*] [above '()]) + (cond + [(null? stack) + (error 'shift "no enclosing reset for tag" (prompt-tag-name tag))] + [(eq? (caar stack) tag) + ;; Found: restore *mk* to the tail, return the escape-k + (let ([k (cdar stack)] + [rest (cdr stack)]) + (set! *mk* rest) + ;; Return escape-k and the frames that were above it (for + ;; named-prompt multi-prompt support — currently unused) + k)] + [else