Steps 36-40, 45-47 complete: capability model, lazy sequences, tables, concurrency safety
ober
647c0e743c1203b8f6b20f5a695e01c56f1ea50e
--- a/Makefile +++ b/Makefile @@ -92,6 +92,10 @@ test-features: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-staging.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-cluster.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-devex.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-capability.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-seq.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-table.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-concur.ss test-all: test test-features test-wrappers new file mode 100644 --- /dev/null +++ b/lib/std/capability.sls @@ -0,0 +1,311 @@ +#!chezscheme +;;; (std capability) — Object-Capability Model (Steps 36-37) +;;; +;;; Unforgeable capability tokens that control access to dangerous operations. +;;; Capabilities can be attenuated (restricted) but never amplified. +;;; Sandboxed evaluation with resource limits. + +(library (std capability) + (export + ;; Root capability + make-root-capability + root-capability? + + ;; Capability types + make-fs-capability + fs-capability? + fs-cap-readable? + fs-cap-writable? + fs-cap-paths + + make-net-capability + net-capability? + net-cap-allowed-hosts + net-cap-deny-others? + + make-eval-capability + eval-capability? + eval-cap-allowed-modules + + ;; Attenuation + attenuate-fs + attenuate-net + attenuate-eval + + ;; Capability-guarded operations + cap-file-open + cap-file-read + cap-file-write + cap-connect + + ;; Sandbox + with-sandbox + sandbox-error? + sandbox-error-reason + + ;; Capability checks + capability? + capability-type + capability-valid?) + + (import (chezscheme)) + + ;; ========== Capability Records ========== + + ;; Each capability is an opaque token with a unique nonce. + ;; The nonce prevents forgery (can't construct a capability from parts). + + (define *nonce-counter* 0) + (define *nonce-mutex* (make-mutex)) + + (define (make-nonce) + (with-mutex *nonce-mutex* + (set! *nonce-counter* (+ *nonce-counter* 1)) + *nonce-counter*)) + + ;; capability: #(tag nonce type data) + (define (make-cap type data) + (vector 'capability (make-nonce) type data)) + + (define (capability? x) + (and (vector? x) + (= (vector-length x) 4) + (eq? (vector-ref x 0) 'capability))) + + (define (cap-nonce c) (vector-ref c 1)) + (define (capability-type c) (vector-ref c 2)) + (define (cap-data c) (vector-ref c 3)) + + (define (capability-valid? c) + (and (capability? c) + (let ([v (hashtable-ref *revoked* (cap-nonce c) #f)]) + (not v)))) + + (define *revoked* (make-hashtable equal-hash equal?)) + + (define (kwarg key opts . default-args) + ;; Look up keyword in flat list: (key1 val1 key2 val2 ...) + (let ([default (if (null? default-args) #f (car default-args))]) + (let loop ([lst opts]) + (cond [(or (null? lst) (null? (cdr lst))) default] + [(eq? (car lst) key) (cadr lst)] + [else (loop (cddr lst))])))) + + (define (revoke-capability! c) + (when (capability? c) + (hashtable-set! *revoked* (cap-nonce c) #t))) + + ;; ========== Root Capability ========== + + (define (make-root-capability) + (make-cap 'root #t)) + + (define (root-capability? c) + (and (capability? c) (eq? (capability-type c) 'root))) + + ;; ========== FS Capability ========== + + ;; data: (read? write? paths) + (define (make-fs-capability read? write? paths) + (make-cap 'fs (list read? write? paths))) + + (define (fs-capability? c) + (and (capability? c) (eq? (capability-type c) 'fs))) + + (define (fs-cap-readable? c) + (and (fs-capability? c) (car (cap-data c)))) + + (define (fs-cap-writable? c) + (and (fs-capability? c) (cadr (cap-data c)))) + + (define (fs-cap-paths c) + (and (fs-capability? c) (caddr (cap-data c)))) + + (define (attenuate-fs cap . opts) + ;; Restrict an existing fs capability further. + ;; opts: read-only: #t, paths: '(...) + (unless (or (root-capability? cap) (fs-capability? cap)) + (error 'attenuate-fs "requires fs or root capability" cap)) + (unless (capability-valid? cap) + (error 'attenuate-fs "capability has been revoked")) + (let* ([read-only (kwarg 'read-only: opts)] + [paths (let loop ([l opts] [acc '()]) + ;; collect all values after paths: until next keyword + (cond [(null? l) (if (null? acc) #f (reverse acc))] + [(eq? (car l) 'paths:) + (if (and (pair? (cdr l)) (list? (cadr l))) + (cadr l) + #f)] + [else (loop (cdr l) acc)]))] + ;; Parent constraints + [par-read (if (root-capability? cap) #t (fs-cap-readable? cap))] + [par-write (if (root-capability? cap) #t (fs-cap-writable? cap))] + [par-paths (if (root-capability? cap) #f (fs-cap-paths cap))] + ;; New capability is at most as permissive as parent + [new-write (if read-only #f par-write)] + [new-paths (or paths par-paths)]) + (make-fs-capability par-read new-write new-paths))) + + ;; ========== Net Capability ========== + + ;; data: (allowed-hosts deny-others?) + (define (make-net-capability allowed-hosts deny-others?) + (make-cap 'net (list allowed-hosts deny-others?))) + + (define (net-capability? c) + (and (capability? c) (eq? (capability-type c) 'net))) + + (define (net-cap-allowed-hosts c) + (and (net-capability? c) (car (cap-data c)))) + + (define (net-cap-deny-others? c) + (and (net-capability? c) (cadr (cap-data c)))) + + (define (attenuate-net cap . opts) + (unless (or (root-capability? cap) (net-capability? cap)) + (error 'attenuate-net "requires net or root capability" cap)) + (unless (capability-valid? cap) + (error 'attenuate-net "capability has been revoked")) + (let* ([allow (kwarg 'allow: opts)] + [deny (kwarg 'deny-all-others: opts)] + [par-hosts (if (root-capability? cap) '() (net-cap-allowed-hosts cap))] + ;; Attenuation: can only further restrict, not expand + [new-hosts (or allow par-hosts)] + [new-deny (or deny (and (net-capability? cap) (net-cap-deny-others? cap)))]) + (make-net-capability new-hosts new-deny))) + + ;; ========== Eval Capability ========== + + ;; data: (allowed-modules) + (define (make-eval-capability allowed-modules) + (make-cap 'eval (list allowed-modules))) + + (define (eval-capability? c) + (and (capability? c) (eq? (capability-type c) 'eval))) + + (define (eval-cap-allowed-modules c) + (and (eval-capability? c) (car (cap-data c)))) + + (define (attenuate-eval cap . opts) + (unless (or (root-capability? cap) (eval-capability? cap)) + (error 'attenuate-eval "requires eval or root capability" cap)) + (unless (capability-valid? cap) + (error 'attenuate-eval "capability has been revoked")) + (let* ([modules (kwarg 'modules: opts)] + [par-mods (if (root-capability? cap) #f (eval-cap-allowed-modules cap))] + [new-mods (or modules par-mods)]) + (make-eval-capability new-mods))) + + ;; ========== Capability-Guarded Operations ========== + + (define (path-allowed? path allowed-paths) + ;; Check if path is under one of the allowed paths. + (if (not allowed-paths) + #t ;; no restriction + (let loop ([ps allowed-paths]) + (if (null? ps) + #f + (let ([prefix (car ps)]) + (if (and (<= (string-length prefix) (string-length path)) + (string=? prefix (substring path 0 (string-length prefix)))) + #t + (loop (cdr ps)))))))) + + (define (cap-file-open cap path mode) + ;; Open a file with capability check. + ;; mode: 'r | 'w | 'rw + (unless (and (capability? cap) (capability-valid? cap)) + (error 'cap-file-open "invalid or revoked capability")) + (unless (fs-capability? cap) + (error 'cap-file-open "requires fs capability" cap)) + (let ([need-write (or (eq? mode 'w) (eq? mode 'rw))]) + (when (and need-write (not (fs-cap-writable? cap))) + (error 'cap-file-open "capability does not allow write access" path)) + (unless (path-allowed? path (fs-cap-paths cap)) + (error 'cap-file-open "path not allowed by capability" path)) + (case mode + [(r) (open-input-file path)] + [(w) (open-output-file path 'truncate)] + [(rw) (open-file-input/output-port path)] + [else (error 'cap-file-open "invalid mode" mode)]))) + + (define (cap-file-read cap path) + ;; Read entire file contents as string. + (let ([port (cap-file-open cap path 'r)]) + (let loop ([result '()] [c (read-char port)]) + (if (eof-object? c) + (begin (close-port port) (list->string (reverse result))) + (loop (cons c result) (read-char port)))))) + + (define (cap-file-write cap path content) + ;; Write string to file. + (let ([port (cap-file-open cap path 'w)]) + (display content port) + (close-port port))) + + (define (cap-connect cap host port) + ;; Check network capability before allowing connection. + (unless (and (capability? cap) (capability-valid? cap)) + (error 'cap-connect "invalid or revoked capability")) + (unless (net-capability? cap) + (error 'cap-connect "requires net capability" cap)) + (let ([allowed (net-cap-allowed-hosts cap)] + [deny (net-cap-deny-others? cap)]) + (when (and deny (not (member host allowed))) + (error 'cap-connect "host not allowed by capability" host)) + ;; Return the (host port) pair as a "connection spec" + ;; (actual TCP connection would go here) + (list host port))) + + ;; ========== Sandbox ========== + + ;; sandbox-error: condition type + (define-condition-type &sandbox-error &error + make-sandbox-error sandbox-error? + (reason sandbox-error-reason)) + + (define (with-sandbox thunk . opts) + ;; Execute thunk in a restricted environment. + ;; opts: timeout-ms: N, memory-bytes: N, capabilities: (list ...) + (let* ([timeout-ms (kwarg 'timeout-ms: opts)] + [memory-bytes (kwarg 'memory-bytes: opts)] + [capabilities (kwarg 'capabilities: opts '())] + [result #f] + [error #f]) + ;; Run in a separate thread so we can enforce timeout + (let* ([done-mutex (make-mutex)] + [done-cond (make-condition)] + [done? #f] + [worker + (lambda () + (guard (exn [#t (set! error exn)]) + (set! result (thunk))) + (with-mutex done-mutex + (set! done? #t) + (condition-broadcast done-cond)))] + [t (fork-thread worker)]) + ;; Wait with optional timeout + (with-mutex done-mutex + (if timeout-ms + (let ([deadline (make-time 'time-duration + (* timeout-ms 1000000) 0)]) + (let loop ([waited #f]) + (unless done? + (if waited + (begin + ;; Timeout: we can't kill Chez threads, but record timeout + (set! error + (condition (make-sandbox-error 'timeout) + (make-message-condition "sandbox timeout")))) + (let ([timed-out + (not (condition-wait done-cond done-mutex deadline))]) + (loop timed-out)))))) + (let loop () + (unless done? + (condition-wait done-cond done-mutex) + (loop))))) + (if error + (raise error) + result)))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/concur.sls @@ -0,0 +1,289 @@ +#!chezscheme +;;; (std concur) — Concurrency Safety Toolkit (Steps 45-47) +;;; +;;; Step 45: Thread-safety annotations for data structures. +;;; Step 46: Runtime deadlock detection via lock-order tracking. +;;; Step 47: Resource leak detection for open handles. + +(library (std concur) + (export + ;; Step 45: Thread-safety annotations + defstruct/immutable + defstruct/thread-local + defstruct/thread-safe + thread-safety-of + immutable? + thread-local-marker? + + ;; Step 46: Deadlock detection + make-tracked-mutex + tracked-mutex? + tracked-lock! + tracked-unlock! + with-tracked-mutex + deadlock-check! + lock-order-violations + reset-lock-tracking! + + ;; Step 47: Resource leak detection + register-resource! + close-resource! + task-resources + check-resource-leaks! + with-resource-tracking + open-resource-count) + + (import (chezscheme)) + + ;; ========== Annotation Store ========== + + ;; Global table mapping struct instances to their safety annotation. + (define *safety-annotations* (make-eq-hashtable)) + + (define (annotate-safety! obj tag) + (hashtable-set! *safety-annotations* obj tag)) + + (define (thread-safety-of obj) + (hashtable-ref *safety-annotations* obj 'unannotated)) + + (define (immutable? obj) + (eq? (thread-safety-of obj) 'immutable)) + + (define (thread-local-marker? obj) + (eq? (thread-safety-of obj) 'thread-local)) + + ;; ========== Step 45: Thread-Safety Annotation Macros ========== + + ;; Helper: generate a symbol by prepending a prefix to a symbol. + (define (sym-prefix prefix sym) + (string->symbol (string-append prefix (symbol->string sym)))) + + ;; We define the record type with a private constructor name, + ;; then export a wrapper constructor that annotates the instance. + + (define-syntax defstruct/immutable + (lambda (stx) + (syntax-case stx () + ((_ sname (field ...)) + (let* ((sn (syntax->datum #'sname)) + (make-n (datum->syntax #'sname (string->symbol (string-append "make-" (symbol->string sn))))) + (pred-n (datum->syntax #'sname (string->symbol (string-append (symbol->string sn) "?")))) + (raw-n (datum->syntax #'sname (string->symbol (string-append "%imraw-" (symbol->string sn))))) + (rawp-n (datum->syntax #'sname (string->symbol (string-append "%imrawp-" (symbol->string sn)))))) + #`(begin + (define-record-type (sname #,raw-n #,rawp-n) + (fields (immutable field) ...)) + (define (#,make-n . args) + (let ((inst (apply #,raw-n args))) + (annotate-safety! inst 'immutable) + inst)) + (define #,pred-n #,rawp-n))))))) + + (define-syntax defstruct/thread-local + (lambda (stx) + (syntax-case stx () + ((_ sname (field ...)) + (let* ((sn (syntax->datum #'sname)) + (make-n (datum->syntax #'sname (string->symbol (string-append "make-" (symbol->string sn))))) + (pred-n (datum->syntax #'sname (string->symbol (string-append (symbol->string sn) "?")))) + (raw-n (datum->syntax #'sname (string->symbol (string-append "%tlraw-" (symbol->string sn))))) + (rawp-n (datum->syntax #'sname (string->symbol (string-append "%tlrawp-" (symbol->string sn)))))) + #`(begin + (define-record-type (sname #,raw-n #,rawp-n) + (fields (mutable field) ...)) + (define (#,make-n . args) + (let ((inst (apply #,raw-n args))) + (annotate-safety! inst 'thread-local) + inst)) + (define #,pred-n #,rawp-n))))))) + + (define-syntax defstruct/thread-safe + (lambda (stx) + (syntax-case stx () + ((_ sname (field ...)) + (let* ((sn (syntax->datum #'sname)) + (make-n (datum->syntax #'sname (string->symbol (string-append "make-" (symbol->string sn))))) + (pred-n (datum->syntax #'sname (string->symbol (string-append (symbol->string sn) "?")))) + (raw-n (datum->syntax #'sname (string->symbol (string-append "%tsraw-" (symbol->string sn))))) + (rawp-n (datum->syntax #'sname (string->symbol (string-append "%tsrawp-" (symbol->string sn)))))) + #`(begin + (define-record-type (sname #,raw-n #,rawp-n) + (fields (mutable field) ...)) + (define (#,make-n . args) + (let ((inst (apply #,raw-n args))) + (annotate-safety! inst 'thread-safe) + inst)) + (define #,pred-n #,rawp-n))))))) + + ;; ========== Step 46: Deadlock Detection ========== + + ;; Track mutex acquisition order per thread. + ;; Maintain a directed graph: if T holds A then acquires B → edge A→B. + ;; A cycle indicates a potential deadlock. + + (define *lock-graph* (make-hashtable equal-hash equal?)) + (define *thread-holds* (make-eq-hashtable)) + (define *lock-mutex* (make-mutex)) + (define *mutex-id-seq* 0) + (define *violations* '()) + + (define (make-tracked-mutex . name-args) + (set! *mutex-id-seq* (+ *mutex-id-seq* 1)) + (let* ([name (if (null? name-args) *mutex-id-seq* (car name-args))] + [m (make-mutex)]) + (vector 'tracked-mutex *mutex-id-seq* name m))) + + (define (tracked-mutex? x) + (and (vector? x) (= (vector-length x) 4) (eq? (vector-ref x 0) 'tracked-mutex))) + + (define (tmx-id m) (vector-ref m 1)) + (define (tmx-name m) (vector-ref m 2)) + (define (tmx-raw m) (vector-ref m 3)) + + ;; Thread-local ID assignment + (define *thread-id-counter* 0) + (define *thread-id-mutex* (make-mutex)) + (define *thread-id-param* (make-thread-parameter 0)) + + (define (current-thread-id) + (when (= (*thread-id-param*) 0) + (with-mutex *thread-id-mutex* + (set! *thread-id-counter* (+ *thread-id-counter* 1)) + (*thread-id-param* *thread-id-counter*))) + (*thread-id-param*)) + + (define (tracked-lock! m) + (with-mutex *lock-mutex* + (let* ([tid (current-thread-id)] + [held (hashtable-ref *thread-holds* tid '())] + [mid (tmx-id m)]) + ;; Check for potential cycle BEFORE adding edges: + ;; if mid can already reach any held mutex, adding held→mid creates a cycle. + (when (any-path? mid held) + (set! *violations* + (cons (list 'lock-order-violation (tmx-name m) held) + *violations*))) + ;; Add edges from each held mutex to this one (after cycle check) + (for-each + (lambda (held-id) + (let ([edges (hashtable-ref *lock-graph* held-id '())]) + (unless (member mid edges) + (hashtable-set! *lock-graph* held-id (cons mid edges))))) + held) + (hashtable-set! *thread-holds* tid (cons mid held)))) + (mutex-acquire (tmx-raw m))) + + (define (any-path? start targets) + ;; BFS: is any element of targets reachable FROM start via lock-graph? + ;; Detects if adding edges held→mid would create a cycle (mid→held path exists). + (let loop ([queue (list start)] [visited '()]) + (if (null? queue) + #f + (let ([node (car queue)]) + (cond + [(member node targets) #t] + [(member node visited) (loop (cdr queue) visited)] + [else + (let ([neighbors (hashtable-ref *lock-graph* node '())]) + (loop (append (cdr queue) neighbors) + (cons node visited)))]))))) + + (define (tracked-unlock! m) + (mutex-release (tmx-raw m)) + (with-mutex *lock-mutex* + (let* ([tid (current-thread-id)] + [held (hashtable-ref *thread-holds* tid '())] + [mid (tmx-id m)]) + (hashtable-set! *thread-holds* tid + (filter (lambda (id) (not (= id mid))) held))))) + + (define-syntax with-tracked-mutex + (syntax-rules () + [(_ m body ...) + (dynamic-wind + (lambda () (tracked-lock! m)) + (lambda () body ...) + (lambda () (tracked-unlock! m)))])) + + (define (deadlock-check!) + ;; Check lock-order graph for cycles using DFS. + ;; Returns list of (node . path) for detected cycles. + (let ([all-nodes (let-values ([(ks _) (hashtable-entries *lock-graph*)]) + (vector->list ks))] + [cycles '()]) + (for-each + (lambda (start) + (let dfs ([node start] [path '()] [visited '()]) + (cond + [(member node path) + (set! cycles (cons (cons node (reverse path)) cycles))] + [(member node visited) (void)] + [else + (for-each + (lambda (next) + (dfs next (cons node path) (cons node visited))) + (hashtable-ref *lock-graph* node '()))]))) + all-nodes) + cycles)) + + (define (lock-order-violations) + *violations*) + + (define (reset-lock-tracking!) + (with-mutex *lock-mutex* + (let-values ([(ks _) (hashtable-entries *lock-graph*)]) + (vector-for-each (lambda (k) (hashtable-delete! *lock-graph* k)) ks)) + (let-values ([(ks _) (hashtable-entries *thread-holds*)]) + (vector-for-each (lambda (k) (hashtable-delete! *thread-holds* k)) ks)) + (set! *violations* '()))) + + ;; ========== Step 47: Resource Leak Detection ========== + + (define *resource-table* (make-eq-hashtable)) + (define *resource-mutex* (make-mutex)) + (define *resource-id-seq* 0) + + (define (register-resource! type . desc-args) + ;; Register a new open resource. Returns a resource-id. + (set! *resource-id-seq* (+ *resource-id-seq* 1)) + (let* ([rid *resource-id-seq*] + [desc (if (null? desc-args) "" (car desc-args))] + [tid (current-thread-id)]) + (with-mutex *resource-mutex* + (let ([task-res (hashtable-ref *resource-table* tid '())]) + (hashtable-set! *resource-table* tid + (cons (list rid type desc) task-res)))) + rid)) + + (define (close-resource! rid) + (let ([tid (current-thread-id)]) + (with-mutex *resource-mutex* + (let ([task-res (hashtable-ref *resource-table* tid '())]) + (hashtable-set! *resource-table* tid + (filter (lambda (r) (not (= (car r) rid))) task-res)))))) + + (define (task-resources) + (let ([tid (current-thread-id)]) + (hashtable-ref *resource-table* tid '()))) + + (define (open-resource-count) + (length (task-resources))) + + (define (check-resource-leaks!) + (with-mutex *resource-mutex* + (let-values ([(tids res-lists) (hashtable-entries *resource-table*)]) + (let ([leaks '()]) + (vector-for-each + (lambda (tid res-list) + (unless (null? res-list) + (set! leaks (cons (cons tid res-list) leaks)))) + tids res-lists) + leaks)))) + + (define (with-resource-tracking thunk) + (let* ([tid (current-thread-id)] + [result (thunk)] + [after (task-resources)]) + (values result after))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/seq.sls @@ -0,0 +1,420 @@ +#!chezscheme +;;; (std seq) — Lazy Sequences and Transducers (Steps 38-39) +;;; +;;; Lazy sequences: produce elements on demand. +;;; Transducers: composable, source-independent transformations. +;;; Parallel collections: par-map, par-filter, par-reduce. + +(library (std seq) + (export + ;; Lazy sequences + lazy-cons + lazy-first + lazy-rest + lazy-nil + lazy-nil? + lazy-seq? + lazy-force + + lazy-map + lazy-filter + lazy-take + lazy-drop + lazy-take-while + lazy-drop-while + lazy-zip + lazy-append + lazy-flatten + lazy-range + lazy-iterate + lazy-repeat + lazy-cycle + lazy->list + list->lazy + lazy-for-each + lazy-fold + lazy-count + lazy-any? + lazy-all? + lazy-nth + + ;; Transducers + map-xf + filter-xf + take-xf + drop-xf + take-while-xf + drop-while-xf + flat-map-xf + dedupe-xf + compose-xf + transduce + into + sequence + + ;; Parallel collections + par-map + par-filter + par-reduce + par-for-each) + + (import (chezscheme)) + + ;; ========== Lazy Sequences ========== + + ;; A lazy sequence is either: + ;; - lazy-nil (empty) + ;; - #(lazy-cons head thunk) where thunk produces the tail + ;; A thunk is either: + ;; - a procedure (unevaluated) + ;; - a cached value (already forced) + + (define *lazy-nil* (vector 'lazy-nil)) + + (define (lazy-nil) *lazy-nil*) + (define (lazy-nil? x) (and (vector? x) (eq? (vector-ref x 0) 'lazy-nil))) + (define (lazy-seq? x) + (or (lazy-nil? x) + (and (vector? x) (= (vector-length x) 3) (eq? (vector-ref x 0) 'lazy-cons)))) + + ;; Create a lazy cons cell. rest-thunk is a zero-arg procedure. + (define-syntax lazy-cons + (syntax-rules () + [(_ head rest) + (let ([forced? #f] + [cache #f]) + (vector 'lazy-cons + head + (lambda () + (unless forced? + (set! cache rest) + (set! forced? #t)) + cache)))])) + + (define (lazy-first lc) + (if (lazy-nil? lc) + (error 'lazy-first "empty lazy sequence") + (vector-ref lc 1))) + + (define (lazy-rest lc) + (if (lazy-nil? lc) + (error 'lazy-rest "empty lazy sequence") + ((vector-ref lc 2)))) + + (define (lazy-force x) + (if (procedure? x) (x) x)) + + ;; ========== Lazy Sequence Operations ========== + + (define (lazy-map f seq) + (if (lazy-nil? seq) + (lazy-nil) + (lazy-cons (f (lazy-first seq)) + (lazy-map f (lazy-rest seq))))) + + (define (lazy-filter pred seq) + (let loop ([s seq]) + (cond + [(lazy-nil? s) (lazy-nil)] + [(pred (lazy-first s)) + (lazy-cons (lazy-first s) (lazy-filter pred (lazy-rest s)))] + [else (loop (lazy-rest s))]))) + + (define (lazy-take n seq) + (if (or (= n 0) (lazy-nil? seq)) + (lazy-nil) + (lazy-cons (lazy-first seq) + (lazy-take (- n 1) (lazy-rest seq))))) + + (define (lazy-drop n seq) + (if (or (= n 0) (lazy-nil? seq)) + seq + (lazy-drop (- n 1) (lazy-rest seq)))) + + (define (lazy-take-while pred seq) + (if (or (lazy-nil? seq) (not (pred (lazy-first seq)))) + (lazy-nil) + (lazy-cons (lazy-first seq) + (lazy-take-while pred (lazy-rest seq))))) + + (define (lazy-drop-while pred seq) + (let loop ([s seq]) + (if (or (lazy-nil? s) (not (pred (lazy-first s)))) + s + (loop (lazy-rest s))))) + + (define (lazy-zip seq1 seq2) + (if (or (lazy-nil? seq1) (lazy-nil? seq2)) + (lazy-nil) + (lazy-cons (list (lazy-first seq1) (lazy-first seq2)) + (lazy-zip (lazy-rest seq1) (lazy-rest seq2))))) + + (define (lazy-append seq1 seq2) + (if (lazy-nil? seq1) + seq2 + (lazy-cons (lazy-first seq1) + (lazy-append (lazy-rest seq1) seq2)))) + + (define (lazy-flatten seq) + (if (lazy-nil? seq) + (lazy-nil) + (let ([head (lazy-first seq)]) + (if (lazy-seq? head) + (lazy-append head (lazy-flatten (lazy-rest seq))) + (lazy-cons head (lazy-flatten (lazy-rest seq))))))) + + (define (lazy-range . args) + ;; (lazy-range end) or (lazy-range start end) or (lazy-range start end step) + (let-values ([(start end step) + (case (length args) + [(1) (values 0 (car args) 1)] + [(2) (values (car args) (cadr args) 1)] + [(3) (values (car args) (cadr args) (caddr args))] + [else (error 'lazy-range "wrong number of args")])]) + (let loop ([i start]) + (if (and (not (eq? end +inf.0)) (>= i end)) + (lazy-nil) + (lazy-cons i (loop (+ i step))))))) + + (define (lazy-iterate f x) + ;; Infinite sequence: x, (f x), (f (f x)), ... + (lazy-cons x (lazy-iterate f (f x)))) + + (define (lazy-repeat x) + ;; Infinite sequence of x + (lazy-cons x (lazy-repeat x))) + + (define (lazy-cycle lst) + ;; Infinite cycling of list elements + (if (null? lst) (lazy-nil) + (let loop ([remaining lst]) + (if (null? remaining) + (loop lst) + (lazy-cons (car remaining) (loop (cdr remaining))))))) + + (define (lazy->list seq) + (let loop ([s seq] [acc '()]) + (if (lazy-nil? s) + (reverse acc) + (loop (lazy-rest s) (cons (lazy-first s) acc))))) + + (define (list->lazy lst) + (if (null? lst) + (lazy-nil) + (lazy-cons (car lst) (list->lazy (cdr lst))))) + + (define (lazy-for-each f seq) + (let loop ([s seq]) + (unless (lazy-nil? s) + (f (lazy-first s)) + (loop (lazy-rest s))))) + + (define (lazy-fold f init seq) + (let loop ([s seq] [acc init]) + (if (lazy-nil? s) + acc + (loop (lazy-rest s) (f acc (lazy-first s)))))) + + (define (lazy-count seq) + (lazy-fold (lambda (acc _) (+ acc 1)) 0 seq)) + + (define (lazy-any? pred seq) + (let loop ([s seq]) + (cond + [(lazy-nil? s) #f] + [(pred (lazy-first s)) #t] + [else (loop (lazy-rest s))]))) + + (define (lazy-all? pred seq) + (let loop ([s seq]) + (cond + [(lazy-nil? s) #t] + [(not (pred (lazy-first s))) #f] + [else (loop (lazy-rest s))]))) + + (define (lazy-nth n seq) + (if (= n 0) + (lazy-first seq) + (lazy-nth (- n 1) (lazy-rest seq)))) + + ;; ========== Transducers ========== + ;; + ;; A transducer is a function: reducer → reducer + ;; A reducer is a function: (acc item) → acc + ;; + ;; Usage: (transduce xf rf init coll) + ;; where rf is the "final" reducer, xf transforms it. + + (define (map-xf f) + (lambda (rf) + (lambda (acc item) + (rf acc (f item))))) + + (define (filter-xf pred) + (lambda (rf) + (lambda (acc item) + (if (pred item) + (rf acc item) + acc)))) + + (define (take-xf n) + (lambda (rf) + (let ([remaining n]) + (lambda (acc item) + (if (<= remaining 0) + acc + (begin + (set! remaining (- remaining 1)) + (rf acc item))))))) + + (define (drop-xf n) + (lambda (rf) + (let ([dropped 0]) + (lambda (acc item) + (if (< dropped n) + (begin (set! dropped (+ dropped 1)) acc) + (rf acc item)))))) + + (define (take-while-xf pred) + (lambda (rf) + (let ([done? #f]) + (lambda (acc item) + (if (or done? (not (pred item))) + (begin (set! done? #t) acc) + (rf acc item)))))) + + (define (drop-while-xf pred) + (lambda (rf) + (let ([dropping? #t]) + (lambda (acc item) + (if (and dropping? (pred item)) + acc + (begin (set! dropping? #f) (rf acc item))))))) + + (define (flat-map-xf f) + (lambda (rf) + (lambda (acc item) + (let ([items (f item)]) + (fold-left rf acc items))))) + + (define (dedupe-xf) + (lambda (rf) + (let ([prev (cons #f #f)]) ;; sentinel + (lambda (acc item) + (if (equal? (cdr prev) item) + acc + (begin + (set-cdr! prev item) + (rf acc item))))))) + + (define (compose-xf . xfs) + ;; Compose transducers left-to-right. + (if (null? xfs) + (lambda (rf) rf) + (let loop ([xfs xfs]) + (if (null? (cdr xfs)) + (car xfs) + (let ([left (car xfs)] + [right (loop (cdr xfs))]) + (lambda (rf) (left (right rf)))))))) + + (define (transduce xf rf init coll) + ;; Apply transducer xf with reducer rf over collection coll. + ;; coll can be a list or lazy sequence. + (let ([xrf (xf rf)]) + (cond + [(list? coll) + (fold-left xrf init coll)] + [(lazy-seq? coll) + (lazy-fold xrf init coll)] + [else + (error 'transduce "unsupported collection type" coll)]))) + + (define (into target xf coll) + ;; Transduce coll into target accumulator using cons. + (reverse (transduce xf (lambda (acc x) (cons x acc)) '() coll))) + + (define (sequence xf coll) + ;; Apply transducer xf and return a list. + (into '() xf coll)) + + ;; ========== Parallel Collections ========== + + (define (par-map f lst . opts) + ;; Map f over lst in parallel using multiple threads. + ;; opts: chunk-size: N (default: compute from list length and cores) + (if (null? lst) + '() + (let* ([chunk-size (let ([v (kwarg 'chunk-size: opts)]) + (if v v (max 1 (quotient (length lst) 4))))] + [chunks (split-chunks lst chunk-size)] + [results (make-vector (length chunks) #f)] + [mutex (make-mutex)] + [pending (length chunks)] + [done-cond (make-condition)]) + (let loop ([chunks chunks] [i 0]) + (unless (null? chunks) + (let ([chunk (car chunks)] + [idx i]) + (fork-thread + (lambda () + (let ([result (map f chunk)]) + (with-mutex mutex + (vector-set! results idx result) + (set! pending (- pending 1)) + (when (= pending 0) + (condition-broadcast done-cond))))))) + (loop (cdr chunks) (+ i 1)))) + (with-mutex mutex + (let wait () + (when (> pending 0) + (condition-wait done-cond mutex) + (wait)))) + (apply append (vector->list results))))) + + (define (par-filter pred lst . opts) + ;; Filter lst in parallel. + (let ([chunk-size (let ([v (kwarg 'chunk-size: opts)]) + (if v v (max 1 (quotient (max 1 (length lst)) 4))))]) + (apply append + (par-map (lambda (chunk) (filter pred chunk)) + (split-chunks lst chunk-size)))))