Phase 2a complete: Foundations (7 libraries, 111 tests passing)
ober
55e99aaee8a2e5bdd42324cbd8fbca8cd007ed2c
new file mode 100644 --- /dev/null +++ b/lib/std/derive.sls @@ -0,0 +1,298 @@ +#!chezscheme +;;; (std derive) -- Declarative Derive System +;;; +;;; Automatically generate implementations from struct definitions. +;;; Similar to Rust's #[derive(...)] or Haskell's deriving (...). +;;; +;;; Usage: +;;; (import (std derive)) +;;; +;;; ;; Basic usage with defstruct +;;; (defstruct/d point (x y) +;;; #:derive (equal hash print json)) +;;; +;;; ;; Define custom derivations +;;; (define-derivation my-derivation +;;; (lambda (info) ...)) +;;; +;;; Built-in derivations: equal hash print json serializable comparable copy builder + +(library (std derive) + (export + ;; Enhanced defstruct with derive support + defstruct/d + + ;; Derivation registry + define-derivation register-derivation! lookup-derivation + + ;; Struct info record (passed to derivation procedures) + make-struct-info struct-info? + struct-info-name struct-info-fields + struct-info-rtd struct-info-make struct-info-pred + struct-info-accessors struct-info-mutators + + ;; Apply derivations explicitly + derive!) + + (import (except (chezscheme) + make-hash-table hash-table? + iota 1+ 1-) + (jerboa core)) + + ;;; ========== Struct info ========== + ;; Passed to derivation procedures describing the struct being derived. + (define-record-type struct-info + (fields name ; symbol: struct name + fields ; list of symbols: field names + rtd ; record-type-descriptor + make ; constructor procedure + pred ; predicate procedure + accessors ; list of accessor procedures + mutators ; list of mutator procedures + )) + + ;;; ========== Derivation registry ========== + (define *derivations* (make-hash-table)) + + (define (register-derivation! name proc) + (hash-put! *derivations* name proc)) + + (define (lookup-derivation name) + (or (hash-get *derivations* name) + (error 'derive "unknown derivation" name))) + + (define-syntax define-derivation + (syntax-rules () + [(_ name proc) + (register-derivation! 'name proc)])) + + ;; Runtime symbol concatenation helper for derivation procedures + (define (%sym-append . syms) + (string->symbol + (apply string-append (map symbol->string syms)))) + + ;;; ========== Apply derivations ========== + ;; Returns a list of (define ...) forms to splice + (define (apply-derivation name info) + (let ([proc (lookup-derivation name)]) + (proc info))) + + ;;; ========== defstruct/d macro ========== + ;; Like defstruct but with #:derive clause + (define-syntax defstruct/d + (lambda (stx) + ;; Inline helpers to avoid phase-system issues + (define (%sym+ . syms) + (string->symbol (apply string-append (map symbol->string syms)))) + (define (find-derives opts) + (let loop ([opts opts]) + (cond + [(null? opts) '()] + [(and (pair? opts) (eq? (car opts) '#:derive)) (cadr opts)] + [else (loop (cdr opts))]))) + (syntax-case stx () + ;; No #:derive — fall through to regular defstruct + [(_ name (field ...) . opts) + (let* ([name-sym (syntax->datum #'name)] + [fields-sym (syntax->datum #'(field ...))] + [opts-list (syntax->datum #'opts)] + [derive-names (find-derives opts-list)]) + (if (null? derive-names) + #'(defstruct name (field ...)) + (with-syntax + ([ns (datum->syntax #'name (%sym+ name-sym '::t))] + [mid (datum->syntax #'name (%sym+ 'make- name-sym))] + [pid (datum->syntax #'name (%sym+ name-sym '?))] + [(acc ...) (datum->syntax #'name + (map (lambda (f) + (%sym+ name-sym '- f)) + fields-sym))] + [(mut ...) (datum->syntax #'name + (map (lambda (f) + (%sym+ name-sym '- f '-set!)) + fields-sym))] + [(idx ...) (datum->syntax #'name + (iota (length fields-sym)))] + [(dname ...) (datum->syntax #'name derive-names)]) + #'(begin + (define-record-type name + (fields (mutable field) ...)) + (define ns (record-type-descriptor name)) + (define mid + (record-constructor + (make-record-constructor-descriptor ns #f #f))) + (define pid (record-predicate ns)) + (define acc (record-accessor ns idx)) ... + (define mut (record-mutator ns idx)) ... + ;; Register struct type for introspection + (register-struct-type! 'name ns) + ;; Apply derivations at runtime (eval'd immediately) + (derive! (make-struct-info 'name '(field ...) ns mid pid + (list acc ...) (list mut ...)) + '(dname ...))))))]))) + + ;; Apply derivations to a struct info, evaluating generated code + ;; derive! installs derived procedures using define-top-level-value. + ;; Derivation procedures return a list of (name . procedure) pairs. + (define (derive! info names) + (let ([env (interaction-environment)]) + (for-each + (lambda (derive-name) + (let ([pairs (apply-derivation derive-name info)]) + (for-each + (lambda (p) + (define-top-level-value (car p) (cdr p) env)) + pairs))) + names))) + + ;;; ========== Built-in derivations ========== + ;; Each derivation returns a list of (symbol . procedure) pairs. + + ;; --- equal: structural equality --- + (register-derivation! 'equal + (lambda (info) + (let* ([name (struct-info-name info)] + [pred (struct-info-pred info)] + [accs (struct-info-accessors info)] + [eq-name (%sym-append name '=?)]) + (list + (cons eq-name + (lambda (a b) + (and (pred a) (pred b) + (let loop ([as accs]) + (or (null? as) + (and (equal? ((car as) a) ((car as) b)) + (loop (cdr as)))))))))))) + + ;; --- hash: consistent hash code --- + (register-derivation! 'hash + (lambda (info) + (let* ([name (struct-info-name info)] + [accs (struct-info-accessors info)] + [hash-name (%sym-append name '-hash)]) + (list + (cons hash-name + (lambda (x) + (let loop ([as accs] [h 17]) + (if (null? as) + h + (loop (cdr as) + (+ (* h 31) (equal-hash ((car as) x)))))))))))) + + ;; --- print: custom display --- + (register-derivation! 'print + (lambda (info) + (let* ([name (struct-info-name info)] + [fields (struct-info-fields info)] + [accs (struct-info-accessors info)] + [hdr (string-append "#<" (symbol->string name))] + [fstrs (map (lambda (f) (string-append " " (symbol->string f) ": ")) fields)] + [print-name (%sym-append name '-print)]) + (list + (cons print-name + (lambda (x . port-opt) + (let ([port (if (pair? port-opt) (car port-opt) (current-output-port))]) + (display hdr port) + (for-each + (lambda (fs acc) + (display fs port) + (write (acc x) port)) + fstrs accs) + (display ">" port)))))))) + + ;; --- json: JSON serialization --- + (register-derivation! 'json + (lambda (info) + (let* ([name (struct-info-name info)] + [fields (struct-info-fields info)] + [accs (struct-info-accessors info)] + [make (struct-info-make info)] + [fstrs (map symbol->string fields)] + [to-name (%sym-append name '->json)] + [from-name (%sym-append 'json-> name)]) + (list + (cons to-name + (lambda (x) + (map (lambda (fs acc) (cons fs (acc x))) fstrs accs))) + (cons from-name + (lambda (alist) + (apply make + (map (lambda (fs) + (let ([p (assoc fs alist)]) + (if p (cdr p) #f))) + fstrs)))))))) + + ;; --- comparable: lexicographic ordering --- + (register-derivation! 'comparable + (lambda (info) + (let* ([name (struct-info-name info)] + [accs (struct-info-accessors info)] + [cmp-name (%sym-append name '-compare)]) + (list + (cons cmp-name + (lambda (a b) + (let loop ([as accs]) + (if (null? as) + 0 + (let ([va ((car as) a)] + [vb ((car as) b)]) + (cond + [(equal? va vb) (loop (cdr as))] + [(and (number? va) (number? vb)) (if (< va vb) -1 1)] + [(and (string? va) (string? vb)) (if (string<? va vb) -1 1)] + [else 1])))))))))) + + ;; --- copy: shallow copy --- + (register-derivation! 'copy + (lambda (info) + (let* ([name (struct-info-name info)] + [make (struct-info-make info)] + [accs (struct-info-accessors info)] + [copy-name (%sym-append name '-copy)]) + (list + (cons copy-name + (lambda (x) (apply make (map (lambda (acc) (acc x)) accs)))))))) + + ;; --- builder: builder pattern --- + (register-derivation! 'builder + (lambda (info) + (let* ([name (struct-info-name info)] + [fields (struct-info-fields info)] + [make (struct-info-make info)] + [fstrs (map (lambda (f) (string->keyword (symbol->string f))) fields)] + [builder-name (%sym-append 'make- name '-builder)] + [build-name (%sym-append name '-build)]) + (list + (cons builder-name + (lambda init-args + (let ([h (make-hash-table)]) + (let loop ([args init-args]) + (unless (null? args) + (hash-put! h (car args) (cadr args)) + (loop (cddr args)))) + h))) + (cons build-name + (lambda (builder) + (apply make (map (lambda (fs) (hashtable-ref builder fs #f)) fstrs)))))))) + + ;; --- serializable: binary serialization (s-expr format) --- + (register-derivation! 'serializable + (lambda (info) + (let* ([name (struct-info-name info)] + [make (struct-info-make info)] + [accs (struct-info-accessors info)] + [to-name (%sym-append name '->bytes)] + [from-name (%sym-append 'bytes-> name)]) + (list + (cons to-name + (lambda (x) + (let ([s (with-output-to-string + (lambda () + (write (cons name (map (lambda (acc) (acc x)) accs)))))]) + (string->utf8 s)))) + (cons from-name + (lambda (bv) + (let ([data (with-input-from-string (utf8->string bv) read)]) + (apply make (cdr data))))))))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/errors.sls @@ -0,0 +1,248 @@ +#!chezscheme +;;; (std errors) -- Enhanced error messages +;;; +;;; Wraps Chez Scheme's condition system with: +;;; - Source-location-aware error formatting +;;; - "Did you mean?" suggestions via Levenshtein distance +;;; - Rich condition types (type-error, arity-error, unbound-error) +;;; - Structured stack-trace display +;;; +;;; Usage: +;;; (import (std errors)) +;;; (install-error-handler!) ; enhance default error display +;;; (type-error 'string-length "String" 42 "Fixnum") + +(library (std errors) + (export + ;; Rich condition types + type-error? type-error-who type-error-expected type-error-got type-error-got-type + arity-error? arity-error-who arity-error-expected arity-error-got arity-error-definition + unbound-error? unbound-error-name unbound-error-suggestions + + ;; Constructors with nice output + type-error arity-error unbound-error + + ;; Did-you-mean suggestions + levenshtein-distance find-suggestions + + ;; Error formatting + format-error-message format-condition + + ;; REPL integration + install-error-handler! with-enhanced-errors + + ;; Utilities + make-source-location source-location? source-location-file + source-location-line source-location-col) + + (import (chezscheme)) + + ;;; ========== Source location ========== + (define-record-type source-location + (fields file line col)) + + ;;; ========== Rich condition types ========== + + (define-condition-type &type-error &error + make-type-error* type-error? + (who type-error-who) + (expected type-error-expected) + (got type-error-got) + (got-type type-error-got-type)) + + (define-condition-type &arity-error &error + make-arity-error* arity-error? + (who arity-error-who) + (expected arity-error-expected) ; number or list of numbers + (got arity-error-got) + (definition arity-error-definition)) ; source location or #f + + (define-condition-type &unbound-error &error + make-unbound-error* unbound-error? + (name unbound-error-name) + (suggestions unbound-error-suggestions)) ; list of similar names + + ;;; ========== Levenshtein distance ========== + ;; Classic DP implementation. Used for "did you mean?" suggestions. + (define (levenshtein-distance s1 s2) + (let* ([n1 (string-length s1)] + [n2 (string-length s2)] + ;; dp: (n1+1) x (n2+1) matrix, stored as a vector + [dp (make-vector (* (+ n1 1) (+ n2 1)) 0)] + [ref (lambda (i j) (vector-ref dp (+ (* i (+ n2 1)) j)))] + [set! (lambda (i j v) (vector-set! dp (+ (* i (+ n2 1)) j) v))]) + ;; Base cases + (do ([i 0 (+ i 1)]) ((> i n1)) (set! i 0 i)) + (do ([j 0 (+ j 1)]) ((> j n2)) (set! 0 j j)) + ;; Fill + (do ([i 1 (+ i 1)]) ((> i n1)) + (do ([j 1 (+ j 1)]) ((> j n2)) + (let ([cost (if (char=? (string-ref s1 (- i 1)) + (string-ref s2 (- j 1))) + 0 1)]) + (set! i j (min (+ (ref (- i 1) j) 1) + (+ (ref i (- j 1)) 1) + (+ (ref (- i 1) (- j 1)) cost)))))) + (ref n1 n2))) + + ;; Find candidates from a list that are "close" to the query + (define (find-suggestions query candidates . max-dist-opt) + (let ([max-dist (if (pair? max-dist-opt) (car max-dist-opt) 3)]) + (let ([scored + (filter-map + (lambda (c) + (let ([d (levenshtein-distance query (symbol->string c))]) + (and (<= d max-dist) (cons d c)))) + candidates)]) + (map cdr (sort (lambda (a b) (< (car a) (car b))) scored))))) + + (define (filter-map proc lst) + (let loop ([lst lst] [acc '()]) + (if (null? lst) + (reverse acc) + (let ([v (proc (car lst))]) + (loop (cdr lst) (if v (cons v acc) acc)))))) + + ;;; ========== Error constructors ========== + + (define (type-error who expected got got-type) + (raise + (condition + (make-type-error* who expected got got-type) + (make-message-condition + (format-type-error who expected got got-type)) + (make-irritants-condition (list got))))) + + (define (arity-error who expected got . def-opt) + (let ([definition (if (pair? def-opt) (car def-opt) #f)]) + (raise + (condition + (make-arity-error* who expected got definition) + (make-message-condition + (format-arity-error who expected got definition)))))) + + (define (unbound-error name . suggestions) + (let ([suggs (if (pair? suggestions) (car suggestions) '())]) + (raise + (condition + (make-unbound-error* name suggs) + (make-message-condition + (format-unbound-error name suggs)))))) + + ;;; ========== Formatting ========== + + (define (format-type-error who expected got got-type) + (string-append + "type mismatch" + (if who (string-append " in " (symbol->string who)) "") + "\n expected: " (if (string? expected) expected (format "~a" expected)) + "\n got: " (format "~s" got) + " (" (if (string? got-type) got-type (format "~a" got-type)) ")")) + + (define (format-arity-error who expected got definition) + (string-append + (if who (symbol->string who) "procedure") + " called with " + (number->string got) + " argument" (if (= got 1) "" "s") + ", but expects " + (cond + [(number? expected) + (string-append (number->string expected) + (if (= expected 1) " argument" " arguments"))] + [(list? expected) + (string-append (string-join (map number->string expected) " or ") + " arguments")] + [else (format "~a" expected)]) + (if definition + (format "\n defined at ~a:~a" + (source-location-file definition) + (source-location-line definition)) + ""))) + + (define (format-unbound-error name suggestions) + (string-append + "unbound identifier '" + (symbol->string name) + "'" + (if (null? suggestions) + "" + (string-append + "\n did you mean: " + (string-join (map symbol->string suggestions) ", ") + "?")))) + + (define (string-join strs sep) + (if (null? strs) + "" + (let loop ([rest (cdr strs)] [acc (car strs)]) + (if (null? rest) + acc + (loop (cdr rest) (string-append acc sep (car rest))))))) + + ;;; ========== Enhanced condition display ========== + + (define (format-condition exn) + (cond + [(type-error? exn) + (string-append "type error: " + (format-type-error + (type-error-who exn) + (type-error-expected exn) + (type-error-got exn) + (type-error-got-type exn)))] + [(arity-error? exn) + (string-append "arity error: " + (format-arity-error + (arity-error-who exn) + (arity-error-expected exn) + (arity-error-got exn) + (arity-error-definition exn)))] + [(unbound-error? exn) + (string-append "unbound: " + (format-unbound-error + (unbound-error-name exn) + (unbound-error-suggestions exn)))] + [(message-condition? exn) + (condition-message exn)] + [else + (format "~a" exn)])) + + ;; Pretty-print an error to a port with context + (define (format-error-message exn . port-opt) + (let ([port (if (pair? port-opt) (car port-opt) (current-error-port))]) + (display "\nerror: " port) + (display (format-condition exn) port) + (newline port) + ;; Show irritants if any + (when (irritants-condition? exn) + (let ([irritants (condition-irritants exn)]) + (unless (null? irritants) + (display " irritants: " port) + (for-each (lambda (x) (display " " port) (write x port)) irritants) + (newline port)))))) + + ;;; ========== REPL integration ========== + + ;; Store original error handler + (define original-error-handler #f) + + (define (install-error-handler!) + ;; Replace Chez's default error display with our enhanced version + (set! original-error-handler (current-exception-state)) + (current-exception-state + (lambda (exn) + (format-error-message exn (current-error-port))))) + + (define-syntax with-enhanced-errors + (syntax-rules () + [(_ body ...) + (call-with-current-continuation + (lambda (k) + (with-exception-handler + (lambda (exn) + (format-error-message exn (current-error-port)) + (k (void))) + (lambda () body ...))))])) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/os/mmap.sls @@ -0,0 +1,353 @@ +#!chezscheme +;;; (std os mmap) -- Memory-Mapped I/O +;;; +;;; Direct access to file contents as byte-addressable memory without copying. +;;; Wraps POSIX mmap(2)/munmap(2)/msync(2)/madvise(2). +;;; +;;; Usage: +;;; (define mapping (mmap "large-file.dat" #:mode 'read-only)) +;;; (mmap-u64-ref mapping 0 'little) ; read 8 bytes little-endian +;;; (munmap mapping) ; release mapping +;;; +;;; The returned mmap region exposes byte-level access via foreign-ref/foreign-set!. +;;; mmap-bytevector returns a fresh bytevector copy of the mapped data. + +(library (std os mmap) + (export + ;; Mapping creation + mmap munmap msync madvise + + ;; Type predicate + mmap-region? mmap-region-addr mmap-region-size mmap-region-mode + + ;; Byte-level access (O(1), no copying) + 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 + + ;; Copy to/from bytevector + mmap->bytevector mmap-copy-in! + + ;; Constants + PROT_READ PROT_WRITE PROT_EXEC + MAP_SHARED MAP_PRIVATE MAP_ANONYMOUS + MADV_SEQUENTIAL MADV_RANDOM MADV_WILLNEED MADV_DONTNEED + MS_SYNC MS_ASYNC MS_INVALIDATE) + + (import (chezscheme)) + + ;;; ========== POSIX constants ========== + ;; Values for Linux x86-64. Adjust for other platforms. + + (define PROT_READ 1) + (define PROT_WRITE 2) + (define PROT_EXEC 4) + (define PROT_NONE 0) + + (define MAP_SHARED 1) + (define MAP_PRIVATE 2) + (define MAP_ANONYMOUS #x20) + (define MAP_FAILED -1) ; mmap returns (void*)-1 on failure + + (define MADV_SEQUENTIAL 2) + (define MADV_RANDOM 1) + (define MADV_WILLNEED 3) + (define MADV_DONTNEED 4) + + (define MS_ASYNC 1) + (define MS_SYNC 4) + (define MS_INVALIDATE 2) + + ;;; ========== FFI declarations ========== + + ;; mmap(addr, length, prot, flags, fd, offset) -> void* + ;; Returns -1 (as unsigned long) on failure, mapped address otherwise + (define %mmap + (foreign-procedure "mmap" + (void* size_t int int int long) + void*)) + + ;; munmap(addr, length) -> int + (define %munmap + (foreign-procedure "munmap" + (void* size_t) + int)) + + ;; msync(addr, length, flags) -> int + (define %msync + (foreign-procedure "msync" + (void* size_t int) + int)) + + ;; madvise(addr, length, advice) -> int + (define %madvise + (foreign-procedure "madvise" + (void* size_t int) + int)) + + ;; open(path, flags, mode) -> fd + (define %open + (foreign-procedure "open" + (string int int) + int)) + + ;; close(fd) -> int + (define %close + (foreign-procedure "close" + (int) + int)) + + ;; stat: just get file size via lseek + (define %lseek + (foreign-procedure "lseek" + (int long int) + long)) + + (define O_RDONLY 0) + (define O_RDWR 2) + (define O_CREAT #x40) + (define O_TRUNC #x200) + (define SEEK_END 2) + + ;;; ========== mmap region record ========== + (define-record-type mmap-region + (fields addr ; integer: the mapped address + size ; fixnum: mapping size in bytes + mode ; symbol: 'read-only or 'read-write + fd)) ; integer: backing fd (-1 for anon) + + ;;; ========== Map a file ========== + (define (mmap path . opts) + (let* ([mode (get-opt opts '#:mode 'read-only)] + [size-opt (get-opt opts '#:size #f)] + [flags (case mode + [(read-only) (bitwise-ior O_RDONLY)] + [(read-write) (bitwise-ior O_RDWR)] + [else (error 'mmap "unknown mode" mode)])] + [fd (if (string? path) + (%open path flags #o644) + path)]) ; allow passing an fd + (when (< fd 0) + (error 'mmap "cannot open file" path)) + (let ([size (or size-opt + ;; Get file size via lseek + (let ([sz (%lseek fd 0 SEEK_END)]) + (%lseek fd 0 0) ; seek back to start + sz))]) + (when (<= size 0) + (when (string? path) (%close fd)) + (error 'mmap "file is empty or size is zero" path)) + (let* ([prot (case mode + [(read-only) PROT_READ] + [(read-write) (bitwise-ior PROT_READ PROT_WRITE)])] + [mflags MAP_SHARED] + [addr (%mmap 0 size prot mflags fd 0)]) + ;; mmap returns (void*)-1 on failure; as a Chez integer this is large + (when (= addr (- (expt 2 64) 1)) ; MAP_FAILED = (void*)-1 + (when (string? path) (%close fd)) + (error 'mmap "mmap failed" path)) + (let ([region (make-mmap-region addr size mode + (if (string? path) fd -1))]) + ;; Register guardian for GC-based cleanup + (register-mmap-guardian! region) + region))))) + + ;; Anonymous mapping (not backed by a file) + (define (mmap-anon size . opts) + (let* ([mode (get-opt opts '#:mode 'read-write)] + [prot (bitwise-ior PROT_READ PROT_WRITE)] + [mflags (bitwise-ior MAP_PRIVATE MAP_ANONYMOUS)] + [addr (%mmap 0 size prot mflags -1 0)]) + (when (= addr (- (expt 2 64) 1)) + (error 'mmap-anon "anonymous mmap failed" size)) + (let ([region (make-mmap-region addr size mode -1)]) + (register-mmap-guardian! region) + region))) + + ;;; ========== Unmap ========== + (define (munmap region) + (let* ([addr (mmap-region-addr region)] + [size (mmap-region-size region)] + [fd (mmap-region-fd region)] + [rc (%munmap addr size)]) + (when (>= fd 0) + (%close fd)) + (when (< rc 0) + (error 'munmap "munmap failed")))) + + ;;; ========== Sync ========== + (define (msync region . flags-opt) + (let ([flags (if (pair? flags-opt) (car flags-opt) MS_SYNC)]) + (let ([rc (%msync (mmap-region-addr region) + (mmap-region-size region) + flags)]) + (when (< rc 0) + (error 'msync "msync failed"))))) + + ;;; ========== Advise kernel ========== + (define (madvise region advice) + (let ([advice-const + (case advice + [(sequential) MADV_SEQUENTIAL] + [(random) MADV_RANDOM] + [(willneed) MADV_WILLNEED] + [(dontneed) MADV_DONTNEED] + [else (if (fixnum? advice) advice + (error 'madvise "unknown advice" advice))])]) + (%madvise (mmap-region-addr region) + (mmap-region-size region) + advice-const))) + + ;;; ========== Byte-level access ========== + + (define (mmap-check-bounds region offset size who) + (when (or (< offset 0) + (> (+ offset size) (mmap-region-size region))) + (error who "offset out of bounds" offset))) + + (define (mmap-u8-ref region offset) + (mmap-check-bounds region offset 1 'mmap-u8-ref) + (foreign-ref 'unsigned-8 (mmap-region-addr region) offset)) + + (define (mmap-u8-set! region offset val) + (mmap-check-bounds region offset 1 'mmap-u8-set!) + (foreign-set! 'unsigned-8 (mmap-region-addr region) offset val)) + + (define (mmap-s8-ref region offset) + (mmap-check-bounds region offset 1 'mmap-s8-ref) + (foreign-ref 'integer-8 (mmap-region-addr region) offset)) + + (define (mmap-u16-ref region offset endianness) + (mmap-check-bounds region offset 2 'mmap-u16-ref) + (let* ([addr (+ (mmap-region-addr region) offset)] + [b0 (foreign-ref 'unsigned-8 addr 0)] + [b1 (foreign-ref 'unsigned-8 addr 1)]) + (case endianness + [(little) (bitwise-ior b0 (bitwise-arithmetic-shift b1 8))] + [(big) (bitwise-ior (bitwise-arithmetic-shift b0 8) b1)] + [else (error 'mmap-u16-ref "bad endianness" endianness)]))) + + (define (mmap-u16-set! region offset val endianness) + (mmap-check-bounds region offset 2 'mmap-u16-set!) + (let ([addr (+ (mmap-region-addr region) offset)]) + (case endianness + [(little) + (foreign-set! 'unsigned-8 addr 0 (bitwise-and val #xff)) + (foreign-set! 'unsigned-8 addr 1 (bitwise-and (bitwise-arithmetic-shift val -8) #xff))] + [(big) + (foreign-set! 'unsigned-8 addr 0 (bitwise-and (bitwise-arithmetic-shift val -8) #xff)) + (foreign-set! 'unsigned-8 addr 1 (bitwise-and val #xff))]))) + + (define (mmap-s16-ref region offset endianness) + (let ([u (mmap-u16-ref region offset endianness)]) + (if (>= u #x8000) (- u #x10000) u))) + + (define (mmap-u32-ref region offset endianness) + (mmap-check-bounds region offset 4 'mmap-u32-ref) + (let* ([addr (+ (mmap-region-addr region) offset)] + [b0 (foreign-ref 'unsigned-8 addr 0)] + [b1 (foreign-ref 'unsigned-8 addr 1)] + [b2 (foreign-ref 'unsigned-8 addr 2)] + [b3 (foreign-ref 'unsigned-8 addr 3)]) + (case endianness + [(little) + (bitwise-ior b0 + (bitwise-arithmetic-shift b1 8) + (bitwise-arithmetic-shift b2 16) + (bitwise-arithmetic-shift b3 24))] + [(big) + (bitwise-ior (bitwise-arithmetic-shift b0 24) + (bitwise-arithmetic-shift b1 16) + (bitwise-arithmetic-shift b2 8) + b3)]))) + + (define (mmap-u32-set! region offset val endianness) + (mmap-check-bounds region offset 4 'mmap-u32-set!) + (let ([addr (+ (mmap-region-addr region) offset)]) + (case endianness + [(little) + (foreign-set! 'unsigned-8 addr 0 (bitwise-and val #xff)) + (foreign-set! 'unsigned-8 addr 1 (bitwise-and (bitwise-arithmetic-shift val -8) #xff)) + (foreign-set! 'unsigned-8 addr 2 (bitwise-and (bitwise-arithmetic-shift val -16) #xff)) + (foreign-set! 'unsigned-8 addr 3 (bitwise-and (bitwise-arithmetic-shift val -24) #xff))] + [(big) + (foreign-set! 'unsigned-8 addr 0 (bitwise-and (bitwise-arithmetic-shift val -24) #xff)) + (foreign-set! 'unsigned-8 addr 1 (bitwise-and (bitwise-arithmetic-shift val -16) #xff)) + (foreign-set! 'unsigned-8 addr 2 (bitwise-and (bitwise-arithmetic-shift val -8) #xff)) + (foreign-set! 'unsigned-8 addr 3 (bitwise-and val #xff))]))) + + (define (mmap-s32-ref region offset endianness) + (let ([u (mmap-u32-ref region offset endianness)]) + (if (>= u #x80000000) (- u #x100000000) u))) + + (define (mmap-u64-ref region offset endianness) + (mmap-check-bounds region offset 8 'mmap-u64-ref) + (let* ([lo (mmap-u32-ref region offset endianness)] + [hi (mmap-u32-ref region (+ offset 4) endianness)]) + (case endianness + [(little) (bitwise-ior lo (bitwise-arithmetic-shift hi 32))] + [(big) (bitwise-ior (bitwise-arithmetic-shift lo 32) hi)]))) + + (define (mmap-u64-set! region offset val endianness) + (mmap-check-bounds region offset 8 'mmap-u64-set!) + (case endianness + [(little) + (mmap-u32-set! region offset (bitwise-and val #xffffffff) 'little) + (mmap-u32-set! region (+ offset 4) (bitwise-arithmetic-shift val -32) 'little)] + [(big) + (mmap-u32-set! region offset (bitwise-arithmetic-shift val -32) 'big) + (mmap-u32-set! region (+ offset 4) (bitwise-and val #xffffffff) 'big)])) + + (define (mmap-s64-ref region offset endianness) + (let ([u (mmap-u64-ref region offset endianness)]) + (if (>= u (expt 2 63)) (- u (expt 2 64)) u))) + + ;;; ========== Copy to/from bytevector ========== + + (define (mmap->bytevector region . range-opt) + (let* ([start (if (pair? range-opt) (car range-opt) 0)] + [end (if (and (pair? range-opt) (pair? (cdr range-opt))) + (cadr range-opt) + (mmap-region-size region))] + [len (- end start)] + [bv (make-bytevector len)]) + (do ([i 0 (+ i 1)]) + ((= i len) bv) + (bytevector-u8-set! bv i (mmap-u8-ref region (+ start i)))))) + + (define (mmap-copy-in! region bv . offset-opt) + (let ([offset (if (pair? offset-opt) (car offset-opt) 0)] + [len (bytevector-length bv)]) + (do ([i 0 (+ i 1)]) + ((= i len)) + (mmap-u8-set! region (+ offset i) (bytevector-u8-ref bv i))))) + + ;;; ========== GC-based cleanup ========== + (define *mmap-guardian* (make-guardian)) + + (define (register-mmap-guardian! region) + (*mmap-guardian* region)) + + ;; Poll the guardian periodically (call from REPL or background thread) + (define (collect-dead-mmaps!) + (let loop ([region (*mmap-guardian*)]) + (when region + (let* ([addr (mmap-region-addr region)] + [size (mmap-region-size region)] + [fd (mmap-region-fd region)]) + (%munmap addr size) + (when (>= fd 0) (%close fd))) + (loop (*mmap-guardian*))))) + + ;;; ========== Helpers ========== + (define (get-opt opts key default) + (let loop ([opts opts]) + (cond + [(null? opts) default] + [(and (pair? opts) (pair? (cdr opts)) (eq? (car opts) key)) + (cadr opts)] + [else (loop (if (pair? opts) (cdr opts) '()))]))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/pmap.sls @@ -0,0 +1,392 @@ +#!chezscheme +;;; (std pmap) -- Persistent Hash Maps (HAMT) +;;; +;;; Immutable hash maps with structural sharing. +;;; Hash Array Mapped Trie (HAMT) with 32-way branching. +;;; O(log_32 n) ≈ O(1) for ref, set, delete. +;;; +;;; Node types: +;;; #f — empty slot +;;; hamt-leaf — single (key, value) pair +;;; hamt-node — interior node with bitmap and compact array +;;; hamt-coll — collision bucket (multiple keys with same hash) + +(library (std pmap) + (export + ;; Construction + persistent-map make-persistent-map pmap-empty + ;; Type predicate + persistent-map? + ;; Access + persistent-map-ref persistent-map-has? persistent-map-size + ;; Functional update + persistent-map-set persistent-map-delete + ;; Derived operations + persistent-map->list persistent-map-keys persistent-map-values + persistent-map-for-each persistent-map-map persistent-map-fold + persistent-map-filter + ;; Merge / set operations + persistent-map-merge persistent-map-diff) + + (import (chezscheme)) + + ;;; ========== Vector copy helper ========== + ;; Chez Scheme's vector-copy! has non-standard argument order: + ;; (vector-copy! from from-start to to-start count) + ;; We use a simple loop to avoid confusion. + (define (vec-copy! from from-start to to-start count) + (do ([i 0 (+ i 1)]) + ((= i count)) + (vector-set! to (+ to-start i) + (vector-ref from (+ from-start i))))) + + ;;; ========== HAMT constants ========== + (define BITS 5) + (define BRANCHING 32) + (define MASK 31) + + ;;; ========== Node records ========== + + ;; Leaf: a single key-value pair + (define-record-type hamt-leaf + (fields key val)) + + ;; Interior node: sparse array indexed by 5-bit hash chunks + ;; bitmap: 32-bit integer where bit k means slot k is occupied + ;; array: compact vector of occupied children (length = popcount(bitmap)) + (define-record-type hamt-node + (fields bitmap array)) + + ;; Collision bucket: multiple keys with the exact same hash + (define-record-type hamt-coll + (fields hash pairs)) ; pairs = list of (key . val) + + ;;; ========== The map record ========== + (define-record-type %pmap + (fields root size equal-proc hash-proc)) + + (define (persistent-map? x) (%pmap? x)) + (define (persistent-map-size m) (%pmap-size m)) + + ;;; ========== Bit utilities ========== + + ;; Count set bits (Brian Kernighan's method) + (define (popcount x) + (let loop ([x x] [n 0]) + (if (= x 0) n + (loop (bitwise-and x (- x 1)) (+ n 1))))) + + ;; The bit position for hash at a given shift level + (define (hamt-bitpos hash shift) + (bitwise-arithmetic-shift 1 (bitwise-and (bitwise-arithmetic-shift hash (- shift)) MASK))) + + ;; Index into the compact array for a given bit position + (define (hamt-index bitmap bit) + (popcount (bitwise-and bitmap (- bit 1)))) + + ;;; ========== Empty map ========== + (define pmap-empty + (make-%pmap #f 0 equal? equal-hash)) + + ;;; ========== Construction ========== + (define (make-persistent-map . kv-args)