~ chicken-core (chicken-5) /tests/weak-pointer-test.scm
Trap1;; weak-pointer-test.scm23(import (chicken gc) (chicken port) (chicken locative))45(include "test.scm")67;; Ensure weakly held items are not just equal to other references to it, but *identical*8(current-test-comparator eq?)910(test-group "Testing basic pair accessors work on weak pairs, too"11 (let ((my-proper-weak-list (weak-cons 1 (weak-cons 2 '())))12 (my-proper-list (cons 1 (cons 2 '())))13 (my-improper-weak-list (weak-cons 1 (weak-cons 2 3)))14 (my-improper-list (cons 1 (cons 2 3))))1516 (test-assert "proper weak lists are pairs" (pair? my-proper-weak-list))17 (test-assert "improper weak lists are pairs" (pair? my-improper-weak-list))1819 (test-assert "regular proper lists are not weak pairs" (not (weak-pair? my-proper-list)))20 (test-assert "regular improper lists are not weak pairs" (not (weak-pair? my-improper-list)))2122 (test-assert "proper weak lists are lists" (list? my-proper-weak-list))23 (test-assert "improper weak lists are *not* lists" (not (list? my-improper-weak-list)))2425 (test-equal "an weak proper list is equal to the same regular proper list" my-proper-weak-list my-proper-list equal?)26 (test-equal "an weak proper list is not *identical* to the same regular proper list" my-proper-weak-list my-proper-list (complement eq?))2728 (test-equal "car of weak list returns the first item" (car my-proper-weak-list) 1)29 (test-equal "cdr of weak list returns the cdr" (cdr my-proper-weak-list) (cdr my-proper-list) equal?)30 (test-equal "cadr of weak list returns the second item" (cadr my-proper-weak-list) 2)31 (test-equal "cddr of weak list returns the cdr of the cdr" (cddr my-proper-weak-list) '())3233 (test-equal "length of weak proper list returns the length" 2 (length my-proper-weak-list))34 (test-error "length of weak improper list raises an error" (length my-improper-weak-list))3536 (let* ((written-proper-weak-list (with-output-to-string (lambda () (write my-proper-weak-list))))37 (written-improper-weak-list (with-output-to-string (lambda () (write my-improper-weak-list))))38 (reread-proper-weak-list (with-input-from-string written-proper-weak-list read))39 (reread-improper-weak-list (with-input-from-string written-improper-weak-list read)))40 (test-equal "a proper weak list is written as a regular proper list" "(1 2)" written-proper-weak-list string=?)41 (test-equal "a proper weak list is read back as regular proper list" my-proper-list reread-proper-weak-list equal?)42 (test-equal "an improper weak list is written as a regular improper list" "(1 2 . 3)" written-improper-weak-list string=?)43 (test-equal "an improper weak list is read back as regular improper list" my-improper-list reread-improper-weak-list equal?))))4445(test-group "Testing that basic weak pairs get their car reclaimed"46 (gc #t) ; Improve chances we don't get a minor GC in between47 (let* ((not-held-onto-value (vector 42))48 (held-onto-vector (vector 'this-one-stays))4950 (weak-list (weak-cons not-held-onto-value51 (weak-cons (vector 'ohai)52 (weak-cons held-onto-vector '()))))53 (weak-immediate-pair (weak-cons 1 2)))5455 ;; break other references to the values56 (set! not-held-onto-value #f)5758 (gc)5960 ;; First item is reclaimed61 (test-assert "first item of weak list is reclaimed" (not (vector? (car weak-list))))62 (test-assert "first item of weak list is set to the broken-weak-pointer object" (bwp-object? (car weak-list)))6364 ;; Second item is reclaimed65 (test-assert "second item of weak list is reclaimed" (not (vector? (cadr weak-list))))66 (test-assert "second item of weak list is set to the broken-weak-pointer object" (bwp-object? (cadr weak-list)))6768 ;; Third item stays69 (test-assert "third item of weak list is kept around due to other references existing" (vector? (caddr weak-list)))70 (test-equal "third item of weak list is identical to the other reference" (caddr weak-list) held-onto-vector)71 (test-assert "third item of weak list is not set to the broken-weak-pointer object" (not (bwp-object? (caddr weak-list))))7273 (test-equal "weak car is kept around when value is an immediate" (car weak-immediate-pair) 1)74 (test-equal "weak cdr is kept around when value is an immediate" (cdr weak-immediate-pair) 2)))757677(test-group "Testing that weak pairs do not get broken when holding permanent symbols"78 (gc #t) ; Improve chances we don't get a minor GC in between7980 ;; NOTE: When we don't use string-append here, the strings somehow get interned as (permanent) symbols?!81 ;; Perhaps this is somehow caused by the reader.82 (let* ((sym1 (string->symbol (string-append "something" "1234")))83 (sym2 (string->symbol (string-append "another" "1234")))84 (weak-permanent-symbol-pair (weak-cons 'scheme#car 'scheme#cdr))85 (weak-impermanent-symbol-pair (weak-cons sym1 sym2)))8687 (set! sym1 #f)88 (set! sym2 #f)8990 (gc)9192 (test-equal "weak car is kept around when value is a \"permanent\" symbol" (car weak-permanent-symbol-pair) 'scheme#car)93 (test-equal "weak cdr is kept around when value is a \"permanent\" symbol" (cdr weak-permanent-symbol-pair) 'scheme#cdr)9495 (test-assert "weak car is reclaimed when value is an \"impermanent\" symbol" (not (symbol? (car weak-impermanent-symbol-pair))))96 (test-assert "weak car is reclaimed when value is an \"impermanent\" symbol" (bwp-object? (car weak-impermanent-symbol-pair)))97 (test-equal "weak cdr is kept around when value is a \"impermanent\" symbol" (cdr weak-impermanent-symbol-pair) (string->symbol (string-append "an" "other1234")))))9899100(test-group "Testing cars of weak pairs referenced by their cdr do not get collected"101 (gc #t) ; Improve chances we don't get a minor GC in between102 (let* ((obj-a (vector 42))103 (ref-a (weak-cons obj-a obj-a))104 (obj-b (vector 'ohai))105 (ref-b (weak-cons obj-b obj-b))106 (held-onto-vector (vector 'this-one-stays)) ; should be held onto regardless of this, but here for consistency107 (ref-c (weak-cons held-onto-vector held-onto-vector)))108109 ;; break other references to the values110 (set! obj-a #f)111 (set! obj-b #f)112113 (gc)114115 (test-assert "object in first weak cons is still kept around in car" (vector? (car ref-a)))116 (test-assert "object in first weak cons is still kept around in cdr" (vector? (cdr ref-a)))117 (test-equal "object in first weak cons' car is identical to its cdr" (car ref-a) (cdr ref-a))118 (test-assert "car of first weak cons is not a broken weak pair" (not (bwp-object? (car ref-a))))119 (test-assert "cdr of first weak cons is not a broken weak pair" (not (bwp-object? (cdr ref-a))))120121 (test-assert "object in second weak cons is still kept around in car" (vector? (car ref-b)))122 (test-assert "object in second weak cons is still kept around in cdr" (vector? (cdr ref-b)))123 (test-equal "object in second weak cons' car is identical to its cdr" (car ref-b) (cdr ref-b))124 (test-assert "car of second weak cons is not a broken weak pair" (not (bwp-object? (car ref-b))))125 (test-assert "cdr of second weak cons is not a broken weak pair" (not (bwp-object? (cdr ref-b))))126127 (test-assert "object in third weak cons is still kept around in car" (vector? (car ref-c)))128 (test-assert "object in third weak cons is still kept around in cdr" (vector? (cdr ref-c)))129 (test-equal "object in third weak cons' car is identical to its cdr" (car ref-c) (cdr ref-c))130 (test-equal "object in third weak cons' car is identical to the other reference" (car ref-c) held-onto-vector)131 (test-assert "car of third weak cons is not a broken weak pair" (not (bwp-object? (car ref-c))))132 (test-assert "cdr of third weak cons is not a broken weak pair" (not (bwp-object? (cdr ref-c))))))133134135(test-group "Testing that strong locatives get their object updated"136 (gc #t) ; Improve chances we don't get a minor GC in between137 (let* ((not-held-onto-value (vector 42))138 (held-onto-vector (vector 'this-one-stays))139 (vec-0 (vector 0))140 (vec-1 (vector 1))141 (vec-2 (vector 2))142143 (nested-not-held-onto-value (vector vec-0 vec-1 vec-2))144 (nested-held-onto-value (vector (vector 'x) (vector 'y) (vector 'z)))145 (vec-ohai (vector 'ohai))146 (vec-fubar (vector 'fubar))147148 (loc1 (make-locative not-held-onto-value 0))149 (loc2 (make-locative (vector 'ohai 'fubar) 1))150 (loc3 (make-locative held-onto-vector 0))151152 (loc4 (make-locative nested-not-held-onto-value 1))153 (loc5 (make-locative (vector vec-ohai vec-fubar) 1))154 (loc6 (make-locative nested-held-onto-value 1)))155156 ;; break other references to the values157 (set! not-held-onto-value #f)158 (set! nested-not-held-onto-value #f)159160 (gc)161162 (test-equal "First locative is updated" (locative-ref loc1) 42)163 (test-equal "Second locative is updated" (locative-ref loc2) 'fubar)164 (test-equal "Third locative is updated" (locative-ref loc3) 'this-one-stays)165166 (test-equal "Fourth locative is updated" (locative-ref loc4) vec-1)167 (test-equal "Fifth locative is updated" (locative-ref loc5) vec-fubar)168 (test-equal "Sixth locative is updated" (locative-ref loc6) (vector-ref nested-held-onto-value 1))))169170171(test-group "Testing that weak locatives get their object reclaimed"172 (gc #t) ; Improve chances we don't get a minor GC in between173 (let* ((not-held-onto-value (vector 42))174 (held-onto-vector (vector 'this-one-stays))175 (vec-0 (vector 0))176 (vec-1 (vector 1))177 (vec-2 (vector 2))178179 (nested-not-held-onto-value (vector vec-0 vec-1 vec-2))180 (nested-held-onto-value (vector (vector 'x) (vector 'y) (vector 'z)))181 (vec-ohai (vector 'ohai))182 (vec-fubar (vector 'fubar))183184 (loc1 (make-weak-locative not-held-onto-value 0))185 (loc2 (make-weak-locative (vector 'ohai 'fubar) 1))186 (loc3 (make-weak-locative held-onto-vector 0))187188 (loc4 (make-weak-locative nested-not-held-onto-value 1))189 (loc5 (make-weak-locative (vector vec-ohai vec-fubar) 1))190 (loc6 (make-weak-locative nested-held-onto-value 1)))191192 ;; break other references to the values193 (set! not-held-onto-value #f)194 (set! nested-not-held-onto-value #f)195196 (gc)197198 (test-error "First locative is reclaimed" (locative-ref loc1))199 (test-error "Second locative is reclaimed" (locative-ref loc2))200 ;; NOTE: It seems we have to go "through" the original vector to ensure reference is kept201 (test-equal "Third locative is NOT reclaimed" (locative-ref loc3) (vector-ref held-onto-vector 0))202203 (test-error "Fourth locative is reclaimed" (locative-ref loc4))204 (test-error "Fifth locative is reclaimed" (locative-ref loc5))205 (test-equal "Sixth locative is NOT reclaimed" (locative-ref loc6) (vector-ref nested-held-onto-value 1))))206207208(test-group "Testing that weak pairs get invalidated before finalizing would-be garbage"209 (gc #t) ; Improve chances we don't get a minor GC in between210 (let* ((not-held-onto-value (vector 42))211 (held-onto-value (vector 99))212 (garbage-a (vector (weak-cons not-held-onto-value '()) (weak-cons held-onto-value '()) #f))213 (garbage-b (vector (weak-cons not-held-onto-value '()) (weak-cons held-onto-value '()) #f))214215 (garbage-a-weak-ref (weak-cons garbage-a '()))216 (garbage-b-weak-ref (weak-cons garbage-b '()))217218 (observed-garbage-a-0 #f)219 (observed-garbage-a-1 #f)220 (observed-garbage-a-2 #f)221 (observed-garbage-b-0 #f)222 (observed-garbage-b-1 #f)223 (observed-garbage-b-2 #f))224225 ;; Garbage weakly references eachother226 (vector-set! garbage-a 2 (weak-cons garbage-b '()))227 (vector-set! garbage-b 2 (weak-cons garbage-a '()))228229 (set-finalizer! garbage-a (lambda (vec)230 (set! observed-garbage-a-0 (car (vector-ref vec 0)))231 (set! observed-garbage-a-1 (car (vector-ref vec 1)))232 (set! observed-garbage-a-2 (car (vector-ref vec 2)))))233 (set-finalizer! garbage-b (lambda (vec)234 (set! observed-garbage-b-0 (car (vector-ref vec 0)))235 (set! observed-garbage-b-1 (car (vector-ref vec 1)))236 (set! observed-garbage-b-2 (car (vector-ref vec 2)))))237238 (set! not-held-onto-value #f)239 (set! garbage-a #f)240 (set! garbage-b #f)241242 ;; Must be a major collection, finalizers don't get queued on minor GC243 ;; (gc #t)244 ;; NOTE: The above won't work because it triggers *another* GC after running finalizers,245 ;; which would invalidate all weak pairs anyway. So instead, we create garbage until246 ;; the finalizers have run. This is more like what happens in a regular program.247 (let lp ()248 (unless (and observed-garbage-a-0 observed-garbage-b-0)249 (make-vector 1000)250 (lp)))251252 (test-assert "Weak pair's car which pointed to first garbage contains broken weak pointer" (bwp-object? (car garbage-a-weak-ref)))253 (test-assert "Weak pair's car in first garbage which pointed to collected object contains broken weak pointer" (bwp-object? observed-garbage-a-0))254 (test-equal "Weak pair's car in first garbage which pointed to retained object contains the original object" observed-garbage-a-1 held-onto-value)255 (test-assert "Weak pair's car in first garbage which pointed to second garbage contains broken weak pointer" (bwp-object? observed-garbage-a-2))256 (test-assert "Weak pair's car which pointed to second garbage contains broken weak pointer" (bwp-object? (car garbage-b-weak-ref)))257 (test-assert "Weak pair's car in second garbage which pointed to collected object contains broken weak pointer" (bwp-object? observed-garbage-b-0))258 (test-equal "Weak pair's car in second garbage which pointed to retained object contains the original object" observed-garbage-b-1 held-onto-value)259 (test-assert "Weak pair's car in second garbage which pointed to first garbage contains broken weak pointer" (bwp-object? observed-garbage-b-2))))260261262;; Safe version of locative-ref, returns !#bwp instead of raising an exception263(define (weak-locative-ref loc)264 (condition-case (locative-ref loc)265 ((exn type) #!bwp)))266267(test-group "Testing that weak locatives get invalidated before finalizing would-be garbage"268 (gc #t) ; Improve chances we don't get a minor GC in between269 (let* ((not-held-onto-value (vector (vector 42)))270 (held-onto-value (vector (vector 99)))271 (garbage-a (vector (make-weak-locative not-held-onto-value 0) (make-weak-locative held-onto-value 0) #f))272 (garbage-b (vector (make-weak-locative not-held-onto-value 0) (make-weak-locative held-onto-value 0) #f))273274 (garbage-a-weak-ref (make-weak-locative garbage-a 0))275 (garbage-b-weak-ref (make-weak-locative garbage-b 0))276277 (observed-garbage-a-0 #f)278 (observed-garbage-a-1 #f)279 (observed-garbage-a-2 #f)280 (observed-garbage-b-0 #f)281 (observed-garbage-b-1 #f)282 (observed-garbage-b-2 #f))283284 ;; Garbage weakly references eachother285 (vector-set! garbage-a 2 (make-weak-locative garbage-b 0))286 (vector-set! garbage-b 2 (make-weak-locative garbage-a 0))287288 (set-finalizer! garbage-a (lambda (vec)289 (set! observed-garbage-a-0 (weak-locative-ref (vector-ref vec 0)))290 (set! observed-garbage-a-1 (weak-locative-ref (vector-ref vec 1)))291 (set! observed-garbage-a-2 (weak-locative-ref (vector-ref vec 2)))))292 (set-finalizer! garbage-b (lambda (vec)293 (set! observed-garbage-b-0 (weak-locative-ref (vector-ref vec 0)))294 (set! observed-garbage-b-1 (weak-locative-ref (vector-ref vec 1)))295 (set! observed-garbage-b-2 (weak-locative-ref (vector-ref vec 2)))))296297 (set! not-held-onto-value #f)298 (set! garbage-a #f)299 (set! garbage-b #f)300301 ;; Must be a major collection, finalizers don't get queued on minor GC302 ;; (gc #t)303 ;; NOTE: The above won't work because it triggers *another* GC after running finalizers,304 ;; which would invalidate all weak pairs anyway. So instead, we create garbage until305 ;; the finalizers have run. This is more like what happens in a regular program.306 (let lp ()307 (unless (and observed-garbage-a-0 observed-garbage-b-0)308 (make-vector 1000)309 (lp)))310311 (test-assert "Weak locative which pointed to first garbage contains broken weak pointer" (bwp-object? (weak-locative-ref garbage-a-weak-ref)))312 (test-assert "Weak locative in first garbage which pointed to collected object contains broken weak pointer" (bwp-object? observed-garbage-a-0))313 (test-equal "Weak locative in first garbage which pointed to retained object contains the original object" observed-garbage-a-1 (vector-ref held-onto-value 0))314 (test-assert "Weak locative in first garbage which pointed to second garbage contains broken weak pointer" (bwp-object? observed-garbage-a-2))315 (test-assert "Weak locative which pointed to second garbage contains broken weak pointer" (bwp-object? (weak-locative-ref garbage-b-weak-ref)))316 (test-assert "Weak locative in second garbage which pointed to collected object contains broken weak pointer" (bwp-object? observed-garbage-b-0))317 (test-equal "Weak locative in second garbage which pointed to retained object contains the original object" observed-garbage-b-1 (vector-ref held-onto-value 0))318 (test-assert "Weak locative in second garbage which pointed to first garbage contains broken weak pointer" (bwp-object? observed-garbage-b-2))))319320(test-exit)