From b677a4e8c90feb56c7cf6fb158e3c4e5be402490 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sat, 3 Jun 2023 17:50:45 +0200 Subject: [PATCH 3/5] Add new user-facing API procedures for weak pairs to (chicken base) This API is compatible with Chez Scheme's API for weak pairs. Eventually, we want to make all the regular pair operators work on weak pairs, so we do not need to add weak-c[ad]r, set-weak-c[ad]r! etc. This means the API is limited to three procedures: - weak-cons to construct weak pairs - weak-pair? to distinguish weak from regular pairs where it matters - bwp-object? to be able to check for broken pointers in weak pairs This commit also adds read/write invariance for #!bwp. This is not strictly necessary - we could decide to make broken weak pair objects unreadable. The advantage of this is that write won't fail randomly just because the objects in the cars have been collected. --- chicken.base.import.scm | 5 ++- chicken.h | 17 +++++++-- core.scm | 2 + distribution/manifest | 1 + eval.scm | 2 + expand.scm | 3 ++ extras.scm | 2 + library.scm | 10 ++++- support.scm | 6 +++ tests/runtests.bat | 5 +++ tests/runtests.sh | 4 ++ tests/weak-pointer-test.scm | 74 +++++++++++++++++++++++++++++++++++++ 12 files changed, 125 insertions(+), 6 deletions(-) create mode 100644 tests/weak-pointer-test.scm diff --git a/chicken.base.import.scm b/chicken.base.import.scm index 09a13ceb..1f64f5ea 100644 --- a/chicken.base.import.scm +++ b/chicken.base.import.scm @@ -32,6 +32,7 @@ (alist-update! . chicken.base#alist-update!) (atom? . chicken.base#atom?) (bignum? . chicken.base#bignum?) + (bwp-object? . chicken.base#bwp-object?) (butlast . chicken.base#butlast) (call/cc . chicken.base#call/cc) (case-sensitive . chicken.base#case-sensitive) @@ -110,5 +111,7 @@ (vector-copy! . chicken.base#vector-copy!) (vector-resize . chicken.base#vector-resize) (void . chicken.base#void) - (warning . chicken.base#warning)) + (warning . chicken.base#warning) + (weak-cons . chicken.base#weak-cons) + (weak-pair? . chicken.base#weak-pair?)) ##sys#chicken.base-macro-environment) diff --git a/chicken.h b/chicken.h index 21e69b18..7f176f5c 100644 --- a/chicken.h +++ b/chicken.h @@ -1129,6 +1129,7 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret; #define C_stringp(x) C_mk_bool(C_header_bits(x) == C_STRING_TYPE) #define C_symbolp(x) C_mk_bool(C_block_header(x) == C_SYMBOL_TAG) #define C_pairp(x) C_mk_bool(C_block_header(x) == C_PAIR_TAG) +#define C_weak_pairp(x) C_mk_bool(C_block_header(x) == C_WEAK_PAIR_TAG) #define C_closurep(x) C_mk_bool(C_header_bits(x) == C_CLOSURE_TYPE) #define C_vectorp(x) C_mk_bool(C_header_bits(x) == C_VECTOR_TYPE) #define C_bytevectorp(x) C_mk_bool(C_header_bits(x) == C_BYTEVECTOR_TYPE) @@ -1139,6 +1140,7 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret; #define C_booleanp(x) C_mk_bool(((x) & C_IMMEDIATE_TYPE_BITS) == C_BOOLEAN_BITS) #define C_eofp(x) C_mk_bool((x) == C_SCHEME_END_OF_FILE) #define C_undefinedp(x) C_mk_bool((x) == C_SCHEME_UNDEFINED) +#define C_bwpp(x) C_mk_bool((x) == C_SCHEME_BROKEN_WEAK_PTR) #define C_fixnump(x) C_mk_bool((x) & C_FIXNUM_BIT) #define C_nfixnump(x) C_mk_nbool((x) & C_FIXNUM_BIT) #define C_pointerp(x) C_mk_bool(C_block_header(x) == C_POINTER_TAG) @@ -1315,11 +1317,14 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret; #ifdef HAVE_STATEMENT_EXPRESSIONS -# define C_a_i(a, n) ({C_word *tmp = *a; *a += (n); tmp;}) -# define C_a_i_cons(a, n, car, cdr) ({C_word tmp = (C_word)(*a); (*a)[0] = C_PAIR_TYPE | 2; *a += C_SIZEOF_PAIR; \ - C_set_block_item(tmp, 0, car); C_set_block_item(tmp, 1, cdr); tmp;}) +# define C_a_i(a, n) ({C_word *tmp = *a; *a += (n); tmp;}) +# define C_a_i_cons(a, n, car, cdr) ({C_word tmp = (C_word)(*a); (*a)[0] = C_PAIR_TAG; *a += C_SIZEOF_PAIR; \ + C_set_block_item(tmp, 0, car); C_set_block_item(tmp, 1, cdr); tmp;}) +# define C_a_i_weak_cons(a, n, car, cdr) ({C_word tmp = (C_word)(*a); (*a)[0] = C_WEAK_PAIR_TAG; *a += C_SIZEOF_PAIR; \ + C_set_block_item(tmp, 0, car); C_set_block_item(tmp, 1, cdr); tmp;}) #else -# define C_a_i_cons(a, n, car, cdr) C_a_pair(a, car, cdr) +# define C_a_i_cons(a, n, car, cdr) C_a_pair(a, car, cdr) +# define C_a_i_weak_cons(a, n, car, cdr) C_a_weak_pair(a, car, cdr) #endif /* HAVE_STATEMENT_EXPRESSIONS */ #define C_a_i_flonum(ptr, c, n) C_flonum(ptr, n) @@ -2714,6 +2719,10 @@ inline static C_word C_i_pairp(C_word x) return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_PAIR_TAG); } +inline static C_word C_i_weak_pairp(C_word x) +{ + return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_WEAK_PAIR_TAG); +} inline static C_word C_i_stringp(C_word x) { diff --git a/core.scm b/core.scm index 46c39a36..c63ef181 100644 --- a/core.scm +++ b/core.scm @@ -3180,6 +3180,8 @@ ((char? x) `(char ,x)) ((null? x) '(nil)) ((eof-object? x) '(eof)) + ;; TODO: Remove once we have a bootstrapping libchicken with bwp-object? + ((##core#inline "C_bwpp" x) #;(bwp-object? x) '(bwp)) (else (bomb "bad immediate (prepare)")) ) '() ) ) ) diff --git a/distribution/manifest b/distribution/manifest index 5f20b3e7..be85064c 100644 --- a/distribution/manifest +++ b/distribution/manifest @@ -131,6 +131,7 @@ tests/inline-unroll.scm tests/compiler-tests.scm tests/inlining-tests.scm tests/locative-stress-test.scm +tests/weak-pointer-test.scm tests/read-lines-tests.scm tests/record-rename-test.scm tests/record-printer-test.scm diff --git a/eval.scm b/eval.scm index 72c0324b..cad25de9 100644 --- a/eval.scm +++ b/eval.scm @@ -182,6 +182,8 @@ (lambda v #f) ) ] ((or (char? x) (eof-object? x) + (##core#inline "C_bwpp" x) ; TODO: Remove once we have a bootstrapping libchicken with bwp-object? + ;;(bwp-object? x) (string? x) (blob? x) (vector? x) diff --git a/expand.scm b/expand.scm index bbd8335d..6af6e5d6 100644 --- a/expand.scm +++ b/expand.scm @@ -1382,6 +1382,9 @@ (char? (car clause)) (string? (car clause)) (eof-object? (car clause)) + ;; TODO: Remove once we have a bootstrapping libchicken with bwp-object? + (##core#inline "C_bwpp" (car clause)) + #;(bwp-object? (car clause)) (blob? (car clause)) (vector? (car clause)) (##sys#srfi-4-vector? (car clause)) diff --git a/extras.scm b/extras.scm index fede5118..1b139d2b 100644 --- a/extras.scm +++ b/extras.scm @@ -295,6 +295,8 @@ (cond ((pair? obj) (wr-expr obj col)) ((null? obj) (wr-lst obj col)) ((eof-object? obj) (out "#!eof" col)) + ;; TODO: Remove once we have a bootstrapping libchicken with bwp-object? + ((##core#inline "C_bwpp" obj) #;(bwp-object? obj) (out "#!bwp" col)) ((vector? obj) (wr-lst (vector->list obj) (out "#" col))) ((boolean? obj) (out (if obj "#t" "#f") col)) ((##sys#number? obj) (out (##sys#number->string obj) col)) diff --git a/library.scm b/library.scm index 819dacfe..0373b535 100644 --- a/library.scm +++ b/library.scm @@ -600,7 +600,7 @@ EOF case-sensitive keyword-style parentheses-synonyms symbol-escape on-exit exit exit-handler implicit-exit-handler emergency-exit - ) + bwp-object? weak-cons weak-pair?) (import scheme chicken.internal.syntax) @@ -810,6 +810,11 @@ EOF (loop t) ) ) ) ) ) ) ) ) +;;; Weak pairs: +(define (bwp-object? x) (##core#inline "C_bwpp" x)) +(define (weak-cons x y) (##core#inline_allocate ("C_a_i_weak_cons" 3) x y)) +(define (weak-pair? x) (##core#inline "C_i_weak_pairp" x)) + ;;; List operators: (define (atom? x) (##core#inline "C_i_not_pair_p" x)) @@ -4279,6 +4284,8 @@ EOF (else (let ([tok (r-token)]) (cond [(string=? "eof" tok) #!eof] + ;; TODO: use #!bwp when we have a bootstrapping compiler whose reader supports it + [(string=? "bwp" tok) (foreign-value "C_SCHEME_BROKEN_WEAK_PTR" scheme-object)] [(member tok '("optional" "rest" "key")) (build-symbol (##sys#string-append "#!" tok)) ] [else @@ -4550,6 +4557,7 @@ EOF ((eq? x #f) (outstr port "#f")) ((##core#inline "C_eofp" x) (outstr port "#!eof")) ((##core#inline "C_undefinedp" x) (outstr port "#")) + ((##core#inline "C_bwpp" x) (outstr port "#!bwp")) ((##core#inline "C_charp" x) (cond [readable (outstr port "#\\") diff --git a/support.scm b/support.scm index dd230465..6bda371e 100644 --- a/support.scm +++ b/support.scm @@ -289,12 +289,16 @@ ;;; Predicates on expressions and literals: +;; TODO: Remove once we have a bootstrapping libchicken with bwp-object? +(define (bwp-object? x) (##core#inline "C_bwpp" x)) + (define (constant? x) (or (number? x) (char? x) (string? x) (boolean? x) (eof-object? x) + (bwp-object? x) (blob? x) (vector? x) (##sys#srfi-4-vector? x) @@ -304,6 +308,7 @@ (or (boolean? x) (char? x) (eof-object? x) + (bwp-object? x) (number? x) (symbol? x) ) ) @@ -312,6 +317,7 @@ (eq? (##core#undefined) x) (null? x) (eof-object? x) + (bwp-object? x) (char? x) (boolean? x) ) ) diff --git a/tests/runtests.bat b/tests/runtests.bat index 8411ec72..ab0bcc45 100644 --- a/tests/runtests.bat +++ b/tests/runtests.bat @@ -613,6 +613,11 @@ for %%s in (100000 120000 200000 250000 300000 350000 400000 450000 500000) do ( if errorlevel 1 exit /b 1 ) +echo ======================================== weak pointer test ... +%compile% weak-pointer-test.scm +if errorlevel 1 exit /b 1 +a.out +if errorlevel 1 exit /b 1 echo ======================================== symbol-GC tests ... %compile% symbolgc-tests.scm diff --git a/tests/runtests.sh b/tests/runtests.sh index e7dd37b3..4fba44b5 100755 --- a/tests/runtests.sh +++ b/tests/runtests.sh @@ -453,6 +453,10 @@ for s in 100000 120000 200000 250000 300000 350000 400000 450000 500000; do ./a.out -:d -:g -:hi$s done +echo "======================================== weak pointer test ..." +$compile weak-pointer-test.scm +./a.out + echo "======================================== symbol-GC tests ..." $compile symbolgc-tests.scm ./a.out diff --git a/tests/weak-pointer-test.scm b/tests/weak-pointer-test.scm new file mode 100644 index 00000000..b1420e89 --- /dev/null +++ b/tests/weak-pointer-test.scm @@ -0,0 +1,74 @@ +;; weak-pointer-test.scm + +(import (chicken gc)) + +(include "test.scm") + +;; Ensure weakly held items are not just equal to other references to it, but *identical* +(current-test-comparator eq?) + +(test-group "Testing that basic weak pairs get their car reclaimed" + (let* ((car (lambda (x) (##sys#slot x 0))) ; TODO: make list accessors work on weak pairs + (cadr (lambda (x) (car (##sys#slot x 1)))) + (caddr (lambda (x) (car (##sys#slot (##sys#slot x 1) 1)))) + (not-held-onto-value (vector 42)) + (held-onto-vector (vector 'this-one-stays)) + (weak-list (weak-cons not-held-onto-value + (weak-cons (vector 'ohai) + (weak-cons held-onto-vector '()))))) + + ;; break other references to the values + (set! not-held-onto-value #f) + + (gc #t) + + ;; First item is reclaimed + (test-assert "first item of weak list is reclaimed" (not (vector? (car weak-list)))) + (test-assert "first item of weak list is set to the broken-weak-pointer object" (bwp-object? (car weak-list))) + + ;; Second item is reclaimed + (test-assert "second item of weak list is reclaimed" (not (vector? (cadr weak-list)))) + (test-assert "second item of weak list is set to the broken-weak-pointer object" (bwp-object? (cadr weak-list))) + + ;; Third item stays + (test-assert "third item of weak list is kept around due to other references existing" (vector? (caddr weak-list))) + (test-equal "third item of weak list is identical to the other reference" (caddr weak-list) held-onto-vector) + (test-assert "third item of weak list is not set to the broken-weak-pointer object" (not (bwp-object? (caddr weak-list)))))) + + +(test-group "Testing cars of weak pairs referenced by their cdr do not get collected" + (let* ((car (lambda (x) (##sys#slot x 0))) ; TODO: make list accessors work on weak pairs + (cdr (lambda (x) (##sys#slot x 1))) + (obj-a (vector 42)) + (ref-a (weak-cons obj-a obj-a)) + (obj-b (vector 'ohai)) + (ref-b (weak-cons obj-b obj-b)) + (held-onto-vector (vector 'this-one-stays)) ; should be held onto regardless of this, but here for consistency + (ref-c (weak-cons held-onto-vector held-onto-vector))) + + ;; break other references to the values + (set! obj-a #f) + (set! obj-b #f) + + (gc #t) + + (test-assert "object in first weak cons is still kept around in car" (vector? (car ref-a))) + (test-assert "object in first weak cons is still kept around in cdr" (vector? (cdr ref-a))) + (test-equal "object in first weak cons' car is identical to its cdr" (car ref-a) (cdr ref-a)) + (test-assert "car of first weak cons is not a broken weak pair" (not (bwp-object? (car ref-a)))) + (test-assert "cdr of first weak cons is not a broken weak pair" (not (bwp-object? (cdr ref-a)))) + + (test-assert "object in second weak cons is still kept around in car" (vector? (car ref-b))) + (test-assert "object in second weak cons is still kept around in cdr" (vector? (cdr ref-b))) + (test-equal "object in second weak cons' car is identical to its cdr" (car ref-b) (cdr ref-b)) + (test-assert "car of second weak cons is not a broken weak pair" (not (bwp-object? (car ref-b)))) + (test-assert "cdr of second weak cons is not a broken weak pair" (not (bwp-object? (cdr ref-b)))) + + (test-assert "object in third weak cons is still kept around in car" (vector? (car ref-c))) + (test-assert "object in third weak cons is still kept around in cdr" (vector? (cdr ref-c))) + (test-equal "object in third weak cons' car is identical to its cdr" (car ref-c) (cdr ref-c)) + (test-equal "object in third weak cons' car is identical to the other reference" (car ref-c) held-onto-vector) + (test-assert "car of third weak cons is not a broken weak pair" (not (bwp-object? (car ref-c)))) + (test-assert "cdr of third weak cons is not a broken weak pair" (not (bwp-object? (cdr ref-c)))))) + +(test-exit) -- 2.38.5