From 8e4a08948e1498fe79853338afc9e4e7db70bbd1 Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Fri, 13 Aug 2010 04:22:46 +0000 Subject: [PATCH] Protect each use of ENTRY-{KEY,DATUM} in hashtb.scm by ENTRY-VALID?. --- src/runtime/hashtb.scm | 190 ++++++++++++++++++++++------------------- 1 file changed, 101 insertions(+), 89 deletions(-) diff --git a/src/runtime/hashtb.scm b/src/runtime/hashtb.scm index bbf4a96b6..73ee873eb 100644 --- a/src/runtime/hashtb.scm +++ b/src/runtime/hashtb.scm @@ -280,15 +280,18 @@ USA. (define-integrable (make-weak-type key-hash key=? rehash-after-gc? compute-hash!) (make-table-type key-hash key=? rehash-after-gc? - (make-method:get compute-hash! key=? %weak-entry-key - %weak-entry-datum) + (make-method:get compute-hash! key=? %weak-entry-valid? + %weak-entry-key %weak-entry-datum) (make-method:put! compute-hash! key=? %weak-make-entry - %weak-entry-key %weak-set-entry-datum!) + %weak-entry-valid? %weak-entry-key + %weak-set-entry-datum!) (make-method:modify! compute-hash! key=? %weak-make-entry - %weak-entry-key %weak-entry-datum + %weak-entry-valid? %weak-entry-key + %weak-entry-datum %weak-set-entry-datum!) - (make-method:remove! compute-hash! key=? %weak-entry-key) - weak-method:clean! + (make-method:remove! compute-hash! key=? %weak-entry-valid? + %weak-entry-key) + (make-method:clean! %weak-entry-valid?) (make-method:rehash! key-hash %weak-entry-valid? %weak-entry-key) (make-method:fold %weak-entry-valid? %weak-entry-key @@ -315,41 +318,42 @@ USA. (define-integrable %weak-entry-datum system-pair-cdr) (define-integrable %weak-set-entry-datum! system-pair-set-cdr!) -(define (weak-method:clean! table) - (let ((buckets (table-buckets table))) - (let ((n-buckets (vector-length buckets))) - (do ((i 0 (fix:+ i 1))) - ((not (fix:< i n-buckets))) - (letrec - ((scan-head - (lambda (p) - (if (pair? p) - (if (%weak-entry-valid? (car p)) - (begin - (vector-set! buckets i p) - (scan-tail (cdr p) p)) - (begin - (decrement-table-count! table) - (scan-head (cdr p)))) - (vector-set! buckets i p)))) - (scan-tail - (lambda (p q) - (if (pair? p) - (if (%weak-entry-valid? (car p)) - (scan-tail (cdr p) p) - (begin - (decrement-table-count! table) - (let loop ((p (cdr p))) - (if (pair? p) - (if (%weak-entry-valid? (car p)) - (begin - (set-cdr! q p) - (scan-tail (cdr p) p)) - (begin - (decrement-table-count! table) - (loop (cdr p)))) - (set-cdr! q p))))))))) - (scan-head (vector-ref buckets i))))))) +(define-integrable (make-method:clean! entry-valid?) + (lambda (table) + (let ((buckets (table-buckets table))) + (let ((n-buckets (vector-length buckets))) + (do ((i 0 (fix:+ i 1))) + ((not (fix:< i n-buckets))) + (letrec + ((scan-head + (lambda (p) + (if (pair? p) + (if (entry-valid? (car p)) + (begin + (vector-set! buckets i p) + (scan-tail (cdr p) p)) + (begin + (decrement-table-count! table) + (scan-head (cdr p)))) + (vector-set! buckets i p)))) + (scan-tail + (lambda (p q) + (if (pair? p) + (if (entry-valid? (car p)) + (scan-tail (cdr p) p) + (begin + (decrement-table-count! table) + (let loop ((p (cdr p))) + (if (pair? p) + (if (entry-valid? (car p)) + (begin + (set-cdr! q p) + (scan-tail (cdr p) p)) + (begin + (decrement-table-count! table) + (loop (cdr p)))) + (set-cdr! q p))))))))) + (scan-head (vector-ref buckets i)))))))) ;;;; Strong table type @@ -375,17 +379,17 @@ USA. (define-integrable (make-strong-type key-hash key=? rehash-after-gc? compute-hash!) (make-table-type key-hash key=? rehash-after-gc? - (make-method:get compute-hash! key=? %strong-entry-key - %strong-entry-datum) + (make-method:get compute-hash! key=? %strong-entry-valid? + %strong-entry-key %strong-entry-datum) (make-method:put! compute-hash! key=? %strong-make-entry - %strong-entry-key + %strong-entry-valid? %strong-entry-key %strong-set-entry-datum!) (make-method:modify! compute-hash! key=? - %strong-make-entry %strong-entry-key - %strong-entry-datum + %strong-make-entry %strong-entry-valid? + %strong-entry-key %strong-entry-datum %strong-set-entry-datum!) (make-method:remove! compute-hash! key=? - %strong-entry-key) + %strong-entry-valid? %strong-entry-key) (lambda (table) table unspecific) (make-method:rehash! key-hash %strong-entry-valid? %strong-entry-key) @@ -405,23 +409,27 @@ USA. ;;;; Methods -(define-integrable (make-method:get compute-hash! key=? entry-key entry-datum) +(define-integrable (make-method:get compute-hash! key=? + entry-valid? entry-key entry-datum) (lambda (table key default) (let ((hash (compute-hash! table key))) (let loop ((p (vector-ref (table-buckets table) hash))) (if (pair? p) - (if (key=? (entry-key (car p)) key) - (entry-datum (car p)) - (loop (cdr p))) + (let ((key* (entry-key (car p))) + (datum (entry-datum (car p)))) + (if (and (entry-valid? (car p)) (key=? key* key)) + datum + (loop (cdr p)))) default))))) -(define-integrable (make-method:put! compute-hash! key=? make-entry entry-key - set-entry-datum!) +(define-integrable (make-method:put! compute-hash! key=? make-entry + entry-valid? entry-key set-entry-datum!) (lambda (table key datum) (let ((hash (compute-hash! table key))) (let loop ((p (vector-ref (table-buckets table) hash)) (q #f)) (if (pair? p) - (if (key=? (entry-key (car p)) key) + (if (let ((key* (entry-key (car p)))) + (and (entry-valid? (car p)) (key=? key* key))) (set-entry-datum! (car p) datum) (loop (cdr p) p)) (with-table-locked! table @@ -434,18 +442,21 @@ USA. (maybe-grow-table! table)))))))) (define-integrable (make-method:modify! compute-hash! key=? make-entry - entry-key entry-datum set-entry-datum!) + entry-valid? entry-key entry-datum + set-entry-datum!) (lambda (table key procedure default) (let ((hash (compute-hash! table key))) (let loop ((p (vector-ref (table-buckets table) hash)) (q #f)) (if (pair? p) - (if (key=? (entry-key (car p)) key) - (with-table-locked! table - (lambda () - (let ((datum (procedure (entry-datum (car p))))) - (set-entry-datum! (car p) datum) - datum))) - (loop (cdr p) p)) + (let ((key* (entry-key (car p))) + (datum (entry-datum (car p)))) + (if (and (entry-valid? (car p)) (key=? key* key)) + (with-table-locked! table + (lambda () + (let ((datum* (procedure datum))) + (set-entry-datum! (car p) datum*) + datum*))) + (loop (cdr p) p))) (let ((datum (procedure default))) (with-table-locked! table (lambda () @@ -457,12 +468,14 @@ USA. (maybe-grow-table! table))) datum)))))) -(define-integrable (make-method:remove! compute-hash! key=? entry-key) +(define-integrable (make-method:remove! compute-hash! key=? + entry-valid? entry-key) (lambda (table key) (let ((hash (compute-hash! table key))) (let loop ((p (vector-ref (table-buckets table) hash)) (q #f)) (if (pair? p) - (if (key=? (entry-key (car p)) key) + (if (let ((key* (entry-key (car p)))) + (and (entry-valid? (car p)) (key=? key* key))) (with-table-locked! table (lambda () (if q @@ -478,9 +491,9 @@ USA. (let ((n-buckets (vector-length buckets))) (let loop ((p entries)) (if (pair? p) - (let ((q (cdr p))) + (let ((key (entry-key (car p))) (q (cdr p))) (if (entry-valid? (car p)) - (let ((hash (key-hash (entry-key (car p)) n-buckets))) + (let ((hash (key-hash key n-buckets))) (set-cdr! p (vector-ref buckets hash)) (vector-set! buckets hash p)) (decrement-table-count! table)) @@ -495,11 +508,11 @@ USA. (let per-entry ((p (vector-ref buckets i)) (value value)) (if (pair? p) (per-entry (cdr p) - (if (entry-valid? (car p)) - (procedure (entry-key (car p)) - (entry-datum (car p)) - value) - value)) + (let ((key (entry-key (car p))) + (datum (entry-datum (car p)))) + (if (entry-valid? (car p)) + (procedure key datum value) + value))) (per-bucket (fix:+ i 1) value))) value)))))) @@ -508,24 +521,23 @@ USA. (lambda (bucket) (let find-head ((p bucket)) (if (pair? p) - (if (entry-valid? (car p)) - (let ((head - (cons (make-entry (entry-key (car p)) - (entry-datum (car p))) - '()))) - (let loop ((p (cdr p)) (previous head)) - (if (pair? p) - (loop (cdr p) - (if (entry-valid? (car p)) - (let ((p* - (cons (make-entry (entry-key (car p)) - (entry-datum (car p))) - '()))) - (set-cdr! previous p*) - p*) - previous)))) - head) - (find-head (cdr p))) + (let ((key (entry-key (car p))) + (datum (entry-datum (car p)))) + (if (entry-valid? (car p)) + (let ((head (cons (make-entry key datum) '()))) + (let loop ((p (cdr p)) (previous head)) + (if (pair? p) + (loop (cdr p) + (let ((key (entry-key (car p))) + (datum (entry-datum (car p)))) + (if (entry-valid? (car p)) + (let ((p* + (cons (make-entry key datum) '()))) + (set-cdr! previous p*) + p*) + previous))))) + head) + (find-head (cdr p)))) p)))) ;;;; Resizing -- 2.25.1