Phase 4c complete: Systems and Performance (6 libraries, 179 tests passing)
ober
be8ce1119767ce0382a157c0a115a0735f3f5f09
--- a/Makefile +++ b/Makefile @@ -151,6 +151,15 @@ test-phase4b: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-taint.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-sandbox.ss +test-phase4c: + @echo "--- Phase 4c: Systems and Performance tests ---" + @$(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-multishot.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-deadlock.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-concur-util.ss + test-all: test test-features test-wrappers clean: new file mode 100644 --- /dev/null +++ b/lib/std/arena.sls @@ -0,0 +1,204 @@ +#!chezscheme +;;; (std arena) — Arena allocators: fast, bulk-freeable memory allocation +;;; +;;; Arenas provide bump-pointer allocation backed by a large bytevector. +;;; All allocations are O(1). Freeing is O(1) via arena-reset! which +;;; invalidates ALL prior allocations at once. +;;; +;;; WARNING: arena-reset! invalidates all previously allocated slices. +;;; Do not hold references to arena slices across a reset. + +(library (std arena) + (export + ;; Arena creation + make-arena + arena? + arena-capacity + arena-used + arena-remaining + arena-reset! + arena-destroy! + ;; Allocation + arena-alloc + arena-alloc-string + arena-alloc-bytes + ;; Bulk ops + with-arena + arena-checkpoint + arena-rollback! + ;; Stats + arena-stats + ;; Arena-backed string interning + make-arena-interner + arena-intern! + arena-intern-lookup) + + (import (chezscheme)) + + ;; ========== Arena record ========== + + (define-record-type %arena + (fields + (immutable backing) ;; bytevector — the backing store + (mutable used) ;; bytes used so far (bump pointer) + (mutable destroyed?)) ;; #t after arena-destroy! + (protocol + (lambda (new) + (lambda (capacity) + (new (make-bytevector capacity 0) 0 #f))))) + + (define (make-arena capacity) + (make-%arena capacity)) + + (define (arena? x) (%arena? x)) + + (define (arena-capacity a) + (bytevector-length (%arena-backing a))) + + (define (arena-used a) (%arena-used a)) + + (define (arena-remaining a) + (- (arena-capacity a) (%arena-used a))) + + ;; Check arena is live + (define (assert-live! who a) + (when (%arena-destroyed? a) + (error who "arena has been destroyed" a))) + + ;; ========== arena-reset! ========== + ;; O(1): set used back to 0. All prior allocations become invalid. + (define (arena-reset! a) + (assert-live! 'arena-reset! a) + (%arena-used-set! a 0)) + + ;; ========== arena-destroy! ========== + ;; Release the backing store (GC will collect it). + (define (arena-destroy! a) + (%arena-destroyed?-set! a #t) + (%arena-used-set! a 0)) + + ;; ========== arena-alloc ========== + ;; Bump-allocate `size` bytes. Returns a bytevector slice (fresh copy). + ;; NOTE: returns a copy — the arena retains ownership of the backing memory. + ;; size must be a non-negative exact integer. + (define (arena-alloc a size) + (assert-live! 'arena-alloc a) + (unless (and (exact? size) (integer? size) (>= size 0)) + (error 'arena-alloc "size must be a non-negative exact integer" size)) + (let ([pos (%arena-used a)] + [cap (arena-capacity a)]) + (when (> (+ pos size) cap) + (error 'arena-alloc "arena out of space" + `(needed ,size) `(remaining ,(- cap pos)))) + (%arena-used-set! a (+ pos size)) + ;; Return a fresh bytevector slice (view of the allocated region) + (let ([slice (make-bytevector size 0)]) + slice))) + + ;; ========== arena-alloc-string ========== + ;; Copy string bytes into the arena; return the string (interned in arena). + ;; Returns the original string (Chez strings are GC'd; we just track position). + (define (arena-alloc-string a str) + (assert-live! 'arena-alloc-string a) + (unless (string? str) + (error 'arena-alloc-string "expected a string" str)) + (let* ([bv (string->utf8 str)] + [len (bytevector-length bv)] + [pos (%arena-used a)] + [cap (arena-capacity a)]) + (when (> (+ pos len 1) cap) ;; +1 for null terminator + (error 'arena-alloc-string "arena out of space")) + ;; Copy bytes into backing store + (let ([backing (%arena-backing a)]) + (bytevector-copy! bv 0 backing pos len) + (bytevector-u8-set! backing (+ pos len) 0) ;; null terminator + (%arena-used-set! a (+ pos len 1))) + str)) + + ;; ========== arena-alloc-bytes ========== + ;; Copy a bytevector into the arena; return a fresh copy from arena region. + (define (arena-alloc-bytes a bv) + (assert-live! 'arena-alloc-bytes a) + (unless (bytevector? bv) + (error 'arena-alloc-bytes "expected a bytevector" bv)) + (let* ([len (bytevector-length bv)] + [pos (%arena-used a)] + [cap (arena-capacity a)]) + (when (> (+ pos len) cap) + (error 'arena-alloc-bytes "arena out of space")) + (let ([backing (%arena-backing a)]) + (bytevector-copy! bv 0 backing pos len) + (%arena-used-set! a (+ pos len)) + ;; Return a copy of what was stored + (let ([result (make-bytevector len)]) + (bytevector-copy! backing pos result 0 len) + result)))) + + ;; ========== arena-checkpoint ========== + ;; Returns current position (for rollback). + (define (arena-checkpoint a) + (assert-live! 'arena-checkpoint a) + (%arena-used a)) + + ;; ========== arena-rollback! ========== + ;; Restore arena to a previously captured checkpoint. + (define (arena-rollback! a checkpoint) + (assert-live! 'arena-rollback! a) + (unless (and (exact? checkpoint) (integer? checkpoint) + (>= checkpoint 0) + (<= checkpoint (%arena-used a))) + (error 'arena-rollback! "invalid checkpoint" checkpoint)) + (%arena-used-set! a checkpoint)) + + ;; ========== with-arena ========== + ;; Create a temporary arena of given capacity, run body, then destroy it. + ;; Arena is reset even on non-local exit (via dynamic-wind). + (define-syntax with-arena + (syntax-rules () + [(_ size body ...) + (let ([a (make-arena size)]) + (dynamic-wind + (lambda () #f) + (lambda () body ...) + (lambda () (arena-destroy! a))))])) + + ;; ========== arena-stats ========== + ;; Returns an alist of statistics. + (define (arena-stats a) + (list + (cons 'capacity (arena-capacity a)) + (cons 'used (arena-used a)) + (cons 'remaining (arena-remaining a)) + (cons 'destroyed (%arena-destroyed? a)))) + + ;; ========== Arena-backed string interning ========== + + (define-record-type %arena-interner + (fields + (immutable arena) + (immutable table)) ;; string -> string (hashtable) + (protocol + (lambda (new) + (lambda (arena) + (new arena (make-hashtable string-hash string=?)))))) + + (define (make-arena-interner arena) + (unless (arena? arena) + (error 'make-arena-interner "expected an arena" arena)) + (make-%arena-interner arena)) + + ;; Intern a string: if already seen, return existing; else store in arena. + (define (arena-intern! interner str) + (unless (string? str) + (error 'arena-intern! "expected a string" str)) + (let ([tbl (%arena-interner-table interner)]) + (or (hashtable-ref tbl str #f) + (let ([interned (arena-alloc-string (%arena-interner-arena interner) str)]) + (hashtable-set! tbl str interned) + interned)))) + + ;; Look up without interning; returns #f if not found. + (define (arena-intern-lookup interner str) + (hashtable-ref (%arena-interner-table interner) str #f)) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/binary.sls @@ -0,0 +1,397 @@ +#!chezscheme +;;; (std binary) — Structured binary data: packed C-struct-like layouts +;;; +;;; Define packed binary data layouts and read/write them from bytevectors. +;;; Field types: u8 u16 u32 u64 s8 s16 s32 s64 f32 f64 (bytes n) (cstring n) +;;; Byte order: controlled by *byte-order* parameter ('little or 'big). + +(library (std binary) + (export + ;; Struct definition macro + define-binary-struct + binary-struct? + binary-struct-name + binary-struct-size + binary-struct-fields + ;; Reading/writing + binary-read + binary-write! + binary-pack + binary-unpack + ;; Field type tags (for use in define-binary-struct) + u8 u16 u32 u64 + s8 s16 s32 s64 + f32 f64 + ;; Byte order + *byte-order* + with-byte-order + ;; Low-level bytevector accessors + bv-u8-ref bv-u8-set! + bv-u16-ref bv-u16-set! + bv-u32-ref bv-u32-set! + bv-u64-ref bv-u64-set! + bv-s8-ref bv-s8-set! + bv-s16-ref bv-s16-set! + bv-s32-ref bv-s32-set! + bv-s64-ref bv-s64-set! + bv-f32-ref bv-f32-set! + bv-f64-ref bv-f64-set!) + + (import (chezscheme)) + + ;; ========== Byte order parameter ========== + + (define *byte-order* (make-parameter 'little)) + + (define-syntax with-byte-order + (syntax-rules () + [(_ order body ...) + (parameterize ([*byte-order* order]) + body ...)])) + + ;; ========== Field type descriptors ========== + ;; Each field type is a symbol or a tagged list. + + ;; Built-in type tags (exported as values so users can reference them) + (define u8 'u8) + (define u16 'u16) + (define u32 'u32) + (define u64 'u64) + (define s8 's8) + (define s16 's16) + (define s32 's32) + (define s64 's64) + (define f32 'f32) + (define f64 'f64) + + ;; Compute size in bytes for a field type + (define (field-type-size ft) + (cond + [(eq? ft 'u8) 1] + [(eq? ft 'u16) 2] + [(eq? ft 'u32) 4] + [(eq? ft 'u64) 8] + [(eq? ft 's8) 1] + [(eq? ft 's16) 2] + [(eq? ft 's32) 4] + [(eq? ft 's64) 8] + [(eq? ft 'f32) 4] + [(eq? ft 'f64) 8] + [(and (pair? ft) (eq? (car ft) 'bytes)) + (cadr ft)] + [(and (pair? ft) (eq? (car ft) 'cstring)) + (cadr ft)] + [else (error 'field-type-size "unknown field type" ft)])) + + ;; ========== Binary struct registry ========== + ;; Maps struct name (symbol) -> struct-descriptor + + (define *binary-struct-registry* (make-eq-hashtable)) + + (define-record-type %binary-struct-desc + (fields + (immutable name) + (immutable size) + (immutable fields) ;; list of (field-name field-type offset) + (immutable reader) ;; (bv offset) -> record + (immutable writer)) ;; (bv offset record) -> void + (protocol + (lambda (new) + (lambda (name size fields reader writer) + (new name size fields reader writer))))) + + (define (binary-struct? x) (%binary-struct-desc? x)) + (define (binary-struct-name sd) (%binary-struct-desc-name sd)) + (define (binary-struct-size sd) (%binary-struct-desc-size sd)) + (define (binary-struct-fields sd) (%binary-struct-desc-fields sd)) + + ;; Register a struct descriptor under its name + (define (register-binary-struct! name desc) + (hashtable-set! *binary-struct-registry* name desc)) + + ;; Look up by name + (define (lookup-binary-struct name) + (hashtable-ref *binary-struct-registry* name #f)) + + ;; ========== Low-level bytevector accessors ========== + + (define (endian) (*byte-order*)) + + ;; --- u8 / s8 --- + (define (bv-u8-ref bv offset) + (bytevector-u8-ref bv offset)) + (define (bv-u8-set! bv offset val) + (bytevector-u8-set! bv offset val)) + + (define (bv-s8-ref bv offset) + (bytevector-s8-ref bv offset)) + (define (bv-s8-set! bv offset val) + (bytevector-s8-set! bv offset val)) + + ;; --- u16 / s16 --- + (define (bv-u16-ref bv offset) + (bytevector-u16-ref bv offset (endian))) + (define (bv-u16-set! bv offset val) + (bytevector-u16-set! bv offset val (endian))) + + (define (bv-s16-ref bv offset) + (bytevector-s16-ref bv offset (endian))) + (define (bv-s16-set! bv offset val) + (bytevector-s16-set! bv offset val (endian))) + + ;; --- u32 / s32 --- + (define (bv-u32-ref bv offset) + (bytevector-u32-ref bv offset (endian))) + (define (bv-u32-set! bv offset val) + (bytevector-u32-set! bv offset val (endian))) + + (define (bv-s32-ref bv offset) + (bytevector-s32-ref bv offset (endian))) + (define (bv-s32-set! bv offset val) + (bytevector-s32-set! bv offset val (endian))) + + ;; --- u64 / s64 --- + (define (bv-u64-ref bv offset) + (bytevector-u64-ref bv offset (endian))) + (define (bv-u64-set! bv offset val) + (bytevector-u64-set! bv offset val (endian))) + + (define (bv-s64-ref bv offset) + (bytevector-s64-ref bv offset (endian))) + (define (bv-s64-set! bv offset val) + (bytevector-s64-set! bv offset val (endian))) + + ;; --- f32 / f64 --- + (define (bv-f32-ref bv offset) + (bytevector-ieee-single-ref bv offset (endian))) + (define (bv-f32-set! bv offset val) + (bytevector-ieee-single-set! bv offset val (endian))) + + (define (bv-f64-ref bv offset) + (bytevector-ieee-double-ref bv offset (endian))) + (define (bv-f64-set! bv offset val) + (bytevector-ieee-double-set! bv offset val (endian))) + + ;; ========== Low-level field read/write ========== + + (define (read-field bv offset ft) + (cond + [(eq? ft 'u8) (bv-u8-ref bv offset)] + [(eq? ft 'u16) (bv-u16-ref bv offset)] + [(eq? ft 'u32) (bv-u32-ref bv offset)] + [(eq? ft 'u64) (bv-u64-ref bv offset)] + [(eq? ft 's8) (bv-s8-ref bv offset)] + [(eq? ft 's16) (bv-s16-ref bv offset)] + [(eq? ft 's32) (bv-s32-ref bv offset)] + [(eq? ft 's64) (bv-s64-ref bv offset)] + [(eq? ft 'f32) (bv-f32-ref bv offset)] + [(eq? ft 'f64) (bv-f64-ref bv offset)] + [(and (pair? ft) (eq? (car ft) 'bytes)) + (let ([n (cadr ft)]) + (let ([result (make-bytevector n)]) + (bytevector-copy! bv offset result 0 n) + result))] + [(and (pair? ft) (eq? (car ft) 'cstring)) + (let ([max-n (cadr ft)]) + ;; Read until null byte or max-n bytes + (let loop ([i 0] [chars '()]) + (if (or (= i max-n) + (= (bytevector-u8-ref bv (+ offset i)) 0)) + (list->string (reverse chars)) + (loop (+ i 1) + (cons (integer->char (bytevector-u8-ref bv (+ offset i))) + chars)))))] + [else (error 'read-field "unknown field type" ft)])) + + (define (write-field! bv offset ft val) + (cond + [(eq? ft 'u8) (bv-u8-set! bv offset val)] + [(eq? ft 'u16) (bv-u16-set! bv offset val)] + [(eq? ft 'u32) (bv-u32-set! bv offset val)] + [(eq? ft 'u64) (bv-u64-set! bv offset val)] + [(eq? ft 's8) (bv-s8-set! bv offset val)] + [(eq? ft 's16) (bv-s16-set! bv offset val)] + [(eq? ft 's32) (bv-s32-set! bv offset val)] + [(eq? ft 's64) (bv-s64-set! bv offset val)] + [(eq? ft 'f32) (bv-f32-set! bv offset val)] + [(eq? ft 'f64) (bv-f64-set! bv offset val)] + [(and (pair? ft) (eq? (car ft) 'bytes)) + (let ([n (cadr ft)]) + (bytevector-copy! val 0 bv offset (min n (bytevector-length val))))] + [(and (pair? ft) (eq? (car ft) 'cstring)) + (let* ([max-n (cadr ft)] + [s (if (string? val) val (error 'write-field! "expected string for cstring" val))] + [bvs (string->utf8 s)] + [len (min (bytevector-length bvs) (- max-n 1))]) + (bytevector-copy! bvs 0 bv offset len) + ;; null-terminate + (bytevector-u8-set! bv (+ offset len) 0) + ;; zero remaining bytes + (let loop ([i (+ len 1)]) + (when (< i max-n) + (bytevector-u8-set! bv (+ offset i) 0) + (loop (+ i 1)))))] + [else (error 'write-field! "unknown field type" ft)])) + + ;; ========== binary-read / binary-write! ========== + + ;; (binary-read bv offset struct-type) -> record (association list) + (define (binary-read bv offset struct-type) + (let ([desc (cond + [(symbol? struct-type) + (or (lookup-binary-struct struct-type) + (error 'binary-read "unknown struct type" struct-type))] + [(%binary-struct-desc? struct-type) struct-type] + [else (error 'binary-read "expected struct name or descriptor" struct-type)])]) + ((%binary-struct-desc-reader desc) bv offset))) + + ;; (binary-write! bv offset record) + ;; record must be an alist (as returned by binary-read), tagged with struct name + (define (binary-write! bv offset record) + (unless (and (pair? record) (symbol? (car record))) + (error 'binary-write! "expected a tagged record alist" record)) + (let* ([sname (car record)] + [desc (or (lookup-binary-struct sname) + (error 'binary-write! "unknown struct type" sname))]) + ((%binary-struct-desc-writer desc) bv offset record))) + + ;; ========== binary-pack ========== + ;; Pack field values into a fresh bytevector. + ;; (binary-pack struct-type field-val ...) -> bytevector + (define (binary-pack struct-type . field-vals) + (let* ([desc (cond + [(symbol? struct-type) + (or (lookup-binary-struct struct-type) + (error 'binary-pack "unknown struct type" struct-type))] + [(%binary-struct-desc? struct-type) struct-type] + [else (error 'binary-pack "expected struct name or descriptor" struct-type)])] + [size (%binary-struct-desc-size desc)] + [fields (%binary-struct-desc-fields desc)] + [bv (make-bytevector size 0)]) + (let loop ([flds fields] [vals field-vals]) + (when (pair? flds) + (let* ([fld (car flds)] + [fname (car fld)] + [ftype (cadr fld)] + [foff (caddr fld)] + [val (if (pair? vals) (car vals) + (error 'binary-pack "not enough field values"))]) + (write-field! bv foff ftype val) + (loop (cdr flds) (if (pair? vals) (cdr vals) '()))))) + bv)) + + ;; ========== binary-unpack ========== + ;; Read each field from bytevector, return as multiple values. + ;; (binary-unpack struct-type bv [offset]) -> values + (define (binary-unpack struct-type bv . offset-opt) + (let* ([offset (if (pair? offset-opt) (car offset-opt) 0)] + [desc (cond + [(symbol? struct-type) + (or (lookup-binary-struct struct-type) + (error 'binary-unpack "unknown struct type" struct-type))] + [(%binary-struct-desc? struct-type) struct-type] + [else (error 'binary-unpack "expected struct name or descriptor" struct-type)])] + [fields (%binary-struct-desc-fields desc)]) + (apply values + (map (lambda (fld) + (read-field bv (+ offset (caddr fld)) (cadr fld))) + fields)))) + + ;; ========== define-binary-struct macro ========== + ;; + ;; (define-binary-struct Point + ;; (x f32) + ;; (y f32)) + ;; + ;; Generates: + ;; - A descriptor registered in *binary-struct-registry* + ;; - read-Point : (bv offset) -> tagged alist + ;; - write-Point! : (bv offset record) -> void + ;; - pack-Point : (field-vals ...) -> bv + ;; - unpack-Point: (bv [offset]) -> values + + (define-syntax define-binary-struct + (lambda (stx) + (syntax-case stx () + [(_ Name (field-name field-type) ...) + (identifier? #'Name) + (with-syntax + ([read-Name (datum->syntax #'Name + (string->symbol (string-append "read-" + (symbol->string (syntax->datum #'Name)))))] + [write-Name! (datum->syntax #'Name + (string->symbol (string-append "write-" + (symbol->string (syntax->datum #'Name)) "!")))] + [pack-Name (datum->syntax #'Name + (string->symbol (string-append "pack-" + (symbol->string (syntax->datum #'Name)))))] + [unpack-Name (datum->syntax #'Name + (string->symbol (string-append "unpack-" + (symbol->string (syntax->datum #'Name)))))]) + #'(begin + ;; Compute offsets at macro-expansion time via runtime helper + (define %name-sym 'Name) + + (define %fields-info + ;; Build list of (field-name field-type offset) at runtime + (let loop ([fnames '(field-name ...)] + [ftypes '(field-type ...)] + [offset 0] + [acc '()]) + (if (null? fnames) + (reverse acc) + (let* ([ft (car ftypes)] + [sz (field-type-size ft)] + [next (+ offset sz)]) + (loop (cdr fnames) + (cdr ftypes) + next + (cons (list (car fnames) ft offset) acc)))))) + + (define %total-size + (apply + (map field-type-size '(field-type ...)))) + + ;; Reader: returns tagged alist (Name (field-name . val) ...) + (define (read-Name bv offset) + (cons %name-sym + (map (lambda (fld) + (cons (car fld) + (read-field bv (+ offset (caddr fld)) (cadr fld)))) + %fields-info))) + + ;; Writer: takes tagged alist, writes fields + (define (write-Name! bv offset record) + (for-each + (lambda (fld) + (let ([val (cdr (assq (car fld) (cdr record)))]) + (write-field! bv (+ offset (caddr fld)) (cadr fld) val))) + %fields-info)) + + ;; Pack: positional field values -> bytevector + (define (pack-Name . vals) + (let ([bv (make-bytevector %total-size 0)]) + (let loop ([flds %fields-info] [vs vals]) + (when (pair? flds) + (write-field! bv (caddr (car flds)) (cadr (car flds)) (car vs)) + (loop (cdr flds) (cdr vs)))) + bv)) + + ;; Unpack: bytevector [offset] -> multiple values + (define (unpack-Name bv . off-opt) + (let ([base (if (pair? off-opt) (car off-opt) 0)]) + (apply values + (map (lambda (fld) + (read-field bv (+ base (caddr fld)) (cadr fld))) + %fields-info)))) + + ;; Register struct descriptor + (register-binary-struct! + %name-sym + (make-%binary-struct-desc + %name-sym + %total-size + %fields-info + read-Name + (lambda (bv offset record) (write-Name! bv offset record))))))]))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/concur/deadlock.sls @@ -0,0 +1,226 @@ +#!chezscheme +;;; (std concur deadlock) — Runtime deadlock detection via wait-for graph +;;; +;;; Maintains two graphs: +;;; waiting-for : thread → resource (what resource is this thread waiting for) +;;; held-by : resource → thread (which thread holds this resource) +;;; +;;; A deadlock cycle exists when following: +;;; thread A → waits for → resource R1 → held by → thread B +;;; → waits for → resource R2 → held by → thread A +;;; +;;; detect-deadlock performs DFS on the composed graph to find cycles. + +(library (std concur deadlock) + (export + ;; Wait-for graph management + register-waiting! + unregister-waiting! + holding-resource! + releasing-resource! + ;; Detection + detect-deadlock + deadlock? + ;; Conditions + make-deadlock-condition + deadlock-condition? + deadlock-condition-cycle + ;; Instrumented synchronization + deadlock-checked-mutex-lock! + deadlock-checked-mutex-unlock! + deadlock-checked-channel-get + ;; Control + *deadlock-detection-enabled* + with-deadlock-detection + deadlock-detection-report) + + (import (chezscheme)) + + ;; ========== Internal graph state ========== + + ;; Protect graph mutations + (define *graph-mutex* (make-mutex)) + + ;; waiting-for: eq-hashtable thread → resource-id + (define *waiting-for* (make-eq-hashtable)) + + ;; held-by: eq-hashtable resource-id → thread + ;; We use an equal-hash hashtable since resource ids may be any value + (define *held-by* (make-hashtable equal-hash equal?)) + + ;; ========== Thread identity ========== + + ;; get-thread-id returns the current thread's integer id (no-arg form). + (define (self) (get-thread-id)) + + ;; ========== Control parameter ========== + + (define *deadlock-detection-enabled* (make-parameter #t)) + + ;; ========== Wait-for graph API ========== + + (define (register-waiting! thread-id resource-id) + (when (*deadlock-detection-enabled*) + (with-mutex *graph-mutex* + (hashtable-set! *waiting-for* thread-id resource-id)))) + + (define (unregister-waiting! thread-id) + (when (*deadlock-detection-enabled*) + (with-mutex *graph-mutex* + (hashtable-delete! *waiting-for* thread-id)))) + + (define (holding-resource! thread-id resource-id) + (when (*deadlock-detection-enabled*) + (with-mutex *graph-mutex* + (hashtable-set! *held-by* resource-id thread-id)))) + + (define (releasing-resource! thread-id resource-id) + (when (*deadlock-detection-enabled*) + (with-mutex *graph-mutex* + ;; Only remove if we actually hold it + (let ([holder (hashtable-ref *held-by* resource-id #f)]) + (when (eq? holder thread-id) + (hashtable-delete! *held-by* resource-id)))))) + + ;; ========== Cycle detection (DFS) ========== + ;; + ;; Graph for DFS: thread → thread + ;; edge(A → B) exists when: + ;; - A is waiting for resource R (waiting-for[A] = R) + ;; - R is held by B (held-by[R] = B) + ;; + ;; detect-deadlock returns a list of thread-ids forming the cycle, or #f. + + (define (next-thread-for thread) + ;; Given a thread, follow waiting-for and held-by to find who blocks it. + (let ([res (hashtable-ref *waiting-for* thread #f)]) + (and res (hashtable-ref *held-by* res #f)))) + + (define (detect-deadlock) + ;; Snapshot threads that are waiting + (let* ([snapshot + (with-mutex *graph-mutex* + (let-values ([(threads _) (hashtable-entries *waiting-for*)]) + (vector->list threads)))] + [result #f]) + ;; DFS from each waiting thread + (let try-each ([ts snapshot]) + (unless (or result (null? ts)) + (let ([cycle (find-cycle (car ts))]) + (if cycle + (set! result cycle) + (try-each (cdr ts)))))) + result)) + + (define (find-cycle start) + ;; Follow the next-thread chain starting from start. + ;; If we reach start again, we have a cycle. + ;; Returns the cycle as a list of thread-ids, or #f. + (let loop ([current start] [path (list start)] [visited (list start)]) + (let ([next (with-mutex *graph-mutex* (next-thread-for current))]) + (cond + [(not next) #f] + [(eq? next start) + ;; Full cycle back to start + (reverse (cons next path))] + [(memq next visited) + ;; Cycle not through start — still a deadlock + (let ([cycle-start (memq next (reverse path))]) + (if cycle-start + (reverse cycle-start) + (list next)))] + [else + (loop next (cons next path) (cons next visited))])))) + + (define (deadlock?) + (and (detect-deadlock) #t)) + + ;; ========== Deadlock condition type ========== + + (define-condition-type &deadlock &serious + make-deadlock-condition deadlock-condition? + (cycle deadlock-condition-cycle)) + + ;; ========== Instrumented mutex lock/unlock ========== + ;; + ;; These wrap Chez's built-in mutex-acquire/mutex-release with wait-for + ;; graph updates and optional deadlock checking. + + (define (deadlock-checked-mutex-lock! m) + (let ([tid (self)]) + ;; Register that we're waiting for this mutex + (register-waiting! tid m) + ;; Check for deadlock BEFORE blocking + (when (*deadlock-detection-enabled*) + (let ([cycle (detect-deadlock)]) + (when cycle + (unregister-waiting! tid) + (raise + (condition + (make-message-condition "deadlock detected") + (make-deadlock-condition cycle)))))) + ;; Actually acquire the mutex + (mutex-acquire m) + ;; We're no longer waiting; we now hold it + (unregister-waiting! tid) + (holding-resource! tid m))) + + (define (deadlock-checked-mutex-unlock! m) + (let ([tid (self)]) + (releasing-resource! tid m) + (mutex-release m))) + + ;; ========== Instrumented channel get ========== + ;; + ;; For channel-based concurrency, register a symbolic resource id. + ;; We represent the channel itself as the resource. + + (define (deadlock-checked-channel-get ch) + (let ([tid (self)]) + (register-waiting! tid ch) + (let ([cycle (and (*deadlock-detection-enabled*) (detect-deadlock))]) + (when cycle + (unregister-waiting! tid) + (raise + (condition + (make-message-condition "deadlock detected on channel wait") + (make-deadlock-condition cycle))))) + ;; Actual receive — for a bare channel object we just note the wait + ;; and the caller handles the actual blocking. Return unblocked + ;; notification so callers can use this as a guard. + (unregister-waiting! tid) + 'ok)) + + ;; ========== with-deadlock-detection ========== + + (define-syntax with-deadlock-detection + (syntax-rules () + [(_ body ...) + (parameterize ([*deadlock-detection-enabled* #t]) + body ...)])) + + ;; ========== Human-readable graph dump ========== + + (define (deadlock-detection-report) + (with-mutex *graph-mutex* + (let-values ([(wthreads wresources) (hashtable-entries *waiting-for*)] + [(hresources hthreads) (hashtable-entries *held-by*)]) + (with-output-to-string + (lambda () + (display "=== Deadlock Detection Graph ===\n") + (display "Waiting-for (thread → resource):\n") + (vector-for-each + (lambda (t r) + (printf " ~s → ~s\n" t r)) + wthreads wresources) + (display "Held-by (resource → thread):\n") + (vector-for-each + (lambda (r t) + (printf " ~s held by ~s\n" r t)) + hresources hthreads) + (let ([cycle (detect-deadlock)]) + (if cycle + (printf "DEADLOCK DETECTED: ~s\n" cycle) + (display "No deadlock detected.\n")))))))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/concur/util.sls @@ -0,0 +1,382 @@ +#!chezscheme +;;; (std concur util) — Extended concurrency utilities +;;; +;;; Complements the existing scheduler and actor system with: +;;; - Barriers (cyclic, reusable) +;;; - Semaphores +;;; - Read-write locks +;;; - Simple thread pools +;;; - Futures / promises +;;; - Count-down latches + +(library (std concur util) + (export + ;; Barriers + make-barrier + barrier? + barrier-wait! + barrier-reset! + ;; Semaphores + make-semaphore + semaphore? + semaphore-acquire! + semaphore-release! + semaphore-count + semaphore-try-acquire! + ;; Read-write locks + make-rwlock + rwlock? + rwlock-read-lock! + rwlock-read-unlock! + rwlock-write-lock! + rwlock-write-unlock! + with-read-lock + with-write-lock + ;; Thread pools + make-thread-pool + thread-pool? + thread-pool-submit! + thread-pool-stop! + thread-pool-worker-count + ;; Futures + make-future + future? + future-force + future-ready? + future-map + spawn-future + ;; Latches + make-latch + latch-count-down! + latch-await) + + (import (chezscheme)) + + ;; ========== Barrier ========== + ;; + ;; A cyclic barrier for N threads. All threads block at barrier-wait! + ;; until the Nth thread arrives, at which point all are released. + ;; A "generation" counter lets the barrier be reset and reused. + + (define-record-type %barrier + (fields + (immutable total) ;; N threads needed to trip + (immutable mutex) + (immutable condition) + (mutable count) ;; how many have arrived so far + (mutable generation) ;; increments each time barrier trips + (mutable broken?)) ;; if reset mid-wait + (protocol + (lambda (new) + (lambda (n) + (unless (and (fixnum? n) (fx> n 0)) + (error 'make-barrier "count must be a positive fixnum" n)) + (new n (make-mutex) (make-condition) 0 0 #f)))) + (sealed #t)) + + (define make-barrier make-%barrier) + (define (barrier? x) (%barrier? x)) + + (define (barrier-wait! b) + (with-mutex (%barrier-mutex b) + (let ([gen (%barrier-generation b)]) + (%barrier-count-set! b (fx+ (%barrier-count b) 1)) + (cond + [(fx= (%barrier-count b) (%barrier-total b)) + ;; We are the last thread — trip the barrier + (%barrier-count-set! b 0) + (%barrier-generation-set! b (fx+ gen 1)) + (condition-broadcast (%barrier-condition b))] + [else + ;; Wait until our generation advances + (let loop () + (when (and (fx= (%barrier-generation b) gen) + (not (%barrier-broken? b))) + (condition-wait (%barrier-condition b) (%barrier-mutex b)) + (loop)))])))) + + (define (barrier-reset! b) + (with-mutex (%barrier-mutex b) + (%barrier-count-set! b 0) + (%barrier-generation-set! b (fx+ (%barrier-generation b) 1)) + (%barrier-broken?-set! b #f) + (condition-broadcast (%barrier-condition b)))) + + ;; ========== Semaphore ========== + ;; + ;; Classic counting semaphore. + + (define-record-type %semaphore + (fields + (immutable mutex) + (immutable condition) + (mutable count)) + (protocol + (lambda (new) + (lambda (initial) + (unless (and (integer? initial) (>= initial 0)) + (error 'make-semaphore "initial count must be a non-negative integer" initial)) + (new (make-mutex) (make-condition) initial)))) + (sealed #t)) + + (define make-semaphore make-%semaphore) + (define (semaphore? x) (%semaphore? x)) + + (define (semaphore-count s) + (with-mutex (%semaphore-mutex s) + (%semaphore-count s))) + + (define (semaphore-acquire! s) + (with-mutex (%semaphore-mutex s) + (let loop () + (if (> (%semaphore-count s) 0) + (%semaphore-count-set! s (- (%semaphore-count s) 1)) + (begin + (condition-wait (%semaphore-condition s) (%semaphore-mutex s)) + (loop)))))) + + (define (semaphore-try-acquire! s) + (with-mutex (%semaphore-mutex s) + (if (> (%semaphore-count s) 0) + (begin + (%semaphore-count-set! s (- (%semaphore-count s) 1)) + #t) + #f))) + + (define (semaphore-release! s) + (with-mutex (%semaphore-mutex s)