Fix breakage I caused with a previous refactoring.

The procedures hash-table-update! and hash-table/modify! were not equivalent, as
I blindly assumed during the refactor.  Changing hash-table-update! to use the
same implementation as hash-table/modify! caused the unit tests to fail, because
that implementation couldn't implement the tested behavior.

Rather than try to fix the implementation, I reverted hash-table-update! to its
previous implementation.  The rationale for this is that fixing the implementation
would effectively eliminate its performance advantage, while still being hard to
understand.  The older implementation is trivial to understand and eliminates
the restriction that the update procedure not use the hash table.

An additional complication arose because the previous implementation of
hash-table-update! returned an unspecified value, which broke hash-table-intern!
and caused hash-table/modify! to differ from its previous behavior.  I fixed
these by rewriting them without using hash-table-update!.

diff --git a/doc/ref-manual/associations.texi b/doc/ref-manual/associations.texi
index 0ee70ba62776c3c5fbb4253b22f1148c98568e4b..f9c92ff2ff3cbeb436cc1fc815913d389bc8da80 100644 (file)
--- a/doc/ref-manual/associations.texi
+++ b/doc/ref-manual/associations.texi
@@ -857,11 +857,9 @@ The average time required by this operation is bounded by a constant.
 Applies @var{procedure} to the datum associated with @var{key} in
 @var{hash-table} or to the value of calling @var{get-default} if there
 is no association for @var{key}, associates the result with @var{key},
-and returns that same result.  If @var{get-default} is not supplied
+and returns an unspecified value.  If @var{get-default} is not supplied
 and there's no association for @var{key}, an error is signaled.
 
-Neither @var{procedure} nor @var{get-default} may use @var{hash-table}.
-
 The average time required by this operation is bounded by a constant.
 @end deffn
 
@@ -873,24 +871,6 @@ Equivalent to
 @end lisp
 @end deffn
 
-@c The reason that the procedure passed to hash-table-update!  may not
-@c even use the hash table is that, e.g., hash-table-ref may actually
-@c mutate the underlying table, because it may perform some deferred
-@c cleanup.  Specifically, if the table needs to be rehashed on GC, it
-@c is not actually rehashed when the garbage collector runs, but on
-@c the next access thereafter.  If the procedure given to
-@c hash-table-update! accesses the hash table, and a garbage
-@c collection occurs after this procedure is invoked but before the
-@c (last) access it makes, the table may be rehashed, which may cause
-@c hash-table-update! to insert the returned datum into the wrong
-@c bucket or into a dead hash table entry.  An analagous problem
-@c plagues weak and ephemeral tables; in this case, even if the table
-@c is not rehashed, accessing it after a GC may trigger a cleanup of
-@c entries whose keys or data have been garbage collected, which may
-@c trigger a resizing of the table and cause hash-table-update!  to
-@c put its datum into the wrong place.  The same considerations apply
-@c to hash-table-intern!.
-
 @deffn procedure hash-table-intern! hash-table key get-default
 @deffnx {obsolete procedure} hash-table/intern! hash-table key get-default
 @var{Get-default} must be a procedure of zero arguments.  Ensures that
@@ -899,8 +879,6 @@ associated datum.  If @var{hash-table} did not have a datum associated
 with @var{key}, @var{get-default} is called and its value is used to
 create a new association for @var{key}.
 
-The @var{get-default} procedure must not use @var{hash-table}.
-
 The average time required by this operation is bounded by a constant.
 @end deffn
 

