Fix nasty bug: modifying a hash table could scramble its buckets.

diff --git a/src/runtime/hashtb.scm b/src/runtime/hashtb.scm
index cde06dd939e0a5205bba5c69bd71384acf0a73a0..c41cab9985f6de604c4f8f866f03ce753a9d37e1 100644 (file)
--- a/src/runtime/hashtb.scm
+++ b/src/runtime/hashtb.scm
@@ -660,31 +660,39 @@ USA.
 (define (make-method:modify! compute-hash! key=? entry-type)
   (declare (integrate-operator compute-hash! key=? entry-type))
   (define (method:modify! table key default procedure)
-    (let ((hash (compute-hash! table key)))
-      (let loop ((p (vector-ref (table-buckets table) hash)) (q #f))
-       (if (pair? p)
-           (call-with-entry-key&datum entry-type (car p)
-             (lambda (key* datum barrier)
-               (declare (integrate key* datum barrier))
-               (if (key=? key* key)
-                   (let ((datum* (procedure datum)))
-                     (without-interruption
-                       (lambda ()
-                         (set-entry-datum! entry-type (car p) datum*)))
-                     (barrier)
-                     datum*)
-                   (loop (cdr p) p)))
-             (lambda () (loop (cdr p) p)))
-           (let ((datum (procedure default)))
-             (without-interruption
-               (lambda ()
-                 (let ((r (cons (make-entry entry-type key datum) '())))
-                   (if q
-                       (set-cdr! q r)
-                       (vector-set! (table-buckets table) hash r)))
-                 (increment-table-count! table)
-                 (maybe-grow-table! table)))
-             datum)))))
+    (let restart ((has-value? #f) (value #f))
+      (let ((hash (compute-hash! table key)))
+       (let loop ((p (vector-ref (table-buckets table) hash)) (q #f))
+         (if (pair? p)
+             (call-with-entry-key&datum entry-type (car p)
+               (lambda (key* datum barrier)
+                 (declare (integrate key* datum barrier))
+                 (if (key=? key* key)
+                     (let ((datum* (procedure datum)))
+                       (without-interruption
+                         (lambda ()
+                           (set-entry-datum! entry-type (car p) datum*)))
+                       (barrier)
+                       datum*)
+                     (loop (cdr p) p)))
+               (lambda () (loop (cdr p) p)))
+             ;; If there's no entry, we have to create a new one.  But calling
+             ;; PROCEDURE potentially modifies TABLE, so we can't assume that Q
+             ;; or the bucket are valid when it returns.  Instead, re-start the
+             ;; loop, and if there's still no entry, we can then safely add the
+             ;; previously computed value.
+             (if (not has-value?)
+                 (restart #t (procedure default))
+                 (begin
+                   (without-interruption
+                     (lambda ()
+                       (let ((r (cons (make-entry entry-type key value) '())))
+                         (if q
+                             (set-cdr! q r)
+                             (vector-set! (table-buckets table) hash r)))
+                       (increment-table-count! table)
+                       (maybe-grow-table! table)))
+                   value)))))))
   method:modify!)
 \f
 (define (make-method:remove! compute-hash! key=? entry-type)