- fixed problem where interned symbols were being gc-ed incorrectly

This commit is contained in:
Abdulaziz Ghuloum 2008-12-17 14:59:03 -05:00
parent e8d727c8a5
commit c2047badb9
3 changed files with 45 additions and 19 deletions

View File

@ -61,28 +61,31 @@
(set-cdr! prev (cdr ls))]
[else (f ls (cdr ls))]))]))))
(define (guardian-lookup str idx st)
(define (dead? sym)
(and ($unbound-object? ($symbol-value sym))
(null? ($symbol-plist sym))))
(define (bleed-guardian sym st)
(let ([g (symbol-table-guardian st)])
(let f ()
(let ([a (g)])
(cond
[(not a) (intern str idx st)]
[(string=? str (symbol->string a))
(begin (g a) a)]
[else
[(g) =>
(lambda (a)
(let loop ([a a])
(cond
[(and ($unbound-object? ($symbol-value a))
(null? ($symbol-plist a)))
(unintern a st)]
[else (g a)])
(f)])))))
[(eq? a sym) (g a)]
[(begin
(if (dead? a) (unintern a st) (g a))
(g)) => loop])))]))
sym)
(define (chain-lookup str idx st ls)
(if (null? ls)
(guardian-lookup str idx st)
(let ([sym (intern str idx st)])
;;; doesn't need eq? check there
(bleed-guardian sym st))
(let ([a (car ls)])
(if (string=? str (symbol->string a))
a
(bleed-guardian a st)
(chain-lookup str idx st (cdr ls))))))
(define (lookup str ih st)

View File

@ -1 +1 @@
1718
1719

View File

@ -14,6 +14,29 @@
(let ([st2 ($symbol-table-size)])
(assert (< (- st2 st1) n)))))
(define (run-tests)
(test-gcable-symbols 1000000)))
(define (test-reference-after-gc)
(define random-string
(lambda (n)
(list->string
(map (lambda (n)
(integer->char (+ (char->integer #\a) (random 26))))
(make-list n)))))
(newline)
(let ([str1 (random-string 70)]
[str2 (random-string 70)])
(printf "sym1=~s\n" (string->symbol str1))
(do ((i 0 (+ i 1))) ((= i 1024)) (collect))
(let ([sym1 (string->symbol str1)])
(printf "sym1=~s\n" (string->symbol str1))
(printf "sym2=~s\n" (string->symbol str2))
(let ([sym3 (string->symbol str1)])
(printf "sym3=~s\n" (string->symbol str1))
(assert (eq? sym1 sym3))))))
(define (run-tests)
(test-gcable-symbols 1000000)
(test-reference-after-gc)))