Add weak pairs, lists, and hash tables (#51)
ober
9f84eef592ee25c52788f5a18b22c59fed506af4
new file mode 100644 --- /dev/null +++ b/lib/std/misc/weak.sls @@ -0,0 +1,116 @@ +#!chezscheme +;;; (std misc weak) — Weak pairs, weak lists, and weak hash tables +;;; +;;; Builds on Chez Scheme's weak-cons, bwp-object?, and weak eq hashtables. +;;; +;;; Weak pairs hold their car weakly — the GC may reclaim it, leaving #!bwp. +;;; Weak lists are chains of weak pairs; compaction removes reclaimed entries. +;;; Weak hash tables hold keys weakly; entries vanish when keys are GC'd. + +(library (std misc weak) + (export + ;; Weak pairs + make-weak-pair weak-pair? weak-car weak-cdr weak-pair-value + ;; Weak lists + list->weak-list weak-list->list weak-list-compact! + ;; Weak hash tables + make-weak-hashtable weak-hashtable-ref weak-hashtable-set! + weak-hashtable-delete! weak-hashtable-keys) + (import (except (chezscheme) weak-pair? make-weak-hashtable)) + + ;;; --- Weak pairs --- + + ;; Create a weak pair: the car is held weakly, the cdr strongly. + (define (make-weak-pair key value) + (weak-cons key value)) + + ;; Predicate: is this a weak pair? + (define (weak-pair? obj) + (#3%weak-pair? obj)) + + ;; Access the car of a weak pair (may be #!bwp if reclaimed). + (define (weak-car wp) + (assert (pair? wp)) + (car wp)) + + ;; Access the cdr of a weak pair. + (define (weak-cdr wp) + (assert (pair? wp)) + (cdr wp)) + + ;; Return the car if still live, or #f if reclaimed. + (define (weak-pair-value wp) + (assert (pair? wp)) + (let ([v (car wp)]) + (if (bwp-object? v) #f v))) + + ;;; --- Weak lists --- + + ;; Convert a list of values into a weak-cons chain. + ;; Each element is the car (held weakly), the cdr links to the next pair. + (define (list->weak-list lst) + (if (null? lst) + '() + (weak-cons (car lst) (list->weak-list (cdr lst))))) + + ;; Collect all live (non-bwp) car values from a weak list. + (define (weak-list->list wl) + (let loop ([wl wl] [acc '()]) + (if (null? wl) + (reverse acc) + (let ([v (car wl)]) + (if (bwp-object? v) + (loop (cdr wl) acc) + (loop (cdr wl) (cons v acc))))))) + + ;; Destructively remove reclaimed entries from a weak list. + ;; Returns the (possibly new) head of the compacted list. + (define (weak-list-compact! wl) + ;; Skip leading dead entries + (let skip-head ([wl wl]) + (cond + [(null? wl) '()] + [(bwp-object? (car wl)) (skip-head (cdr wl))] + [else + ;; wl head is live; walk the rest and splice out dead entries + (let loop ([prev wl] [cur (cdr wl)]) + (cond + [(null? cur) (void)] + [(bwp-object? (car cur)) + (set-cdr! prev (cdr cur)) + (loop prev (cdr cur))] + [else + (loop cur (cdr cur))])) + wl]))) + + ;;; --- Weak hash tables --- + ;;; + ;;; Keys are held weakly (eq-based). When a key is reclaimed by the GC, + ;;; the entry is automatically removed by Chez's runtime. + + (define make-weak-hashtable + (case-lambda + [() (make-weak-eq-hashtable)] + [(size) (make-weak-eq-hashtable size)])) + + (define (weak-hashtable-ref ht key default) + (hashtable-ref ht key default)) + + (define (weak-hashtable-set! ht key value) + (hashtable-set! ht key value)) + + (define (weak-hashtable-delete! ht key) + (hashtable-delete! ht key)) + + ;; Return a list of live keys (filters out any bwp entries). + (define (weak-hashtable-keys ht) + (let ([kvec (hashtable-keys ht)]) + (let loop ([i 0] [acc '()]) + (if (fx>= i (vector-length kvec)) + acc + (let ([k (vector-ref kvec i)]) + (if (bwp-object? k) + (loop (fx+ i 1) acc) + (loop (fx+ i 1) (cons k acc)))))))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-weak.ss @@ -0,0 +1,154 @@ +#!chezscheme +;;; Tests for (std misc weak) — weak pairs, weak lists, weak hash tables + +(import (except (chezscheme) weak-pair? make-weak-hashtable) (std misc weak)) + +(define pass 0) +(define fail 0) + +(define-syntax test + (syntax-rules () + [(_ name expr expected) + (guard (exn + [#t (set! fail (+ fail 1)) + (printf "FAIL ~a: exception ~a~%" name + (if (message-condition? exn) (condition-message exn) exn))]) + (let ([got expr]) + (if (equal? got expected) + (begin (set! pass (+ pass 1)) + (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) + (printf "FAIL ~a: got ~a, expected ~a~%" name got expected)))))])) + +(printf "--- (std misc weak) tests ---~%") + +;;; === Weak pairs === + +(printf "~%Weak pairs:~%") + +(let ([wp (make-weak-pair 'hello 42)]) + (test "make-weak-pair returns pair" (pair? wp) #t) + (test "weak-pair? on weak pair" (weak-pair? wp) #t) + (test "weak-pair? on regular pair" (weak-pair? (cons 'a 'b)) #f) + (test "weak-car" (weak-car wp) 'hello) + (test "weak-cdr" (weak-cdr wp) 42) + (test "weak-pair-value live" (weak-pair-value wp) 'hello)) + +;; weak-pair-value returns #f for reclaimed entries +(let ([wp (make-weak-pair (list 1 2 3) 'data)]) + (test "weak-pair-value before GC" (list? (weak-pair-value wp)) #t) + ;; Drop all references to the key and force GC + (collect (collect-maximum-generation)) + (test "weak-pair-value after GC" (weak-pair-value wp) #f)) + +;;; === Weak lists === + +(printf "~%Weak lists:~%") + +(test "list->weak-list empty" (weak-list->list (list->weak-list '())) '()) + +(let ([wl (list->weak-list '(a b c d))]) + (test "weak-list->list roundtrip" (weak-list->list wl) '(a b c d)) + ;; Symbols are interned so they won't be GC'd; just test structural integrity + (test "weak-list is chain of pairs" (pair? wl) #t) + (test "weak-list second pair" (pair? (cdr wl)) #t)) + +;; Test with GC-reclaimable objects +(let () + (define wl + (let ([a (list 'x)] [b (list 'y)] [c (list 'z)]) + (let ([result (list->weak-list (list a b c))]) + ;; Return only result, dropping a/b/c references + result))) + (test "weak-list before GC" (length (weak-list->list wl)) 3) + (collect (collect-maximum-generation)) + ;; After GC, the freshly-allocated lists should be reclaimed + (let ([live (weak-list->list wl)]) + (test "weak-list after GC filters reclaimed" (<= (length live) 3) #t) + ;; We expect 0 survivors since the lists were only held weakly + (test "weak-list GC reclaimed entries" (length live) 0))) + +;; Test weak-list-compact! +(printf "~%Weak list compaction:~%") + +(let ([wl (list->weak-list '(x y z))]) + (let ([compacted (weak-list-compact! wl)]) + (test "compact! live list unchanged" (weak-list->list compacted) '(x y z)))) + +(test "compact! empty list" (weak-list-compact! '()) '()) + +;; compact! with GC'd entries +(let () + (define wl + (let ([a (list 'obj1)] [b (list 'obj2)]) + (list->weak-list (list a b)))) + (collect (collect-maximum-generation)) + (let ([compacted (weak-list-compact! wl)]) + (test "compact! removes GC'd" (weak-list->list compacted) '()))) + +;;; === Weak hash tables === + +(printf "~%Weak hash tables:~%") + +(let ([ht (make-weak-hashtable)]) + ;; Basic operations with interned symbols (won't be GC'd) + (weak-hashtable-set! ht 'foo 1) + (weak-hashtable-set! ht 'bar 2) + (weak-hashtable-set! ht 'baz 3) + (test "weak-ht ref existing" (weak-hashtable-ref ht 'foo #f) 1) + (test "weak-ht ref missing" (weak-hashtable-ref ht 'qux #f) #f) + (test "weak-ht ref default" (weak-hashtable-ref ht 'qux 'nope) 'nope) + + ;; Keys list + (let ([keys (weak-hashtable-keys ht)]) + (test "weak-ht keys count" (length keys) 3) + (test "weak-ht keys contains foo" (memq 'foo keys) (memq 'foo keys)) + (test "weak-ht keys contains bar" (and (memq 'bar keys) #t) #t)) + + ;; Delete + (weak-hashtable-delete! ht 'bar) + (test "weak-ht delete" (weak-hashtable-ref ht 'bar #f) #f) + (test "weak-ht keys after delete" (length (weak-hashtable-keys ht)) 2) + + ;; Overwrite + (weak-hashtable-set! ht 'foo 999) + (test "weak-ht overwrite" (weak-hashtable-ref ht 'foo #f) 999)) + +;; Test with sized constructor +(let ([ht (make-weak-hashtable 64)]) + (weak-hashtable-set! ht 'a 1) + (test "weak-ht sized constructor" (weak-hashtable-ref ht 'a #f) 1)) + +;; Test GC reclamation of weak hash table keys +(printf "~%Weak hash table GC:~%") + +(let ([ht (make-weak-hashtable)]) + ;; Insert entries with freshly allocated keys (not interned) + (let ([k1 (list 'key1)] [k2 (list 'key2)] [k3 (list 'key3)]) + (weak-hashtable-set! ht k1 'val1) + (weak-hashtable-set! ht k2 'val2) + (weak-hashtable-set! ht k3 'val3) + (test "weak-ht before GC count" (length (weak-hashtable-keys ht)) 3) + (test "weak-ht ref before GC" (weak-hashtable-ref ht k1 #f) 'val1) + ;; Keep a reference to k1, drop k2 and k3 + (collect (collect-maximum-generation)) + (test "weak-ht ref retained key" (weak-hashtable-ref ht k1 #f) 'val1) + ;; k1 is still live because we're inside the let binding + (test "weak-ht retained key in keys" (and (memq k1 (weak-hashtable-keys ht)) #t) #t))) + +;; Test that unreferenced keys get collected +(let ([ht (make-weak-hashtable)]) + (let () + ;; Create and insert keys that will go out of scope + (do ([i 0 (fx+ i 1)]) + ((fx= i 10)) + (weak-hashtable-set! ht (list i) i))) + ;; All keys are now unreferenced + (collect (collect-maximum-generation)) + (let ([remaining (length (weak-hashtable-keys ht))]) + (test "weak-ht keys GC'd" remaining 0))) + +;;; === Summary === + +(printf "~%~a tests, ~a passed, ~a failed~%" (+ pass fail) pass fail) +(when (> fail 0) (exit 1))