diff --git a/src/runtime/hash-table.scm b/src/runtime/hash-table.scm
index 8c4e73ac4f02d178b9ac3cd2402c7bc1ea156b08..5f756f20c242d17e6dd63ff69f01c8b29d94ab3e 100644 (file)
--- a/src/runtime/hash-table.scm
+++ b/src/runtime/hash-table.scm
@@ -40,7 +40,6 @@ USA.
   (rehash-after-gc? #f read-only #t)
   (method:get #f read-only #t)
   (method:put! #f read-only #t)
-  (method:modify! #f read-only #t)
   (method:remove! #f read-only #t)
   (method:clean! #f read-only #t)
   (method:rehash! #f read-only #t)
@@ -164,23 +163,20 @@ USA.
   ((table-type-method:put! (table-type table)) table key datum))
 
 (define (hash-table-update! table key procedure #!optional get-default)
-  (guarantee hash-table? table 'hash-table-update!)
-  ((table-type-method:modify! (table-type table))
-   table
-   key
-   (if (default-object? get-default)
-       (lambda () (error:bad-range-argument key 'hash-table-update!))
-       get-default)
-   procedure))
+  (hash-table-set! table key
+                  (procedure (hash-table-ref table key get-default))))
 
 (define (hash-table-update!/default table key procedure default)
   (hash-table-update! table key procedure (lambda () default)))
 
 (define (hash-table-intern! table key generator)
-  (hash-table-update!/default table key
-    (lambda (datum)
-      (if (eq? datum default-marker) (generator) datum))
-    default-marker))
+  (let ((datum
+        (let ((datum (hash-table-ref/default table key default-marker)))
+          (if (eq? datum default-marker)
+              (generator)
+              datum))))
+    (hash-table-set! table key datum)
+    datum))
 
 (define (hash-table-delete! table key)
   (guarantee hash-table? table 'hash-table-delete!)
@@ -349,7 +345,6 @@ USA.
   (%make-table-type key-hash key=? rehash-after-gc?
                    (make-method:get compute-hash! key=? entry-type)
                    (make-method:put! compute-hash! key=? entry-type)
-                   (make-method:modify! compute-hash! key=? entry-type)
                    (make-method:remove! compute-hash! key=? entry-type)
                    (if (eq? entry-type hash-table-entry-type:strong)
                        (named-lambda (method:no-clean! table)
@@ -710,44 +705,6 @@ USA.
                (maybe-grow-table! table)))))))
   method:put!)
 
-(define (make-method:modify! compute-hash! key=? entry-type)
-  (declare (integrate-operator compute-hash! key=? entry-type))
-  (define (method:modify! table key get-default procedure)
-    (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 (get-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)
   (declare (integrate-operator compute-hash! key=? entry-type))
   (define (method:remove! table key)
@@ -768,7 +725,7 @@ USA.
                    (loop (cdr p) p)))
              (lambda () (loop (cdr p) p)))))))
   method:remove!)
-
+\f
 (define (make-method:clean! entry-type)
   (declare (integrate-operator entry-type))
   (define (method:clean! table)
@@ -805,7 +762,7 @@ USA.
                              (set-cdr! q p)))))))
            (scan-head (vector-ref buckets i)))))))
   method:clean!)
-\f
+
 (define (make-method:rehash! key-hash entry-type)
   (declare (integrate-operator key-hash entry-type))
   (define (method:rehash! table entries)
@@ -823,7 +780,7 @@ USA.
                  (lambda () (decrement-table-count! table)))
                (loop q)))))))
   method:rehash!)
-
+\f
 (define (make-method:fold entry-type)
   (declare (integrate-operator entry-type))
   (define (method:fold table procedure initial-value)
@@ -1204,7 +1161,7 @@ USA.
 (define-syntax define-integrableish
   (sc-macro-transformer
    (lambda (form environment)
-     environment                       ;ignore
+     (declare (ignore environment))
      (let ((name (caadr form))
           (parameters (cdadr form))
           (body (cddr form)))
@@ -1221,9 +1178,9 @@ USA.
 (define-integrableish (open-type-constructor entry-type)
   (declare (integrate-operator %make-hash-table-type make-table-type))
   (declare (integrate-operator make-method:get make-method:put!))
-  (declare (integrate-operator make-method:modify! make-method:remove!))
-  (declare (integrate-operator make-method:clean! make-method:rehash!))
-  (declare (integrate-operator make-method:fold make-method:copy-bucket))
+  (declare (integrate-operator make-method:remove! make-method:clean!))
+  (declare (integrate-operator make-method:rehash! make-method:fold))
+  (declare (integrate-operator make-method:copy-bucket))
   (lambda (key-hash key=? rehash-after-gc?)
     (let ((compute-hash!
           ((if rehash-after-gc?
@@ -1243,9 +1200,9 @@ USA.
   (declare (integrate-operator %make-hash-table-type make-table-type))
   (declare (integrate-operator compute-address-hash compute-non-address-hash))
   (declare (integrate-operator make-method:get make-method:put!))
-  (declare (integrate-operator make-method:modify! make-method:remove!))
-  (declare (integrate-operator make-method:clean! make-method:rehash!))
-  (declare (integrate-operator make-method:fold make-method:copy-bucket))
+  (declare (integrate-operator make-method:remove! make-method:clean!))
+  (declare (integrate-operator make-method:rehash! make-method:fold))
+  (declare (integrate-operator make-method:copy-bucket))
   (make-table-type key-hash key=? rehash-after-gc?
                   (if rehash-after-gc?
                       (compute-address-hash key-hash)
@@ -1409,7 +1366,9 @@ USA.
        (if-found datum))))
 
 (define (hash-table/modify! table key default procedure)
-  (hash-table-update!/default table key procedure default))
+  (let ((datum (procedure (hash-table-ref/default table key default))))
+    (hash-table-set! table key datum)
+    datum))
 
 (define (hash-table-copy table)
   (guarantee hash-table? table 'hash-table-copy)