Steel Bank Common Lisp

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv12016/src/code

Modified Files:
	cold-init.lisp early-impl.lisp gc.lisp hash-table.lisp 
	target-hash-table.lisp 
Log Message:
1.0.10.14: remove locking and gc inhibition from hash-tables, power of 2 sizes

        This commit removes a bunch of bottlenecks from the hash-table
        implementation. It speeds up GETHASH, (SETF GETHASH) and
        REMHASH by a factor of 2-4x (on platforms with a real
        WITH-PINNED-OBJECTS) depending on the operation. On the flip
        side, no automatic locking is done on tables any more, so
        multi-threaded applications must do their own locking. (The
        locking done by SBCL was always just an implementation detail,
        not a part of the external interface). By popular demand it's
        also still safe to have multiple readers on the same table
        without locking.

	Originally GCs were inhibited during most hash-table
        operations for two reasons. To prevent the GC from rehashing a
        table while a Lisp-side operation is going on, and to prevent
        the GC from moving the key after the hash-value has been
        calculated.

        More recently, most hash-tables operations have acquired a
        lock on the table in order to prevent two concurrent writers
        from corrupting the chains. While it's never been the intent
        for the standard data structures to be automatically
        thread-safe in SBCL, this locking had to be done since corrupt
        tables could lead to infinite GC loops.

        Both the locking and the without-gcing are expensive
        operations relative to the total cost of a hash-table lookup.
        This commit removes both the gc inhibition and the locks.
        Additionally we switch to power of two table size, which
        allows calculating a cheaper hash -> bucket with cheaper
        operations than MOD.

        * The GC no longer does the rehashing itself, but just marks
          the hash-table as needing a rehash, which will then be done
          Lisp-side when the table is next accessed. While it's
          possible to find cases where the former behaviour has better
          performance, they're very contrived.
        * The hash-table operations that work on the chains now check
          for loops in the chains, and signal an error if one is found.
        * The hash-table operations now pin the key before calculating
          the hash value (needed for EQ-based hash functions).
        * Add a GC epoch value that GETHASH can use to check whether
          a GC happened during the lookup. This is needed since another
          thread calling GETHASH on the same table might have caused it
          to be rehashed.
        * Kill the old MUST-REHASH vector header, and replace it with a
          slot in the HASH-TABLE structure. The overloading of the header
          caused missed rehashings when both the GC and %%PUTHASH modified
          it at the same time.
        * Switch to power of two table sizes, with a slightly more complex
          hash value -> bucket calculation than just taking the low bits,
          which in many cases have a very skewed distribution for the existing
          SBCL hash functions. Still a lot faster than using MOD.
        * Leave in locking and GC inhibition during rehashing (needed to
          allow multiple readers to coexist) and for weak hash-tables
          (they need some GC support, and the code is much simpler when
          all of the logic is in the GC instead of interleaved in the GC and 
          Lisp-side). Neither of these cases is performance critical.



Index: cold-init.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/cold-init.lisp,v
retrieving revision 1.73
retrieving revision 1.74
diff -u -d -r1.73 -r1.74
--- cold-init.lisp	9 Aug 2007 16:52:03 -0000	1.73
+++ cold-init.lisp	30 Sep 2007 23:18:50 -0000	1.74
@@ -104,7 +104,8 @@
         *current-error-depth* 0
         *cold-init-complete-p* nil
         *type-system-initialized* nil
-        sb!vm:*alloc-signal* nil)
+        sb!vm:*alloc-signal* nil
+        sb!kernel::*gc-epoch* (cons nil nil))
 
   ;; I'm not sure where eval is first called, so I put this first.
   #!+sb-eval

Index: early-impl.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-impl.lisp,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -d -r1.24 -r1.25
--- early-impl.lisp	20 Jun 2007 19:05:54 -0000	1.24
+++ early-impl.lisp	30 Sep 2007 23:18:50 -0000	1.25
@@ -37,6 +37,7 @@
                   *interrupts-enabled*
                   *interrupt-pending*
                   *free-interrupt-context-index*
+                  sb!kernel::*gc-epoch*
                   sb!vm::*unwind-to-frame-function*
                   sb!vm::*allocation-pointer*
                   sb!vm::*binding-stack-pointer*

Index: gc.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/gc.lisp,v
retrieving revision 1.75
retrieving revision 1.76
diff -u -d -r1.75 -r1.76
--- gc.lisp	9 Jun 2007 18:31:38 -0000	1.75
+++ gc.lisp	30 Sep 2007 23:18:50 -0000	1.76
@@ -180,6 +180,22 @@
 (defvar *already-in-gc*
   (sb!thread:make-mutex :name "GC lock") "ID of thread running SUB-GC")
 
+;;; A unique GC id. This is supplied for code that needs to detect
+;;; whether a GC has happened since some earlier point in time. For
+;;; example:
+;;;
+;;;   (let ((epoch *gc-epoch*))
+;;;      ...
+;;;      (unless (eql epoch *gc-epoch)
+;;;        ....))
+;;;
+;;; This isn't just a fixnum counter since then we'd have theoretical
+;;; problems when exactly 2^29 GCs happen between epoch
+;;; comparisons. Unlikely, but the cost of using a cons instead is too
+;;; small to measure. -- JES, 2007-09-30
+(declaim (type cons *gc-epoch*))
+(defvar *gc-epoch* (cons nil nil))
+
 (defun sub-gc (&key (gen 0))
   (unless (eq sb!thread:*current-thread*
               (sb!thread::mutex-value *already-in-gc*))
@@ -202,6 +218,7 @@
                  (gc-stop-the-world)
                  (let ((start-time (get-internal-run-time)))
                    (collect-garbage gen)
+                   (setf *gc-epoch* (cons nil nil))
                    (incf *gc-run-time*
                          (- (get-internal-run-time) start-time)))
                  (setf *gc-pending* nil

Index: hash-table.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/hash-table.lisp,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -d -r1.14 -r1.15
--- hash-table.lisp	2 Apr 2007 08:37:36 -0000	1.14
+++ hash-table.lisp	30 Sep 2007 23:18:50 -0000	1.15
@@ -46,10 +46,6 @@
   ;; the docstring of MAKE-HASH-TABLE.
   (weakness nil :type (member nil :key :value :key-or-value :key-and-value)
             :read-only t)
-  ;; Index into the next-vector, chaining together buckets that need
-  ;; to be rehashed because their hashing is EQ based and the key has
-  ;; been moved by the garbage collector.
-  (needing-rehash 0 :type index)
   ;; Index into the Next vector chaining together free slots in the KV
   ;; vector.
   (next-free-kv 0 :type index)
@@ -61,8 +57,8 @@
   (index-vector (missing-arg)
                 :type (simple-array (unsigned-byte #.sb!vm:n-word-bits) (*)))
   ;; This table parallels the KV vector, and is used to chain together
-  ;; the hash buckets, the free list, and the values needing rehash, a
-  ;; slot will only ever be in one of these lists.
+  ;; the hash buckets and the free list. A slot will only ever be in
+  ;; one of these lists.
   (next-vector (missing-arg)
                :type (simple-array (unsigned-byte #.sb!vm:n-word-bits) (*)))
   ;; This table parallels the KV table, and can be used to store the
@@ -73,8 +69,18 @@
   ;; respective key.
   (hash-vector nil :type (or null (simple-array (unsigned-byte
                                                  #.sb!vm:n-word-bits) (*))))
-  ;; This lock is acquired by %PUTHASH, REMHASH, CLRHASH and GETHASH.
-  (spinlock (sb!thread::make-spinlock)))
+  ;; Used for locking GETHASH/(SETF GETHASH)/REMHASH for tables with :LOCK-P T
+  (spinlock (sb!thread::make-spinlock) :type sb!thread::spinlock)
+  ;; The GC will set this to T if it moves an EQ-based key. This used
+  ;; to be signaled by a bit in the header of the kv vector, but that
+  ;; implementation caused some concurrency issues when we stopped
+  ;; inhibiting GC during hash-table lookup.
+  (needs-rehash-p nil :type (member nil t))
+  ;; For detecting concurrent accesses.
+  #!+sb-hash-table-debug
+  (concurrent-access-error t :type (member nil t))
+  #!+sb-hash-table-debug
+  (accessing-thread nil))
 
 ;; as explained by pmai on openprojects #lisp IRC 2002-07-30: #x80000000
 ;; is bigger than any possible nonEQ hash value, and thus indicates an
@@ -112,7 +118,7 @@
                          (let ((key (aref kv-vector (* 2 index)))
                                (value (aref kv-vector (1+ (* 2 index)))))
                            (incf index)
-                           (unless (and (eq key +empty-ht-slot+)
+                           (unless (or (eq key +empty-ht-slot+)
                                         (eq value +empty-ht-slot+))
                              (return (values t key value))))))))
                 #',function))))

Index: target-hash-table.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-hash-table.lisp,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -d -r1.37 -r1.38
--- target-hash-table.lisp	28 Jun 2007 23:13:46 -0000	1.37
+++ target-hash-table.lisp	30 Sep 2007 23:18:50 -0000	1.38
@@ -14,26 +14,46 @@
 
 ;;;; utilities
 
-;;; Without the locking the next vector can get cyclic causing
-;;; looping in a WITHOUT-GCING form, SHRINK-VECTOR can corrupt memory
-;;; and who knows what else.
-;;;
-;;; WITHOUT-GCING implies WITHOUT-INTERRUPTS.
-(defmacro with-spinlock-and-without-gcing ((spinlock) block &body body)
-  #!-sb-thread
-  (declare (ignore spinlock))
-  `(without-gcing
-     (unwind-protect
-          (progn
-            #!+sb-thread
-            (sb!thread::get-spinlock ,spinlock)
-            (block ,block ,@body))
-       #!+sb-thread
-       (sb!thread::release-spinlock ,spinlock))))
-
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defconstant max-hash sb!xc:most-positive-fixnum))
 
+;;; Code for detecting concurrent accesses to the same table from
+;;; multiple threads. Only compiled in when the :SB-HASH-TABLE-DEBUG
+;;; feature is enabled. The main reason for the existence of this code
+;;; is to detect thread-unsafe uses of hash-tables in sbcl itself,
+;;; where debugging anythign can be impossible after an important
+;;; internal hash-table has been corrupted. It's plausible that this
+;;; could be useful for some user code too, but the runtime cost is
+;;; really too high to enable it by default.
+(defmacro with-concurrent-access-check (hash-table &body body)
+  (declare (ignorable hash-table))
+  #!-sb-hash-table-debug
+  `(progn ,@body)
+  #!+sb-hash-table-debug
+  (once-only ((hash-table hash-table))
+    `(progn
+       (flet ((body-fun ()
+                ,@body)
+              (error-fun ()
+                ;; Don't signal more errors for this table.
+                (setf (hash-table-concurrent-access-error ,hash-table) nil)
+                (error "Concurrent access to ~A" ,hash-table)))
+         (if (hash-table-concurrent-access-error ,hash-table)
+             (let ((thread (hash-table-accessing-thread ,hash-table)))
+               (unwind-protect
+                    (progn
+                      (when (and thread
+                                 (not (eql thread sb!thread::*current-thread*)))
+                        (error-fun))
+                      (setf (hash-table-accessing-thread ,hash-table)
+                            sb!thread::*current-thread*)
+                      (body-fun))
+                 (unless (eql (hash-table-accessing-thread ,hash-table)
+                              sb!thread::*current-thread*)
+                   (error-fun))
+                 (setf (hash-table-accessing-thread ,hash-table) thread)))
+             (body-fun))))))
+
 (deftype hash ()
   `(integer 0 ,max-hash))
 
@@ -84,17 +104,24 @@
     (t
      (eq-hash key))))
 
-(defun almost-primify (num)
+(defun ceil-power-of-two (num)
   (declare (type index num))
-  #!+sb-doc
-  "Return an almost prime number greater than or equal to NUM."
-  (if (= (rem num 2) 0)
-      (setq num (+ 1 num)))
-  (if (= (rem num 3) 0)
-      (setq num (+ 2 num)))
-  (if (= (rem num 7) 0)
-      (setq num (+ 4 num)))
-  num)
+  (ash 1 (integer-length num)))
+
+(declaim (inline index-for-hashing))
+(defun index-for-hashing (index length)
+  (declare (type index index length))
+  ;; We're using power of two tables which obviously are very
+  ;; sensitive to the exact values of the low bits in the hash
+  ;; value. Do a little shuffling of the value to mix the high bits in
+  ;; there too.
+  (logand (1- length)
+          (+ (logxor #b11100101010001011010100111
+                     index)
+             (ash index -6)
+             (ash index -15)
+             (ash index -23))))
+
 
 ;;;; user-defined hash table tests
 
@@ -193,7 +220,7 @@
            ;; Note that this has not yet been audited for
            ;; correctness. It just seems to work. -- CSR, 2002-11-02
            (scaled-size (truncate (/ (float size+1) rehash-threshold)))
-           (length (almost-primify (max scaled-size
+           (length (ceil-power-of-two (max scaled-size
                                         (1+ +min-hash-table-size+))))
            (index-vector (make-array length
                                      :element-type
@@ -232,7 +259,6 @@
         (setf (aref next-vector i) (1+ i)))
       (setf (aref next-vector size) 0)
       (setf (hash-table-next-free-kv table) 1)
-      (setf (hash-table-needing-rehash table) 0)
       (setf (aref kv-vector 0) table)
       table)))
 
@@ -266,6 +292,13 @@
 (setf (fdocumentation 'hash-table-weakness 'function)
       "Return the WEAKNESS of HASH-TABLE which is one of NIL, :KEY,
 :VALUE, :KEY-AND-VALUE, :KEY-OR-VALUE.")
+
+;;; Called when we detect circular chains in a hash-table.
+(defun signal-corrupt-hash-table (hash-table)
+  (error "Corrupt NEXT-chain in ~A. This is probably caused by ~
+multiple threads accessing the same hash-table without locking."
+         hash-table))
+
 
 ;;;; accessing functions
 
@@ -273,17 +306,19 @@
 ;;; rehash-size.
 (defun rehash (table)
   (declare (type hash-table table))
+  (aver *gc-inhibit*)
   (let* ((old-kv-vector (hash-table-table table))
          (old-next-vector (hash-table-next-vector table))
          (old-hash-vector (hash-table-hash-vector table))
          (old-size (length old-next-vector))
          (new-size
+          (ceil-power-of-two
           (let ((rehash-size (hash-table-rehash-size table)))
             (etypecase rehash-size
               (fixnum
                (+ rehash-size old-size))
               (float
-               (the index (truncate (* rehash-size old-size)))))))
+                (the index (truncate (* rehash-size old-size))))))))
          (new-kv-vector (make-array (* 2 new-size)
                                     :initial-element +empty-ht-slot+))
          (new-next-vector
@@ -295,10 +330,7 @@
             (make-array new-size
                         :element-type '(unsigned-byte #.sb!vm:n-word-bits)
                         :initial-element +magic-hash-vector-value+)))
-         (old-index-vector (hash-table-index-vector table))
-         (new-length (almost-primify
-                      (truncate (/ (float new-size)
-                                   (hash-table-rehash-threshold table)))))
+         (new-length new-size)
          (new-index-vector
           (make-array new-length
                       :element-type '(unsigned-byte #.sb!vm:n-word-bits)
@@ -329,7 +361,6 @@
         (setf (aref new-hash-vector i) (aref old-hash-vector i))))
 
     (setf (hash-table-next-free-kv table) 0)
-    (setf (hash-table-needing-rehash table) 0)
     ;; Rehash all the entries; last to first so that after the pushes
     ;; the chains are first to last.
     (do ((i (1- new-size) (1- i)))
@@ -348,7 +379,7 @@
                             +magic-hash-vector-value+)))
                ;; Can use the existing hash value (not EQ based)
                (let* ((hashing (aref new-hash-vector i))
-                      (index (rem hashing new-length))
+                      (index (index-for-hashing hashing new-length))
                       (next (aref new-index-vector index)))
                  (declare (type index index)
                           (type hash hashing))
@@ -361,7 +392,7 @@
                (set-header-data new-kv-vector
                                 sb!vm:vector-valid-hashing-subtype)
                (let* ((hashing (pointer-hash key))
-                      (index (rem hashing new-length))
+                      (index (index-for-hashing hashing new-length))
                       (next (aref new-index-vector index)))
                  (declare (type index index)
                           (type hash hashing))
@@ -372,18 +403,18 @@
     (setf (hash-table-index-vector table) new-index-vector)
     (setf (hash-table-next-vector table) new-next-vector)
     (setf (hash-table-hash-vector table) new-hash-vector)
-    ;; Shrink the old vectors to 0 size to help the conservative GC.
-    (%shrink-vector old-kv-vector 0)
-    (%shrink-vector old-index-vector 0)
-    (%shrink-vector old-next-vector 0)
-    (when old-hash-vector
-      (%shrink-vector old-hash-vector 0))
-    (setf (hash-table-rehash-trigger table) new-size))
+    ;; Fill the old kv-vector with 0 to help the conservative GC. Even
+    ;; if nothing else were zeroed, it's important to clear the
+    ;; special first cells in old-kv-vector.
+    (fill old-kv-vector 0)
+    (setf (hash-table-rehash-trigger table) new-size)
+    (setf (hash-table-needs-rehash-p table) nil))
   (values))
 
 ;;; Use the same size as before, re-using the vectors.
 (defun rehash-without-growing (table)
   (declare (type hash-table table))
+  (aver *gc-inhibit*)
   (let* ((kv-vector (hash-table-table table))
          (next-vector (hash-table-next-vector table))
          (hash-vector (hash-table-hash-vector table))
@@ -400,7 +431,6 @@
 
     ;; Rehash all the entries.
     (setf (hash-table-next-free-kv table) 0)
-    (setf (hash-table-needing-rehash table) 0)
     (dotimes (i size)
       (setf (aref next-vector i) 0))
     (dotimes (i length)
@@ -419,7 +449,7 @@
                                         +magic-hash-vector-value+)))
                ;; Can use the existing hash value (not EQ based)
                (let* ((hashing (aref hash-vector i))
-                      (index (rem hashing length))
+                      (index (index-for-hashing hashing length))
                       (next (aref index-vector index)))
                  (declare (type index index))
                  ;; Push this slot into the next chain.
@@ -430,32 +460,71 @@
                ;; Enable GC tricks.
                (set-header-data kv-vector sb!vm:vector-valid-hashing-subtype)
                (let* ((hashing (pointer-hash key))
-                      (index (rem hashing length))
+                      (index (index-for-hashing hashing length))
                       (next (aref index-vector index)))
                  (declare (type index index)
                           (type hash hashing))
                  ;; Push this slot into the next chain.
                  (setf (aref next-vector i) next)
                  (setf (aref index-vector index) i)))))))
+  ;; Clear the rehash bit only at the very end, otherwise another thread
+  ;; might see a partially rehashed table as a normal one.
+  (setf (hash-table-needs-rehash-p table) nil)
   (values))
 
-(defun flush-needing-rehash (table)
-  (let* ((kv-vector (hash-table-table table))
-         (index-vector (hash-table-index-vector table))
-         (next-vector (hash-table-next-vector table))
-         (length (length index-vector)))
-    (do ((next (hash-table-needing-rehash table)))
-        ((zerop next))
-      (declare (type index/2 next))
-      (let* ((key (aref kv-vector (* 2 next)))
-             (hashing (pointer-hash key))
-             (index (rem hashing length))
-             (temp (aref next-vector next)))
-        (setf (aref next-vector next) (aref index-vector index))
-        (setf (aref index-vector index) next)
-        (setf next temp))))
-  (setf (hash-table-needing-rehash table) 0)
-  (values))
+(declaim (inline maybe-rehash))
+(defun maybe-rehash (hash-table ensure-free-slot-p)
+  (when (hash-table-weakness hash-table)
+    (aver *gc-inhibit*))
+  (flet ((rehash-p ()
+           (and ensure-free-slot-p
+                (zerop (hash-table-next-free-kv hash-table))))
+         (rehash-without-growing-p ()
+           (hash-table-needs-rehash-p hash-table)))
+    (cond ((rehash-p)
+           ;; Use recursive spinlocks since for weak tables the
+           ;; spinlock has already been acquired. GC must be inhibited
+           ;; to prevent the GC from seeing a rehash in progress.
+           (sb!thread::with-recursive-system-spinlock
+               ((hash-table-spinlock hash-table) :without-gcing t)
+             ;; Repeat the condition inside the lock to ensure that if
+             ;; two reader threads enter MAYBE-REHASH at the same time
+             ;; only one rehash is performed.
+             (when (rehash-p)
+               (rehash hash-table))))
+          ((rehash-without-growing-p)
+           (sb!thread::with-recursive-system-spinlock
+               ((hash-table-spinlock hash-table) :without-gcing t)
+             (when (rehash-without-growing-p)
+               (without-gcing
+                 (rehash-without-growing hash-table))))))))
+
+(declaim (inline update-hash-table-cache))
+(defun update-hash-table-cache (hash-table index)
+  (unless (hash-table-weakness hash-table)
+    (setf (hash-table-cache hash-table) index)))
+
+(defmacro with-hash-table-locks ((hash-table inline &rest pin-objects)
+                                 &body body)
+  `(with-concurrent-access-check ,hash-table
+     ;; Inhibit GC for the duration of BODY if the GC might mutate the
+     ;; HASH-TABLE in some way (currently true only if the table is
+     ;; weak). We also need to lock the table to ensure that two
+     ;; concurrent writers can't create a cyclical vector that would
+     ;; cause scav_weak_hash_table_chain to loop.
+     ;;
+     ;; Otherwise we can avoid the 2x-3x overhead, and just pin the key.
+     (if (hash-table-weakness ,hash-table)
+         (sb!thread::with-recursive-system-spinlock
+             ((hash-table-spinlock hash-table) :without-gcing t)
+           ,@body)
+         (with-pinned-objects ,pin-objects
+           (locally
+               ;; Inline the implementation function on the fast path
+               ;; only. (On the slow path it'll just bloat the
+               ;; generated code with no benefit).
+               (declare (inline ,@inline))
+             ,@body)))))
 
 (defun gethash (key hash-table &optional default)
   #!+sb-doc
@@ -466,40 +535,50 @@
            (values t (member t nil)))
   (gethash3 key hash-table default))
 
-(defun gethash2 (key hash-table)
-  #!+sb-doc
-  "Two argument version of GETHASH"
-  (declare (type hash-table hash-table)
-           (values t (member t nil)))
-  (gethash3 key hash-table nil))
-
-(defun gethash3 (key hash-table default)
-  #!+sb-doc
-  "Three argument version of GETHASH"
+(declaim (maybe-inline %gethash3))
+(defun %gethash3 (key hash-table default)
   (declare (type hash-table hash-table)
+           (optimize speed)
            (values t (member t nil)))
-  (with-spinlock-and-without-gcing ((hash-table-spinlock hash-table))
-    gethash3
-    (cond ((= (get-header-data (hash-table-table hash-table))
-              sb!vm:vector-must-rehash-subtype)
-           (rehash-without-growing hash-table))
-          ((not (zerop (hash-table-needing-rehash hash-table)))
-           (flush-needing-rehash hash-table)))
-
-    ;; First check the cache.  Use EQ here for speed.
+  (tagbody
+   start
+     (let ((start-epoch sb!kernel::*gc-epoch*))
+       (macrolet ((result (value foundp)
+                    ;; When the table has multiple concurrent readers,
+                    ;; it's possible that there was a GC after this
+                    ;; thread called MAYBE-REHASH from %GETHASH3, and
+                    ;; some other thread then rehashed the table. If
+                    ;; this happens, we might not find the key even if
+                    ;; it's in the table. To protect against this,
+                    ;; redo the lookup if the GC epoch counter has changed.
+                    ;; -- JES,  2007-09-30
+                    `(if (and (not ,foundp)
+                              (not (eql start-epoch sb!kernel::*gc-epoch*)))
+                         (go start)
+                         (return-from %gethash3 (values ,value ,foundp))))
+                  (overflow ()
+                    ;; The next-vector chain is circular. This is caused
+                    ;; caused by thread-unsafe mutations of the table.
+                    `(signal-corrupt-hash-table hash-table)))
+         (maybe-rehash hash-table nil)
+         ;; Note that it's OK for a GC + a REHASH-WITHOUT-GROWING to
+         ;; be triggered by another thread after this point, since the
+         ;; GC epoch check will catch it.
     (let ((cache (hash-table-cache hash-table))
           (table (hash-table-table hash-table)))
-
-      (if (and cache (< cache (length table)) (eq (aref table cache) key))
-          (values (aref table (1+ cache)) t)
-
+           ;; First check the cache.  Use EQ here for speed.
+           (if (and cache
+                    (< cache (length table))
+                    (eq (aref table cache) key))
+               (let ((value (aref table (1+ cache))))
+                 (result value t))
           ;; Search for key in the hash table.
           (multiple-value-bind (hashing eq-based)
               (funcall (hash-table-hash-fun hash-table) key)
             (declare (type hash hashing))
             (let* ((index-vector (hash-table-index-vector hash-table))
                    (length (length index-vector))
-                   (index (rem hashing length))
+                        (index (index-for-hashing hashing length))
                    (next (aref index-vector index))
                    (next-vector (hash-table-next-vector hash-table))
                    (hash-vector (hash-table-hash-vector hash-table))
@@ -507,58 +586,55 @@
               (declare (type index index))
               ;; Search next-vector chain for a matching key.
               (if (or eq-based (not hash-vector))
-                  (do ((next next (aref next-vector next)))
-                      ((zerop next) (values default nil))
-                    (declare (type index/2 next))
+                       (do ((next next (aref next-vector next))
+                            (i 0 (1+ i)))
+                           ((zerop next) (result default nil))
+                         (declare (type index/2 next i))
+                         (when (> i length)
+                           (overflow))
                     (when (eq key (aref table (* 2 next)))
-                      (setf (hash-table-cache hash-table) (* 2 next))
-                      (return (values (aref table (1+ (* 2 next))) t))))
-                  (do ((next next (aref next-vector next)))
-                      ((zerop next) (values default nil))
-                    (declare (type index/2 next))
+                           (update-hash-table-cache hash-table (* 2 next))
+                           (let ((value (aref table (1+ (* 2 next)))))
+                             (result value t))))
+                       (do ((next next (aref next-vector next))
+                            (i 0 (1+ i)))
+                           ((zerop next) (result default nil))
+                         (declare (type index/2 next i))
+                         (when (> i length)
+                           (overflow))
                     (when (and (= hashing (aref hash-vector next))
-                               (funcall test-fun key (aref table (* 2 next))))
+                                    (funcall test-fun key
+                                             (aref table (* 2 next))))
                       ;; Found.
-                      (setf (hash-table-cache hash-table) (* 2 next))
-                      (return (values (aref table (1+ (* 2 next))) t)))))))))))
+                           (update-hash-table-cache hash-table (* 2 next))
+                           (let ((value (aref table (1+ (* 2 next)))))
+                             (result value t)))))))))))))
+
+(defun gethash3 (key hash-table default)
+  "Three argument version of GETHASH"
+  (declare (type hash-table hash-table))
+  (with-hash-table-locks (hash-table (%gethash3) key)
+    (%gethash3 key hash-table default)))
 
 ;;; so people can call #'(SETF GETHASH)
 (defun (setf gethash) (new-value key table &optional default)
   (declare (ignore default))
   (%puthash key table new-value))
 
-(defun %puthash (key hash-table value)
-  (declare (type hash-table hash-table))
-  (aver (hash-table-index-vector hash-table))
-  (with-spinlock-and-without-gcing ((hash-table-spinlock hash-table))
-    %puthash
+(declaim (maybe-inline %%puthash))
+(defun %%puthash (key hash-table value)
+  (declare (optimize speed))
     ;; We need to rehash here so that a current key can be found if it
     ;; exists. Check that there is room for one more entry. May not be
     ;; needed if the key is already present.
-    (cond ((zerop (hash-table-next-free-kv hash-table))
-           (rehash hash-table))
-          ((= (get-header-data (hash-table-table hash-table))
-              sb!vm:vector-must-rehash-subtype)
-           (rehash-without-growing hash-table))
-          ((not (zerop (hash-table-needing-rehash hash-table)))
-           (flush-needing-rehash hash-table)))
-
-    (let ((cache (hash-table-cache hash-table))
-          (kv-vector (hash-table-table hash-table)))
-
-      ;; Check the cache
-      (if (and cache (< cache (length kv-vector))
-               (eq (aref kv-vector cache) key))
-          ;; If cached, just store here
-          (setf (aref kv-vector (1+ cache)) value)
-
+  (maybe-rehash hash-table t)
           ;; Search for key in the hash table.
           (multiple-value-bind (hashing eq-based)
               (funcall (hash-table-hash-fun hash-table) key)
             (declare (type hash hashing))
             (let* ((index-vector (hash-table-index-vector hash-table))
                    (length (length index-vector))
-                   (index (rem hashing length))
+           (index (index-for-hashing hashing length))
                    (next (aref index-vector index))
                    (kv-vector (hash-table-table hash-table))
                    (next-vector (hash-table-next-vector hash-table))
@@ -571,29 +647,33 @@
                      (when eq-based
                        (set-header-data kv-vector
                                         sb!vm:vector-valid-hashing-subtype))
-
                      ;; Search next-vector chain for a matching key.
-                     (do ((next next (aref next-vector next)))
+             (do ((next next (aref next-vector next))
+                  (i 0 (1+ i)))
                          ((zerop next))
-                       (declare (type index/2 next))
+               (declare (type index/2 next i))
+               (when (> i length)
+                 (signal-corrupt-hash-table hash-table))
                        (when (eq key (aref kv-vector (* 2 next)))
                          ;; Found, just replace the value.
-                         (setf (hash-table-cache hash-table) (* 2 next))
+                 (update-hash-table-cache hash-table (* 2 next))
                          (setf (aref kv-vector (1+ (* 2 next))) value)
-                         (return-from %puthash value))))
+                 (return-from %%puthash value))))
                     (t
                      ;; Search next-vector chain for a matching key.
-                     (do ((next next (aref next-vector next)))
+             (do ((next next (aref next-vector next))
+                  (i 0 (1+ i)))
                          ((zerop next))
-                       (declare (type index/2 next))
+               (declare (type index/2 next i))
+               (when (> i length)
+                 (signal-corrupt-hash-table hash-table))
                        (when (and (= hashing (aref hash-vector next))
                                   (funcall test-fun key
                                            (aref kv-vector (* 2 next))))
                          ;; Found, just replace the value.
-                         (setf (hash-table-cache hash-table) (* 2 next))
+                 (update-hash-table-cache hash-table (* 2 next))
                          (setf (aref kv-vector (1+ (* 2 next))) value)
-                         (return-from %puthash value)))))
-
+                 (return-from %%puthash value)))))
               ;; Pop a KV slot off the free list
               (let ((free-kv-slot (hash-table-next-free-kv hash-table)))
                 (declare (type index/2 free-kv-slot))
@@ -602,49 +682,53 @@
                 (setf (hash-table-next-free-kv hash-table)
                       (aref next-vector free-kv-slot))
                 (incf (hash-table-number-entries hash-table))
-
-                (setf (hash-table-cache hash-table) (* 2 free-kv-slot))
+        (update-hash-table-cache hash-table (* 2 free-kv-slot))
                 (setf (aref kv-vector (* 2 free-kv-slot)) key)
                 (setf (aref kv-vector (1+ (* 2 free-kv-slot))) value)
-
                 ;; Setup the hash-vector if necessary.
                 (when hash-vector
                   (if (not eq-based)
                       (setf (aref hash-vector free-kv-slot) hashing)
                       (aver (= (aref hash-vector free-kv-slot)
                                +magic-hash-vector-value+))))
-
                 ;; Push this slot into the next chain.
                 (setf (aref next-vector free-kv-slot) next)
-                (setf (aref index-vector index) free-kv-slot)))))))
-  value)
+        (setf (aref index-vector index) free-kv-slot)))
+    value))
 
-(defun remhash (key hash-table)
-  #!+sb-doc
-  "Remove the entry in HASH-TABLE associated with KEY. Return T if there
-   was such an entry, or NIL if not."
-  (declare (type hash-table hash-table)
-           (values (member t nil)))
-  (with-spinlock-and-without-gcing ((hash-table-spinlock hash-table))
-    remhash
+(defun %puthash (key hash-table value)
+  (declare (type hash-table hash-table))
+  (aver (hash-table-index-vector hash-table))
+  (let ((cache (hash-table-cache hash-table))
+        (kv-vector (hash-table-table hash-table)))
+    ;; Check the cache
+    (if (and cache
+             (< cache (length kv-vector))
+             (eq (aref kv-vector cache) key))
+        ;; If cached, just store here
+        (setf (aref kv-vector (1+ cache)) value)
+        ;; Otherwise do things the hard way
+        (with-hash-table-locks (hash-table (%%puthash) key)
+          (%%puthash key hash-table value)))))
+
+(declaim (maybe-inline %remhash))
+(defun %remhash (key hash-table)
     ;; We need to rehash here so that a current key can be found if it
     ;; exists.
-    (cond ((= (get-header-data (hash-table-table hash-table))
-              sb!vm:vector-must-rehash-subtype)
-           (rehash-without-growing hash-table))
-          ((not (zerop (hash-table-needing-rehash hash-table)))
-           (flush-needing-rehash hash-table)))
-
-    ;; For now, just clear the cache
-    (setf (hash-table-cache hash-table) nil)
-
+  ;;
+  ;; Note that if a GC happens after MAYBE-REHASH returns and another
+  ;; thread the accesses the table (triggering a rehash), we might not
+  ;; find the key even if it is in the table. But that's ok, since the
+  ;; only concurrent case that we safely allow is multiple readers
+  ;; with no writers.
+  (maybe-rehash hash-table nil)
     ;; Search for key in the hash table.
     (multiple-value-bind (hashing eq-based)
         (funcall (hash-table-hash-fun hash-table) key)
       (declare (type hash hashing))
       (let* ((index-vector (hash-table-index-vector hash-table))
              (length (length index-vector))
-             (index (rem hashing length))
+           (index (index-for-hashing hashing length))
              (next (aref index-vector index))
              (table (hash-table-table hash-table))
              (next-vector (hash-table-next-vector hash-table))
@@ -680,29 +764,44 @@
                 ((or eq-based (not hash-vector))
                  ;; EQ based
                  (do ((prior next next)
+                    (i 0 (1+ i))
                       (next (aref next-vector next) (aref next-vector next)))
                      ((zerop next) nil)
                    (declare (type index next))
+                 (when (> i length)
+                   (signal-corrupt-hash-table hash-table))
                    (when (eq key (aref table (* 2 next)))
-                     (return-from remhash (clear-slot next-vector prior next)))))
+                   (return-from %remhash (clear-slot next-vector prior next)))))
                 (t
                  ;; not EQ based
                  (do ((prior next next)
+                    (i 0 (1+ i))
                       (next (aref next-vector next) (aref next-vector next)))
                      ((zerop next) nil)
                    (declare (type index/2 next))
+                 (when (> i length)
+                   (signal-corrupt-hash-table hash-table))
                    (when (and (= hashing (aref hash-vector next))
                               (funcall test-fun key (aref table (* 2 next))))
-                     (return-from remhash
-                       (clear-slot next-vector prior next)))))))))))
+                   (return-from %remhash
+                     (clear-slot next-vector prior next))))))))))
+
+(defun remhash (key hash-table)
+  #!+sb-doc
+  "Remove the entry in HASH-TABLE associated with KEY. Return T if there
+   was such an entry, or NIL if not."
+  (declare (type hash-table hash-table)
+           (values (member t nil)))
+  ;; For now, just clear the cache
+  (setf (hash-table-cache hash-table) nil)
+  (with-hash-table-locks (hash-table (%remhash) key)
+    (%remhash key hash-table)))
 
 (defun clrhash (hash-table)
   #!+sb-doc
   "This removes all the entries from HASH-TABLE and returns the hash table
    itself."
-  (declare (optimize speed))
-  (with-spinlock-and-without-gcing ((hash-table-spinlock hash-table))
-    clrhash
+  (with-hash-table-locks (hash-table nil)
     (let* ((kv-vector (hash-table-table hash-table))
            (next-vector (hash-table-next-vector hash-table))
            (hash-vector (hash-table-hash-vector hash-table))
@@ -720,15 +819,15 @@
         (setf (aref next-vector i) (1+ i)))
       (setf (aref next-vector (1- size)) 0)
       (setf (hash-table-next-free-kv hash-table) 1)
-      (setf (hash-table-needing-rehash hash-table) 0)
       ;; Clear the index-vector.
       (fill index-vector 0)
       ;; Clear the hash-vector.
       (when hash-vector
         (fill hash-vector +magic-hash-vector-value+)))
     (setf (hash-table-cache hash-table) nil)
-    (setf (hash-table-number-entries hash-table) 0))
-  hash-table)
+    (setf (hash-table-number-entries hash-table) 0)
+    hash-table))
+
 
 ;;;; MAPHASH
 
@@ -810,3 +909,5 @@
   (declare (ignore environment))
   (values `(make-hash-table ,@(%hash-table-ctor-args hash-table))
           `(%stuff-hash-table ,hash-table ',(%hash-table-alist hash-table))))
+
+

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv12016

Modified Files:
	NEWS base-target-features.lisp-expr version.lisp-expr 
Log Message:
1.0.10.14: remove locking and gc inhibition from hash-tables, power of 2 sizes

        This commit removes a bunch of bottlenecks from the hash-table
        implementation. It speeds up GETHASH, (SETF GETHASH) and
        REMHASH by a factor of 2-4x (on platforms with a real
        WITH-PINNED-OBJECTS) depending on the operation. On the flip
        side, no automatic locking is done on tables any more, so
        multi-threaded applications must do their own locking. (The
        locking done by SBCL was always just an implementation detail,
        not a part of the external interface). By popular demand it's
        also still safe to have multiple readers on the same table
        without locking.

	Originally GCs were inhibited during most hash-table
        operations for two reasons. To prevent the GC from rehashing a
        table while a Lisp-side operation is going on, and to prevent
        the GC from moving the key after the hash-value has been
        calculated.

        More recently, most hash-tables operations have acquired a
        lock on the table in order to prevent two concurrent writers
        from corrupting the chains. While it's never been the intent
        for the standard data structures to be automatically
        thread-safe in SBCL, this locking had to be done since corrupt
        tables could lead to infinite GC loops.

        Both the locking and the without-gcing are expensive
        operations relative to the total cost of a hash-table lookup.
        This commit removes both the gc inhibition and the locks.
        Additionally we switch to power of two table size, which
        allows calculating a cheaper hash -> bucket with cheaper
        operations than MOD.

        * The GC no longer does the rehashing itself, but just marks
          the hash-table as needing a rehash, which will then be done
          Lisp-side when the table is next accessed. While it's
          possible to find cases where the former behaviour has better
          performance, they're very contrived.
        * The hash-table operations that work on the chains now check
          for loops in the chains, and signal an error if one is found.
        * The hash-table operations now pin the key before calculating
          the hash value (needed for EQ-based hash functions).
        * Add a GC epoch value that GETHASH can use to check whether
          a GC happened during the lookup. This is needed since another
          thread calling GETHASH on the same table might have caused it
          to be rehashed.
        * Kill the old MUST-REHASH vector header, and replace it with a
          slot in the HASH-TABLE structure. The overloading of the header
          caused missed rehashings when both the GC and %%PUTHASH modified
          it at the same time.
        * Switch to power of two table sizes, with a slightly more complex
          hash value -> bucket calculation than just taking the low bits,
          which in many cases have a very skewed distribution for the existing
          SBCL hash functions. Still a lot faster than using MOD.
        * Leave in locking and GC inhibition during rehashing (needed to
          allow multiple readers to coexist) and for weak hash-tables
          (they need some GC support, and the code is much simpler when
          all of the logic is in the GC instead of interleaved in the GC and 
          Lisp-side). Neither of these cases is performance critical.



Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.1254
retrieving revision 1.1255
diff -u -d -r1.1254 -r1.1255
--- NEWS	27 Sep 2007 15:50:43 -0000	1.1254
+++ NEWS	30 Sep 2007 23:18:50 -0000	1.1255
@@ -1,5 +1,12 @@
 ;;;; -*- coding: utf-8; -*-
 changes in sbcl-1.0.11 relative to sbcl-1.0.10:
+  * incompatible change: hash-table accessor functions are no longer
+    automatically protected by locks. Concurrent accesses on the same hash-table
+    from multiple threads can give inconsistent results or even corrupt the
+    hash-table completely. Multi-threaded applications should do their own
+    locking at the correct granularity. In the current implementation it is
+    still safe to have multiple readers access the same table, but it's not
+    guaranteed that this property will be maintained in future releases.
   * enhancement: CONS can now stack-allocate on x86 and
     x86-64. (Earlier LIST and LIST* supported stack-allocation, but
     CONS did not.)

Index: base-target-features.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/base-target-features.lisp-expr,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -d -r1.46 -r1.47
--- base-target-features.lisp-expr	2 Sep 2007 03:04:32 -0000	1.46
+++ base-target-features.lisp-expr	30 Sep 2007 23:18:50 -0000	1.47
@@ -138,6 +138,13 @@
  ;; anyone who wants to collect such statistics in the future.
  ; :sb-dyncount
 
+ ;; Enable code for detecting concurrent accesses to the same hash-table
+ ;; in multiple threads. Note that this implementation is currently
+ ;; (2007-09-11) somewhat too eager: even though in the current implementation
+ ;; multiple readers are thread safe as long as there are no writers, this
+ ;; code will also trap multiple readers.
+ ; :sb-hash-table-debug
+
  ;; Peter Van Eynde's increase-bulletproofness code for CMU CL
  ;;
  ;; Some of the code which was #+high-security before the fork has now

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.3652
retrieving revision 1.3653
diff -u -d -r1.3652 -r1.3653
--- version.lisp-expr	29 Sep 2007 13:27:29 -0000	1.3652
+++ version.lisp-expr	30 Sep 2007 23:18:50 -0000	1.3653
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.10.13"
+"1.0.10.14"

Update of /cvsroot/sbcl/sbcl/src/compiler/generic
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv12016/src/compiler/generic

Modified Files:
	early-objdef.lisp genesis.lisp 
Log Message:
1.0.10.14: remove locking and gc inhibition from hash-tables, power of 2 sizes

        This commit removes a bunch of bottlenecks from the hash-table
        implementation. It speeds up GETHASH, (SETF GETHASH) and
        REMHASH by a factor of 2-4x (on platforms with a real
        WITH-PINNED-OBJECTS) depending on the operation. On the flip
        side, no automatic locking is done on tables any more, so
        multi-threaded applications must do their own locking. (The
        locking done by SBCL was always just an implementation detail,
        not a part of the external interface). By popular demand it's
        also still safe to have multiple readers on the same table
        without locking.

	Originally GCs were inhibited during most hash-table
        operations for two reasons. To prevent the GC from rehashing a
        table while a Lisp-side operation is going on, and to prevent
        the GC from moving the key after the hash-value has been
        calculated.

        More recently, most hash-tables operations have acquired a
        lock on the table in order to prevent two concurrent writers
        from corrupting the chains. While it's never been the intent
        for the standard data structures to be automatically
        thread-safe in SBCL, this locking had to be done since corrupt
        tables could lead to infinite GC loops.

        Both the locking and the without-gcing are expensive
        operations relative to the total cost of a hash-table lookup.
        This commit removes both the gc inhibition and the locks.
        Additionally we switch to power of two table size, which
        allows calculating a cheaper hash -> bucket with cheaper
        operations than MOD.

        * The GC no longer does the rehashing itself, but just marks
          the hash-table as needing a rehash, which will then be done
          Lisp-side when the table is next accessed. While it's
          possible to find cases where the former behaviour has better
          performance, they're very contrived.
        * The hash-table operations that work on the chains now check
          for loops in the chains, and signal an error if one is found.
        * The hash-table operations now pin the key before calculating
          the hash value (needed for EQ-based hash functions).
        * Add a GC epoch value that GETHASH can use to check whether
          a GC happened during the lookup. This is needed since another
          thread calling GETHASH on the same table might have caused it
          to be rehashed.
        * Kill the old MUST-REHASH vector header, and replace it with a
          slot in the HASH-TABLE structure. The overloading of the header
          caused missed rehashings when both the GC and %%PUTHASH modified
          it at the same time.
        * Switch to power of two table sizes, with a slightly more complex
          hash value -> bucket calculation than just taking the low bits,
          which in many cases have a very skewed distribution for the existing
          SBCL hash functions. Still a lot faster than using MOD.
        * Leave in locking and GC inhibition during rehashing (needed to
          allow multiple readers to coexist) and for weak hash-tables
          (they need some GC support, and the code is much simpler when
          all of the logic is in the GC instead of interleaved in the GC and 
          Lisp-side). Neither of these cases is performance critical.



Index: early-objdef.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/generic/early-objdef.lisp,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -d -r1.30 -r1.31
--- early-objdef.lisp	10 Jun 2006 05:07:24 -0000	1.30
+++ early-objdef.lisp	30 Sep 2007 23:18:51 -0000	1.31
@@ -222,5 +222,4 @@
 (defenum (:prefix vector- :suffix -subtype)
   normal
   unused
-  valid-hashing
-  must-rehash)
+  valid-hashing)

Index: genesis.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/generic/genesis.lisp,v
retrieving revision 1.136
retrieving revision 1.137
diff -u -d -r1.136 -r1.137
--- genesis.lisp	1 Sep 2007 23:37:42 -0000	1.136
+++ genesis.lisp	30 Sep 2007 23:18:51 -0000	1.137
@@ -2729,7 +2729,6 @@
                   (symbol-value c)
                   nil)
             constants))
-
     (setf constants
           (sort constants
                 (lambda (const1 const2)

Update of /cvsroot/sbcl/sbcl/src/runtime
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv12016/src/runtime

Modified Files:
	gc-common.c 
Log Message:
1.0.10.14: remove locking and gc inhibition from hash-tables, power of 2 sizes

        This commit removes a bunch of bottlenecks from the hash-table
        implementation. It speeds up GETHASH, (SETF GETHASH) and
        REMHASH by a factor of 2-4x (on platforms with a real
        WITH-PINNED-OBJECTS) depending on the operation. On the flip
        side, no automatic locking is done on tables any more, so
        multi-threaded applications must do their own locking. (The
        locking done by SBCL was always just an implementation detail,
        not a part of the external interface). By popular demand it's
        also still safe to have multiple readers on the same table
        without locking.

	Originally GCs were inhibited during most hash-table
        operations for two reasons. To prevent the GC from rehashing a
        table while a Lisp-side operation is going on, and to prevent
        the GC from moving the key after the hash-value has been
        calculated.

        More recently, most hash-tables operations have acquired a
        lock on the table in order to prevent two concurrent writers
        from corrupting the chains. While it's never been the intent
        for the standard data structures to be automatically
        thread-safe in SBCL, this locking had to be done since corrupt
        tables could lead to infinite GC loops.

        Both the locking and the without-gcing are expensive
        operations relative to the total cost of a hash-table lookup.
        This commit removes both the gc inhibition and the locks.
        Additionally we switch to power of two table size, which
        allows calculating a cheaper hash -> bucket with cheaper
        operations than MOD.

        * The GC no longer does the rehashing itself, but just marks
          the hash-table as needing a rehash, which will then be done
          Lisp-side when the table is next accessed. While it's
          possible to find cases where the former behaviour has better
          performance, they're very contrived.
        * The hash-table operations that work on the chains now check
          for loops in the chains, and signal an error if one is found.
        * The hash-table operations now pin the key before calculating
          the hash value (needed for EQ-based hash functions).
        * Add a GC epoch value that GETHASH can use to check whether
          a GC happened during the lookup. This is needed since another
          thread calling GETHASH on the same table might have caused it
          to be rehashed.
        * Kill the old MUST-REHASH vector header, and replace it with a
          slot in the HASH-TABLE structure. The overloading of the header
          caused missed rehashings when both the GC and %%PUTHASH modified
          it at the same time.
        * Switch to power of two table sizes, with a slightly more complex
          hash value -> bucket calculation than just taking the low bits,
          which in many cases have a very skewed distribution for the existing
          SBCL hash functions. Still a lot faster than using MOD.
        * Leave in locking and GC inhibition during rehashing (needed to
          allow multiple readers to coexist) and for weak hash-tables
          (they need some GC support, and the code is much simpler when
          all of the logic is in the GC instead of interleaved in the GC and 
          Lisp-side). Neither of these cases is performance critical.



Index: gc-common.c
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/gc-common.c,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -d -r1.47 -r1.48
--- gc-common.c	9 Sep 2007 12:39:23 -0000	1.47
+++ gc-common.c	30 Sep 2007 23:18:51 -0000	1.48
@@ -1685,66 +1685,14 @@
             /* Scavenge the key and value. */
             scavenge(&kv_vector[2*i],2);
 
-            /* Rehashing of EQ based keys. */
-            if ((!hash_vector) ||
-                (hash_vector[i] == MAGIC_HASH_VECTOR_VALUE)) {
-#ifndef LISP_FEATURE_GENCGC
-                /* For GENCGC scav_hash_table_entries only rehashes
-                 * the entries whose keys were moved. Cheneygc always
-                 * moves the objects so here we let the lisp side know
-                 * that rehashing is needed for the whole table. */
-                *(kv_vector - 2) = (subtype_VectorMustRehash<<N_WIDETAG_BITS) |
-                    SIMPLE_VECTOR_WIDETAG;
-#else
-                unsigned long old_index = EQ_HASH(old_key)%length;
+            /* If an EQ-based key has moved, mark the hash-table for
+             * rehashing. */
+            if (!hash_vector || hash_vector[i] == MAGIC_HASH_VECTOR_VALUE) {
                 lispobj new_key = kv_vector[2*i];
-                unsigned long new_index = EQ_HASH(new_key)%length;
-                /* Check whether the key has moved. */
-                if ((old_index != new_index) &&
-                    (new_key != empty_symbol)) {
-                    gc_assert(kv_vector[2*i+1] != empty_symbol);
 
-                    /*FSHOW((stderr,
-                      "* EQ key %d moved from %x to %x; index %d to %d\n",
-                      i, old_key, new_key, old_index, new_index));*/
-
-                    /* Unlink the key from the old_index chain. */
-                    if (!index_vector[old_index]) {
-                        /* It's not here, must be on the
-                         * needing_rehash chain. */
-                    } else if (index_vector[old_index] == i) {
-                        /*FSHOW((stderr, "/P2a %d\n", next_vector[i]));*/
-                        index_vector[old_index] = next_vector[i];
-                        /* Link it into the needing rehash chain. */
-                        next_vector[i] =
-                            fixnum_value(hash_table->needing_rehash);
-                        hash_table->needing_rehash = make_fixnum(i);
-                        /*SHOW("P2");*/
-                    } else {
-                        unsigned long prior = index_vector[old_index];
-                        unsigned long next = next_vector[prior];
-
-                        /*FSHOW((stderr, "/P3a %d %d\n", prior, next));*/
-
-                        while (next != 0) {
-                            /*FSHOW((stderr, "/P3b %d %d\n", prior, next));*/
-                            if (next == i) {
-                                /* Unlink it. */
-                                next_vector[prior] = next_vector[next];
-                                /* Link it into the needing rehash
-                                 * chain. */
-                                next_vector[next] =
-                                    fixnum_value(hash_table->needing_rehash);
-                                hash_table->needing_rehash = make_fixnum(next);
-                                /*SHOW("/P3");*/
-                                break;
-                            }
-                            prior = next;
-                            next = next_vector[next];
-                        }
-                    }
+                if (old_key != new_key && new_key != empty_symbol) {
+                    hash_table->needs_rehash_p = T;
                 }
-#endif
             }
         }
     }
@@ -1770,7 +1718,13 @@
     /* Scavenge element 0, which may be a hash-table structure. */
     scavenge(where+2, 1);
     if (!is_lisp_pointer(where[2])) {
-        lose("no pointer at %x in hash table\n", where[2]);
+        /* This'll happen when REHASH clears the header of old-kv-vector
+         * and fills it with zero, but some other thread simulatenously
+         * sets the header in %%PUTHASH.
+         */
+        fprintf(stderr, "Warning: no pointer at %x in hash table: this indicates non-fatal corruption caused by concurrent access to a hash-table from multiple threads. Any accesses to hash-tables shared between threads should be protected by locks.\n", &where[2]);
+        // We've scavenged three words.
+        return 3;
     }
     hash_table = (struct hash_table *)native_pointer(where[2]);
     /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
@@ -1886,13 +1840,6 @@
                                    kv_vector, index_vector, next_vector,
                                    hash_vector, empty_symbol, weakness);
     }
-    {
-        lispobj first = fixnum_value(hash_table->needing_rehash);
-        scan_weak_hash_table_chain(hash_table, &first,
-                                   kv_vector, index_vector, next_vector,
-                                   hash_vector, empty_symbol, weakness);
-        hash_table->needing_rehash = make_fixnum(first);
-    }
 }
 
 /* Remove dead entries from weak hash tables. */

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv12016/src/compiler

Modified Files:
	srctran.lisp 
Log Message:
1.0.10.14: remove locking and gc inhibition from hash-tables, power of 2 sizes

        This commit removes a bunch of bottlenecks from the hash-table
        implementation. It speeds up GETHASH, (SETF GETHASH) and
        REMHASH by a factor of 2-4x (on platforms with a real
        WITH-PINNED-OBJECTS) depending on the operation. On the flip
        side, no automatic locking is done on tables any more, so
        multi-threaded applications must do their own locking. (The
        locking done by SBCL was always just an implementation detail,
        not a part of the external interface). By popular demand it's
        also still safe to have multiple readers on the same table
        without locking.

	Originally GCs were inhibited during most hash-table
        operations for two reasons. To prevent the GC from rehashing a
        table while a Lisp-side operation is going on, and to prevent
        the GC from moving the key after the hash-value has been
        calculated.

        More recently, most hash-tables operations have acquired a
        lock on the table in order to prevent two concurrent writers
        from corrupting the chains. While it's never been the intent
        for the standard data structures to be automatically
        thread-safe in SBCL, this locking had to be done since corrupt
        tables could lead to infinite GC loops.

        Both the locking and the without-gcing are expensive
        operations relative to the total cost of a hash-table lookup.
        This commit removes both the gc inhibition and the locks.
        Additionally we switch to power of two table size, which
        allows calculating a cheaper hash -> bucket with cheaper
        operations than MOD.

        * The GC no longer does the rehashing itself, but just marks
          the hash-table as needing a rehash, which will then be done
          Lisp-side when the table is next accessed. While it's
          possible to find cases where the former behaviour has better
          performance, they're very contrived.
        * The hash-table operations that work on the chains now check
          for loops in the chains, and signal an error if one is found.
        * The hash-table operations now pin the key before calculating
          the hash value (needed for EQ-based hash functions).
        * Add a GC epoch value that GETHASH can use to check whether
          a GC happened during the lookup. This is needed since another
          thread calling GETHASH on the same table might have caused it
          to be rehashed.
        * Kill the old MUST-REHASH vector header, and replace it with a
          slot in the HASH-TABLE structure. The overloading of the header
          caused missed rehashings when both the GC and %%PUTHASH modified
          it at the same time.
        * Switch to power of two table sizes, with a slightly more complex
          hash value -> bucket calculation than just taking the low bits,
          which in many cases have a very skewed distribution for the existing
          SBCL hash functions. Still a lot faster than using MOD.
        * Leave in locking and GC inhibition during rehashing (needed to
          allow multiple readers to coexist) and for weak hash-tables
          (they need some GC support, and the code is much simpler when
          all of the logic is in the GC instead of interleaved in the GC and 
          Lisp-side). Neither of these cases is performance critical.



Index: srctran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/srctran.lisp,v
retrieving revision 1.150
retrieving revision 1.151
diff -u -d -r1.150 -r1.151
--- srctran.lisp	30 Jun 2007 09:21:26 -0000	1.150
+++ srctran.lisp	30 Sep 2007 23:18:51 -0000	1.151
@@ -145,7 +145,7 @@
 (define-source-transform last (x) `(sb!impl::last1 ,x))
 (define-source-transform gethash (&rest args)
   (case (length args)
-   (2 `(sb!impl::gethash2 ,@args))
+   (2 `(sb!impl::gethash3 ,@args nil))
    (3 `(sb!impl::gethash3 ,@args))
    (t (values nil t))))
 (define-source-transform get (&rest args)

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv14866

Modified Files:
	version.lisp-expr 
Log Message:
1.0.10.13: trivial change: Print more explicit message upon entering LDB.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.3651
retrieving revision 1.3652
diff -u -d -r1.3651 -r1.3652
--- version.lisp-expr	28 Sep 2007 12:56:23 -0000	1.3651
+++ version.lisp-expr	29 Sep 2007 13:27:29 -0000	1.3652
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.10.12"
+"1.0.10.13"

Update of /cvsroot/sbcl/sbcl/src/runtime
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv14866/src/runtime

Modified Files:
	monitor.c 
Log Message:
1.0.10.13: trivial change: Print more explicit message upon entering LDB.


Index: monitor.c
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/monitor.c,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -d -r1.35 -r1.36
--- monitor.c	3 Jan 2006 09:52:38 -0000	1.35
+++ monitor.c	29 Sep 2007 13:27:30 -0000	1.36
@@ -500,7 +500,7 @@
 
     bcopy(curbuf, oldbuf, sizeof(oldbuf));
 
-    printf("LDB monitor\n");
+    printf("Welcome to LDB, a low-level debugger for the Lisp runtime environment.\n");
 
     setjmp(curbuf);

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv16941

Modified Files:
	BUGS version.lisp-expr 
Log Message:
1.0.10.12: logged bug 417


Index: BUGS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/BUGS,v
retrieving revision 1.517
retrieving revision 1.518
diff -u -d -r1.517 -r1.518
--- BUGS	20 Jun 2007 19:05:53 -0000	1.517
+++ BUGS	28 Sep 2007 12:56:23 -0000	1.518
@@ -1843,6 +1843,19 @@
     1: (SB-KERNEL:FDEFINITION-OBJECT 13 NIL)
   as the second frame.
 
-
-
-
+417: Toplevel NIL expressions mess up unreachable code reporting.
+	In sbcl-1.0.10.7, COMPILE-FILE on the file
+		nil
+		(defmethod frob ((package package) stream)
+		  (if (string= (package-name package) "FOO")
+		      (pprint-logical-block (stream nil))
+		      (print-unreadable-object (package stream))))
+	causes complaints like
+		; in: SOME SB-C::STRANGE SB-C::PLACE
+		;     (SB-C::UNABLE SB-C::TO SB-C::LOCATE SB-C::SOURCE)
+		; 
+		; note: deleting unreachable code
+		; 
+		; note: deleting unreachable code
+	Deleting the toplevel NIL, or even replacing it with 3,
+	causes the system not to complain.

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.3650
retrieving revision 1.3651
diff -u -d -r1.3650 -r1.3651
--- version.lisp-expr	27 Sep 2007 19:25:25 -0000	1.3650
+++ version.lisp-expr	28 Sep 2007 12:56:23 -0000	1.3651
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.10.11"
+"1.0.10.12"

Update of /cvsroot/sbcl/sbcl-page
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv9017

Modified Files:
	index-page.lisp platform-support-platforms.lisp 
Log Message:
1.0.10 release, x86 darwin/linux, x86-64 linux and ppc netbsd binaries


Index: index-page.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl-page/index-page.lisp,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -d -r1.35 -r1.36
--- index-page.lisp	27 Aug 2007 09:41:08 -0000	1.35
+++ index-page.lisp	27 Sep 2007 21:30:02 -0000	1.36
@@ -1,6 +1,6 @@
 (define-page :index "About SBCL" "index" index-page :index-order :top)
 
-(defparameter *most-recent-release* (list "1.0.9" "August 26, 2007"))
+(defparameter *most-recent-release* (list "1.0.10" "September 25, 2007"))
 
 (defun index-page ()
 

Index: platform-support-platforms.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl-page/platform-support-platforms.lisp,v
retrieving revision 1.68
retrieving revision 1.69
diff -u -d -r1.68 -r1.69
--- platform-support-platforms.lisp	9 Sep 2007 19:46:41 -0000	1.68
+++ platform-support-platforms.lisp	27 Sep 2007 21:30:02 -0000	1.69
@@ -24,8 +24,8 @@
 (define-status :not-available "not-available" "Not available (porters welcome!)" "X")
 (define-status :not-applicable "not-applicable" "No such system" " ")
 
-(define-port :x86 :linux :available "1.0.9")
-(define-port :x86-64 :linux :available "1.0.9")
+(define-port :x86 :linux :available "1.0.10")
+(define-port :x86-64 :linux :available "1.0.10")
 (define-port :ppc :linux :available "1.0")
 (define-port :mips :linux :available "0.9.12")
 (define-port :mipsel :linux :available "0.9.12")
@@ -34,7 +34,7 @@
 (define-port :hppa :linux :not-maintained nil)
 
 (define-port :ppc :darwin :available "1.0.2")
-(define-port :x86 :darwin :available "1.0.9")
+(define-port :x86 :darwin :available "1.0.10")
 (define-port :x86-64 :darwin :in-progress nil)
 
 (define-port :sparc :solaris :available "0.9.11")
@@ -44,7 +44,7 @@
 (define-port :x86-64 :freebsd :available "1.0.6")
 (define-port :x86 :netbsd :available "0.9.1")
 (define-port :x86 :openbsd :available "0.8.10")
-(define-port :ppc :netbsd :in-progress nil)
+(define-port :ppc :netbsd :in-progress "1.0.10")
 
 (define-port :alpha :osf/1 :not-maintained nil)
 (define-port :x86 :win32 :in-progress "1.0.9" :file-type "msi")

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv32081/src/code

Modified Files:
	early-extensions.lisp 
Log Message:
1.0.10.11: Make FEATUREP accept only symbols or conses.

One more restriction on feature expressions: They can contain only conses
or symbols. The previous implementation allowed conses and atoms.


Index: early-extensions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-extensions.lisp,v
retrieving revision 1.88
retrieving revision 1.89
diff -u -d -r1.88 -r1.89
--- early-extensions.lisp	18 Sep 2007 08:05:29 -0000	1.88
+++ early-extensions.lisp	27 Sep 2007 19:25:25 -0000	1.89
@@ -920,23 +920,24 @@
   (def-constantly-fun constantly-nil nil)
   (def-constantly-fun constantly-0 0))
 
-;;; If X is an atom, see whether it is present in *FEATURES*. Also
+;;; If X is a symbol, see whether it is present in *FEATURES*. Also
 ;;; handle arbitrary combinations of atoms using NOT, AND, OR.
 (defun featurep (x)
-  (if (consp x)
-      (case (car x)
-        ((:not not)
-         (cond
-           ((cddr x)
-            (error "too many subexpressions in feature expression: ~S" x))
-           ((null (cdr x))
-            (error "too few subexpressions in feature expression: ~S" x))
-           (t (not (featurep (cadr x))))))
-        ((:and and) (every #'featurep (cdr x)))
-        ((:or or) (some #'featurep (cdr x)))
-        (t
-         (error "unknown operator in feature expression: ~S." x)))
-      (not (null (memq x *features*)))))
+  (etypecase x
+    (cons
+     (case (car x)
+       ((:not not)
+        (cond
+          ((cddr x)
+           (error "too many subexpressions in feature expression: ~S" x))
+          ((null (cdr x))
+           (error "too few subexpressions in feature expression: ~S" x))
+          (t (not (featurep (cadr x))))))
+       ((:and and) (every #'featurep (cdr x)))
+       ((:or or) (some #'featurep (cdr x)))
+       (t
+        (error "unknown operator in feature expression: ~S." x))))
+    (symbol (not (null (memq x *features*))))))
 
 ;;;; utilities for two-VALUES predicates

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv32081

Modified Files:
	version.lisp-expr 
Log Message:
1.0.10.11: Make FEATUREP accept only symbols or conses.

One more restriction on feature expressions: They can contain only conses
or symbols. The previous implementation allowed conses and atoms.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.3649
retrieving revision 1.3650
diff -u -d -r1.3649 -r1.3650
--- version.lisp-expr	27 Sep 2007 15:56:06 -0000	1.3649
+++ version.lisp-expr	27 Sep 2007 19:25:25 -0000	1.3650
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.10.10"
+"1.0.10.11"

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv15989/src/code

Modified Files:
	early-type.lisp 
Log Message:
1.0.10.10: theoretical #!+long-float fix to MAKE-MEMBER-TYPE

* 0.0l0, not 0.0lo. Thanks to Peter Graves.


Index: early-type.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-type.lisp,v
retrieving revision 1.51
retrieving revision 1.52
diff -u -d -r1.51 -r1.52
--- early-type.lisp	27 Aug 2007 14:44:22 -0000	1.51
+++ early-type.lisp	27 Sep 2007 15:56:07 -0000	1.52
@@ -432,7 +432,7 @@
                           (member n-double doubles)
                           (or (aver (= 2 (length doubles))) t)))
             #!+long-float
-            (longp (and (member 0.0lo longs)
+            (longp (and (member 0.0l0 longs)
                         (member n-long longs)
                         (or (aver (= 2 (lenght longs))) t))))
         (if (or singlep doublep #!+long-float longp)

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv15989

Modified Files:
	version.lisp-expr 
Log Message:
1.0.10.10: theoretical #!+long-float fix to MAKE-MEMBER-TYPE

* 0.0l0, not 0.0lo. Thanks to Peter Graves.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.3648
retrieving revision 1.3649
diff -u -d -r1.3648 -r1.3649
--- version.lisp-expr	27 Sep 2007 15:50:44 -0000	1.3648
+++ version.lisp-expr	27 Sep 2007 15:56:06 -0000	1.3649
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.10.9"
+"1.0.10.10"

Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv13668/tests

Modified Files:
	macroexpand.impure.lisp 
Log Message:
1.0.10.9: symbol-macro expansion uses *MACROEXPAND-HOOK*

Thanks to Tobias Rittweiler.


Index: macroexpand.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/macroexpand.impure.lisp,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- macroexpand.impure.lisp	7 Oct 2005 04:57:09 -0000	1.1
+++ macroexpand.impure.lisp	27 Sep 2007 15:50:44 -0000	1.2
@@ -27,3 +27,41 @@
 (assert (null glob))
 (assert (equal (let ((glob nil)) (push 'foo glob) glob) '(foo)))
 (assert (null glob))
+
+
+
+;;; CLHS 3.1.2.1.1 specifies that symbol macro expansion must also
+;;; go through *MACROEXPAND-HOOK*. (2007-09-22, -TCR.)
+
+(define-symbol-macro .foo. 'foobar)
+
+(let* ((expanded-p nil)
+      (*macroexpand-hook* #'(lambda (fn form env)
+                              (when (eq form '.foo.)
+                                (setq expanded-p t))
+                              (funcall fn form env))))
+  (multiple-value-bind (expansion flag) (macroexpand '.foo.)
+    (assert (equal expansion '(quote foobar)))
+    (assert flag)
+    (assert expanded-p)))
+
+(let ((sb-ext::*evaluator-mode* :interpret))
+  (let* ((expanded-p nil)
+         (*macroexpand-hook* #'(lambda (fn form env)
+                                 (when (eq form '.foo.)
+                                   (setq expanded-p t))
+                                 (funcall fn form env))))
+    (eval '.foo.)
+    (assert expanded-p)))
+
+(let* ((expanded-p nil)
+       (*macroexpand-hook* #'(lambda (fn form env)
+                               (when (eq form '/foo/)
+                                 (setq expanded-p t))
+                               (funcall fn form env))))
+  (compile nil '(lambda ()
+                 (symbol-macrolet ((/foo/ 'foobar))
+                   (macrolet ((expand (symbol &environment env)
+                                (macroexpand symbol env)))
+                     (expand /foo/)))))
+  (assert expanded-p))

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv13668/src/code

Modified Files:
	macroexpand.lisp 
Log Message:
1.0.10.9: symbol-macro expansion uses *MACROEXPAND-HOOK*

Thanks to Tobias Rittweiler.


Index: macroexpand.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/macroexpand.lisp,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -d -r1.9 -r1.10
--- macroexpand.lisp	7 Oct 2005 04:57:09 -0000	1.9
+++ macroexpand.lisp	27 Sep 2007 15:50:44 -0000	1.10
@@ -53,17 +53,25 @@
                        t)
                (values form nil))))
         ((symbolp form)
-         (let* ((venv (when env (sb!c::lexenv-vars env)))
-                (local-def (cdr (assoc form venv))))
-           (cond ((and (consp local-def)
-                       (eq (car local-def) 'macro))
-                  (values (cdr local-def) t))
-                 (local-def
-                  (values form nil))
-                 ((eq (info :variable :kind form) :macro)
-                  (values (info :variable :macro-expansion form) t))
-                 (t
-                  (values form nil)))))
+         (flet ((perform-symbol-expansion (symbol expansion)
+                  ;; CLHS 3.1.2.1.1 specifies that symbol-macros are expanded
+                  ;; via the macroexpand hook, too.
+                  (funcall sb!xc:*macroexpand-hook*
+                           (constantly expansion)
+                           symbol
+                           env)))
+           (let* ((venv (when env (sb!c::lexenv-vars env)))
+                  (local-def (cdr (assoc form venv))))
+             (cond ((and (consp local-def)
+                         (eq (car local-def) 'macro))
+                    (values (perform-symbol-expansion form (cdr local-def)) t))
+                   (local-def
+                    (values form nil))
+                   ((eq (info :variable :kind form) :macro)
+                    (let ((expansion (info :variable :macro-expansion form)))
+                      (values (perform-symbol-expansion form expansion) t)))
+                   (t
+                    (values form nil))))))
         (t
          (values form nil))))

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv13668

Modified Files:
	NEWS version.lisp-expr 
Log Message:
1.0.10.9: symbol-macro expansion uses *MACROEXPAND-HOOK*

Thanks to Tobias Rittweiler.


Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.1253
retrieving revision 1.1254
diff -u -d -r1.1253 -r1.1254
--- NEWS	26 Sep 2007 16:00:44 -0000	1.1253
+++ NEWS	27 Sep 2007 15:50:43 -0000	1.1254
@@ -8,6 +8,8 @@
   * enhancement: dynamic-extent support has been extended to support
     cases where there are multiple possible sources for the stack
     allocated value.
+  * bug fix: symbol-macro expansion now uses the *MACROEXPAND-HOOK*
+    as specified by the CLHS. (thanks to Tobias Rittweiler)
 
 changes in sbcl-1.0.10 relative to sbcl-1.0.9:
   * minor incompatible change: the MSI installer on Windows no longer

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.3647
retrieving revision 1.3648
diff -u -d -r1.3647 -r1.3648
--- version.lisp-expr	27 Sep 2007 15:43:25 -0000	1.3647
+++ version.lisp-expr	27 Sep 2007 15:50:44 -0000	1.3648
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.10.8"
+"1.0.10.9"

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv10811/src/compiler

Modified Files:
	ir1util.lisp locall.lisp physenvanal.lisp 
Log Message:
1.0.10.8: correct nested DX implementation

* Instead of just checking for BASIC-COMBINATION-P,
  HANDLE-NESTED-DYNAMIC-EXTENT needs to do the same check for each USE
  as RECHECK-DYNAMIC-EXTENT-LVARS does.

* Tests.


Index: ir1util.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1util.lisp,v
retrieving revision 1.108
retrieving revision 1.109
diff -u -d -r1.108 -r1.109
--- ir1util.lisp	27 Jan 2007 03:45:49 -0000	1.108
+++ ir1util.lisp	27 Sep 2007 15:43:25 -0000	1.109
@@ -382,6 +382,13 @@
   (awhen (node-lvar node)
     (lvar-dynamic-extent it)))
 
+(defun use-good-for-dx-p (use)
+  (and (combination-p use)
+       (eq (combination-kind use) :known)
+       (awhen (fun-info-stack-allocate-result
+               (combination-fun-info use))
+         (funcall it use))))
+
 (declaim (inline block-to-be-deleted-p))
 (defun block-to-be-deleted-p (block)
   (or (block-delete-p block)

Index: locall.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/locall.lisp,v
retrieving revision 1.81
retrieving revision 1.82
diff -u -d -r1.81 -r1.82
--- locall.lisp	26 Sep 2007 16:00:45 -0000	1.81
+++ locall.lisp	27 Sep 2007 15:43:25 -0000	1.82
@@ -43,23 +43,25 @@
              (setf (car args) nil)))
   (values))
 
-
-(defun handle-nested-dynamic-extent-lvars (arg)
-  (let ((uses (lvar-uses arg)))
+(defun handle-nested-dynamic-extent-lvars (lvar)
+  (let ((uses (lvar-uses lvar)))
     ;; Stack analysis wants DX value generators to end their
     ;; blocks. Uses of mupltiple used LVARs already end their blocks,
     ;; so we just need to process used-once LVARs.
     (when (node-p uses)
-      (node-ends-block uses)
-      (setf uses (list uses)))
-    ;; If the function result is DX, so are its arguments... This
-    ;; assumes that all our DX functions do not store their arguments
-    ;; anywhere -- just use, and maybe return.
-    (cons arg
-          (loop for use in uses
-                when (basic-combination-p use)
-                nconc (loop for a in (basic-combination-args use)
-                            append (handle-nested-dynamic-extent-lvars a))))))
+      (node-ends-block uses))
+    ;; If this LVAR's USE is good for DX, it must be a regular
+    ;; combination, and its arguments are potentially DX as well.
+    (flet ((recurse (use)
+             (loop for arg in (combination-args use)
+                   append (handle-nested-dynamic-extent-lvars arg))))
+      (cons lvar
+            (if (listp uses)
+                (loop for use in uses
+                      when (use-good-for-dx-p use)
+                      nconc (recurse use))
+                (when (use-good-for-dx-p uses)
+                  (recurse uses)))))))
 
 (defun recognize-dynamic-extent-lvars (call fun)
   (declare (type combination call) (type clambda fun))

Index: physenvanal.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/physenvanal.lisp,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -d -r1.22 -r1.23
--- physenvanal.lisp	26 Sep 2007 16:00:45 -0000	1.22
+++ physenvanal.lisp	27 Sep 2007 15:43:26 -0000	1.23
@@ -334,17 +334,12 @@
                    (loop for what in (cleanup-info cleanup)
                          do (etypecase what
                               (lvar
-                               (let* ((lvar what)
-                                      (uses (lvar-uses lvar)))
-                                 (if (every (lambda (use)
-					      (and (combination-p use)
-						   (eq (basic-combination-kind use) :known)
-						   (awhen (fun-info-stack-allocate-result
-							   (basic-combination-fun-info use))
-						     (funcall it use))))
-					    (if (listp uses) uses (list uses)))
-                                     (real-dx-lvars lvar)
-				     (setf (lvar-dynamic-extent lvar) nil))))
+                               (if (let ((uses (lvar-uses what)))
+                                     (if (listp uses)
+                                         (every #'use-good-for-dx-p uses)
+                                         (use-good-for-dx-p uses)))
+                                   (real-dx-lvars what)
+                                   (setf (lvar-dynamic-extent what) nil)))
                               (node ; DX closure
                                (let* ((call what)
                                       (arg (first (basic-combination-args call)))

Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv10811/tests

Modified Files:
	dynamic-extent.impure.lisp 
Log Message:
1.0.10.8: correct nested DX implementation

* Instead of just checking for BASIC-COMBINATION-P,
  HANDLE-NESTED-DYNAMIC-EXTENT needs to do the same check for each USE
  as RECHECK-DYNAMIC-EXTENT-LVARS does.

* Tests.


Index: dynamic-extent.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/dynamic-extent.impure.lisp,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -d -r1.21 -r1.22
--- dynamic-extent.impure.lisp	26 Sep 2007 16:00:45 -0000	1.21
+++ dynamic-extent.impure.lisp	27 Sep 2007 15:43:26 -0000	1.22
@@ -160,6 +160,25 @@
     (true dx)
     nil))
 
+(defun-with-dx nested-dx-not-used (x)
+  (declare (list x))
+  (let ((l (setf (car x) (list x x x))))
+    (declare (dynamic-extent l))
+    (true l)
+    (true (length l))
+    nil))
+
+(defun-with-dx nested-evil-dx-used (x)
+  (declare (list x))
+  (let ((l (list x x x)))
+    (declare (dynamic-extent l))
+    (unwind-protect
+         (progn
+           (setf (car x) l)
+           (true l))
+      (setf (car x) nil))
+    nil))
+
 ;;; multiple uses for dx lvar
 
 (defun-with-dx multiple-dx-uses ()
@@ -196,6 +215,18 @@
       (funcall thunk))
     (assert (< (- (get-bytes-consed) before) times))))
 
+(defmacro assert-consing (form &optional times)
+  `(%assert-consing (lambda () ,form) ,times))
+(defun %assert-consing (thunk &optional times)
+  (let ((before (get-bytes-consed))
+        (times (or times 10000)))
+    (declare (type (integer 1 *) times))
+    (dotimes (i times)
+      (funcall thunk))
+    (assert (not (< (- (get-bytes-consed) before) times)))))
+
+(defvar *a-cons* (cons nil nil))
+
 #+(or x86 x86-64 alpha ppc sparc mips)
 (progn
   (assert-no-consing (dxclosure 42))
@@ -211,6 +242,8 @@
   (assert-no-consing (cons-on-stack 42))
   (assert-no-consing (nested-dx-conses))
   (assert-no-consing (nested-dx-lists))
+  (assert-consing (nested-dx-not-used *a-cons*))
+  (assert-no-consing (nested-evil-dx-used *a-cons*))
   (assert-no-consing (multiple-dx-uses))
   ;; Not strictly DX..
   (assert-no-consing (test-hash-table))

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv10811

Modified Files:
	version.lisp-expr 
Log Message:
1.0.10.8: correct nested DX implementation

* Instead of just checking for BASIC-COMBINATION-P,
  HANDLE-NESTED-DYNAMIC-EXTENT needs to do the same check for each USE
  as RECHECK-DYNAMIC-EXTENT-LVARS does.

* Tests.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.3646
retrieving revision 1.3647
diff -u -d -r1.3646 -r1.3647
--- version.lisp-expr	26 Sep 2007 16:00:44 -0000	1.3646
+++ version.lisp-expr	27 Sep 2007 15:43:25 -0000	1.3647
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.10.7"
+"1.0.10.8"

Update of /cvsroot/sbcl/sbcl/src/compiler/mips
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv24111/src/compiler/mips

Modified Files:
	alloc.lisp 
Log Message:
1.0.10.5: dynamic-extent CONS

* Extend EMIT-FIXED-ALLOC to support stack-allocation.

* Appropriate DEFOPTIMIZER for CONS.

Note: it seems like it should be a simple matter to support stack
allocation of all primitive objects allocated using the :ALLOC-TRANS
framework.


Index: alloc.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/mips/alloc.lisp,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -d -r1.15 -r1.16
--- alloc.lisp	5 Sep 2007 20:31:15 -0000	1.15
+++ alloc.lisp	26 Sep 2007 15:44:23 -0000	1.16
@@ -175,8 +175,8 @@
 
 (define-vop (fixed-alloc)
   (:args)
-  (:info name words type lowtag)
-  (:ignore name)
+  (:info name words type lowtag stack-allocate-p)
+  (:ignore name stack-allocate-p)
   (:results (result :scs (descriptor-reg)))
   (:temporary (:scs (non-descriptor-reg)) temp)
   (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)

Update of /cvsroot/sbcl/sbcl/src/compiler/hppa
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv24111/src/compiler/hppa

Modified Files:
	alloc.lisp 
Log Message:
1.0.10.5: dynamic-extent CONS

* Extend EMIT-FIXED-ALLOC to support stack-allocation.

* Appropriate DEFOPTIMIZER for CONS.

Note: it seems like it should be a simple matter to support stack
allocation of all primitive objects allocated using the :ALLOC-TRANS
framework.


Index: alloc.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/hppa/alloc.lisp,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- alloc.lisp	5 Sep 2007 20:31:15 -0000	1.8
+++ alloc.lisp	26 Sep 2007 15:44:23 -0000	1.9
@@ -158,8 +158,8 @@
 
 (define-vop (fixed-alloc)
   (:args)
-  (:info name words type lowtag)
-  (:ignore name)
+  (:info name words type lowtag stack-allocate-p)
+  (:ignore name stack-allocate-p)
   (:results (result :scs (descriptor-reg)))
   (:temporary (:scs (non-descriptor-reg)) temp)
   (:generator 4

Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv30847/tests

Modified Files:
	dynamic-extent.impure.lisp 
Log Message:
1.0.10.7: multiply-used DX LVARS

* HANDLE-NESTED-DYNAMIC-EXTENT maps over all the uses of the LVAR,
  collecting their argument lvars as well.

* RECHECK-DYNAMIC-EXTENT-LVARS accepts multiply-used DX LVARs,
  checking that all uses support stack allocation.

* UPDATE-UVL-LIVE-SETS accepts multiply-used DX LVARs, doing that
  lifetime merging with all uses.

* ...and OOPS, move the NEWS entries of .5 and .6 to a new section for
  1.0.11...


Index: dynamic-extent.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/dynamic-extent.impure.lisp,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -d -r1.20 -r1.21
--- dynamic-extent.impure.lisp	26 Sep 2007 15:54:58 -0000	1.20
+++ dynamic-extent.impure.lisp	26 Sep 2007 16:00:45 -0000	1.21
@@ -160,6 +160,16 @@
     (true dx)
     nil))
 
+;;; multiple uses for dx lvar
+
+(defun-with-dx multiple-dx-uses ()
+  (let ((dx (if (true t)
+                (list 1 2 3)
+                (list 2 3 4))))
+    (declare (dynamic-extent dx))
+    (true dx)
+    nil))
+
 ;;; with-spinlock should use DX and not cons
 
 (defvar *slock* (sb-thread::make-spinlock :name "slocklock"))
@@ -201,6 +211,7 @@
   (assert-no-consing (cons-on-stack 42))
   (assert-no-consing (nested-dx-conses))
   (assert-no-consing (nested-dx-lists))
+  (assert-no-consing (multiple-dx-uses))
   ;; Not strictly DX..
   (assert-no-consing (test-hash-table))
   #+sb-thread

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv30847

Modified Files:
	NEWS OPTIMIZATIONS version.lisp-expr 
Log Message:
1.0.10.7: multiply-used DX LVARS

* HANDLE-NESTED-DYNAMIC-EXTENT maps over all the uses of the LVAR,
  collecting their argument lvars as well.

* RECHECK-DYNAMIC-EXTENT-LVARS accepts multiply-used DX LVARs,
  checking that all uses support stack allocation.

* UPDATE-UVL-LIVE-SETS accepts multiply-used DX LVARs, doing that
  lifetime merging with all uses.

* ...and OOPS, move the NEWS entries of .5 and .6 to a new section for
  1.0.11...


Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.1252
retrieving revision 1.1253
diff -u -d -r1.1252 -r1.1253
--- NEWS	26 Sep 2007 15:54:58 -0000	1.1252
+++ NEWS	26 Sep 2007 16:00:44 -0000	1.1253
@@ -1,4 +1,14 @@
 ;;;; -*- coding: utf-8; -*-
+changes in sbcl-1.0.11 relative to sbcl-1.0.10:
+  * enhancement: CONS can now stack-allocate on x86 and
+    x86-64. (Earlier LIST and LIST* supported stack-allocation, but
+    CONS did not.)
+  * enhancement: nested lists can now be stack allocated on
+    platforms providing stack allocation support.
+  * enhancement: dynamic-extent support has been extended to support
+    cases where there are multiple possible sources for the stack
+    allocated value.
+
 changes in sbcl-1.0.10 relative to sbcl-1.0.9:
   * minor incompatible change: the MSI installer on Windows no longer
     associates .lisp and .fasl files with the installed SBCL.
@@ -21,11 +31,6 @@
   * optimization: UNION and NUNION are now O(N+M) for large
     inputs as long as the :TEST function is one of EQ, EQL, EQUAL, or
     EQUALP.
-  * enhancement: CONS can now stack-allocate on x86 and
-    x86-64. (Earlier LIST and LIST* supported stack-allocation, but
-    CONS did not:)
-  * enhancement: nested lists can now be stack allocated on
-    platforms providing stack allocation support.
   * enhancement: DEFINE-MODIFY-MACRO lambda-list information is
     now more readable in environments like Slime which display it.
     (thanks to Tobias C. Rittweiler)  

Index: OPTIMIZATIONS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/OPTIMIZATIONS,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -d -r1.37 -r1.38
--- OPTIMIZATIONS	26 Sep 2007 15:54:58 -0000	1.37
+++ OPTIMIZATIONS	26 Sep 2007 16:00:44 -0000	1.38
@@ -162,15 +162,6 @@
 rather than either constant-folding or manipulating NIL-VALUE or
 NULL-TN directly.
 --------------------------------------------------------------------------------
-#19
-  (let ((dx (if (foo)
-                (list x)
-                (list y z))))
-    (declare (dynamic-extent dx))
-    ...)
-
-DX is not allocated on stack.
---------------------------------------------------------------------------------
 #20
 (defun-with-dx foo (x)
   (flet ((make (x)

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.3645
retrieving revision 1.3646
diff -u -d -r1.3645 -r1.3646
--- version.lisp-expr	26 Sep 2007 15:54:58 -0000	1.3645
+++ version.lisp-expr	26 Sep 2007 16:00:44 -0000	1.3646
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.10.6"
+"1.0.10.7"

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv30847/src/compiler

Modified Files:
	locall.lisp physenvanal.lisp stack.lisp 
Log Message:
1.0.10.7: multiply-used DX LVARS

* HANDLE-NESTED-DYNAMIC-EXTENT maps over all the uses of the LVAR,
  collecting their argument lvars as well.

* RECHECK-DYNAMIC-EXTENT-LVARS accepts multiply-used DX LVARs,
  checking that all uses support stack allocation.

* UPDATE-UVL-LIVE-SETS accepts multiply-used DX LVARs, doing that
  lifetime merging with all uses.

* ...and OOPS, move the NEWS entries of .5 and .6 to a new section for
  1.0.11...


Index: locall.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/locall.lisp,v
retrieving revision 1.80
retrieving revision 1.81
diff -u -d -r1.80 -r1.81
--- locall.lisp	26 Sep 2007 15:54:58 -0000	1.80
+++ locall.lisp	26 Sep 2007 16:00:45 -0000	1.81
@@ -45,20 +45,21 @@
 
 
 (defun handle-nested-dynamic-extent-lvars (arg)
-  (let ((use (lvar-uses arg)))
+  (let ((uses (lvar-uses arg)))
     ;; Stack analysis wants DX value generators to end their
     ;; blocks. Uses of mupltiple used LVARs already end their blocks,
     ;; so we just need to process used-once LVARs.
-    (when (node-p use)
-      (node-ends-block use))
+    (when (node-p uses)
+      (node-ends-block uses)
+      (setf uses (list uses)))
     ;; If the function result is DX, so are its arguments... This
     ;; assumes that all our DX functions do not store their arguments
     ;; anywhere -- just use, and maybe return.
-    (if (basic-combination-p use)
-        (cons arg (funcall (lambda (lists)
-                             (reduce #'append lists))
-                         (mapcar #'handle-nested-dynamic-extent-lvars (basic-combination-args use))))
-        (list arg))))
+    (cons arg
+          (loop for use in uses
+                when (basic-combination-p use)
+                nconc (loop for a in (basic-combination-args use)
+                            append (handle-nested-dynamic-extent-lvars a))))))
 
 (defun recognize-dynamic-extent-lvars (call fun)
   (declare (type combination call) (type clambda fun))

Index: physenvanal.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/physenvanal.lisp,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -d -r1.21 -r1.22
--- physenvanal.lisp	11 Sep 2005 07:27:43 -0000	1.21
+++ physenvanal.lisp	26 Sep 2007 16:00:45 -0000	1.22
@@ -335,14 +335,16 @@
                          do (etypecase what
                               (lvar
                                (let* ((lvar what)
-                                      (use (lvar-uses lvar)))
-                                 (if (and (combination-p use)
-                                          (eq (basic-combination-kind use) :known)
-                                          (awhen (fun-info-stack-allocate-result
-                                                  (basic-combination-fun-info use))
-                                            (funcall it use)))
+                                      (uses (lvar-uses lvar)))
+                                 (if (every (lambda (use)
+					      (and (combination-p use)
+						   (eq (basic-combination-kind use) :known)
+						   (awhen (fun-info-stack-allocate-result
+							   (basic-combination-fun-info use))
+						     (funcall it use))))
+					    (if (listp uses) uses (list uses)))
                                      (real-dx-lvars lvar)
-                                     (setf (lvar-dynamic-extent lvar) nil))))
+				     (setf (lvar-dynamic-extent lvar) nil))))
                               (node ; DX closure
                                (let* ((call what)
                                       (arg (first (basic-combination-args call)))

Index: stack.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/stack.lisp,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -d -r1.18 -r1.19
--- stack.lisp	14 Jul 2005 18:57:02 -0000	1.18
+++ stack.lisp	26 Sep 2007 16:00:45 -0000	1.19
@@ -61,6 +61,7 @@
 ;;; been changed.
 (defun merge-uvl-live-sets (early late)
   (declare (type list early late))
+  ;; FIXME: O(N^2)
   (dolist (e late early)
     (pushnew e early)))
 
@@ -93,21 +94,23 @@
                      block
                      (lambda (dx-cleanup)
                        (dolist (lvar (cleanup-info dx-cleanup))
-                         (let* ((generator (lvar-use lvar))
-                                (block (node-block generator))
-                                (2block (block-info block)))
-                           ;; DX objects, living in the LVAR, are
-                           ;; alive in the environment, protected by
-                           ;; the CLEANUP. We also cannot move them
-                           ;; (because, in general, we cannot track
-                           ;; all references to them). Therefore,
-                           ;; everything, allocated deeper than a DX
-                           ;; object, should be kept alive until the
-                           ;; object is deallocated.
-                           (setq new-end (merge-uvl-live-sets
-                                          new-end (ir2-block-end-stack 2block)))
-                           (setq new-end (merge-uvl-live-sets
-                                          new-end (ir2-block-pushed 2block)))))))
+                         (let ((uses (lvar-uses lvar)))
+                           (dolist (generator (if (listp uses) uses (list uses)))
+                             (let* ((block (node-block generator))
+                                    (2block (block-info block)))
+                               ;; DX objects, living in the LVAR, are
+                               ;; alive in the environment, protected
+                               ;; by the CLEANUP. We also cannot move
+                               ;; them (because, in general, we cannot
+                               ;; track all references to
+                               ;; them). Therefore, everything,
+                               ;; allocated deeper than a DX object,
+                               ;; should be kept alive until the
+                               ;; object is deallocated.
+                               (setq new-end (merge-uvl-live-sets
+                                              new-end (ir2-block-end-stack 2block)))
+                               (setq new-end (merge-uvl-live-sets
+                                              new-end (ir2-block-pushed 2block)))))))))
 
     (setf (ir2-block-end-stack 2block) new-end)

Update of /cvsroot/sbcl/sbcl/src/compiler/x86-64
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv24111/src/compiler/x86-64

Modified Files:
	alloc.lisp 
Log Message:
1.0.10.5: dynamic-extent CONS

* Extend EMIT-FIXED-ALLOC to support stack-allocation.

* Appropriate DEFOPTIMIZER for CONS.

Note: it seems like it should be a simple matter to support stack
allocation of all primitive objects allocated using the :ALLOC-TRANS
framework.


Index: alloc.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/alloc.lisp,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -d -r1.15 -r1.16
--- alloc.lisp	28 Jun 2007 13:04:59 -0000	1.15
+++ alloc.lisp	26 Sep 2007 15:44:23 -0000	1.16
@@ -11,7 +11,9 @@
 
 (in-package "SB!VM")
 
-;;;; LIST and LIST*
+;;;; CONS, LIST and LIST*
+(defoptimizer (cons stack-allocate-result) ((&rest args))
+  t)
 (defoptimizer (list stack-allocate-result) ((&rest args))
   (not (null args)))
 (defoptimizer (list* stack-allocate-result) ((&rest args))
@@ -248,13 +250,13 @@
 
 (define-vop (fixed-alloc)
   (:args)
-  (:info name words type lowtag)
+  (:info name words type lowtag stack-allocate-p)
   (:ignore name)
   (:results (result :scs (descriptor-reg)))
   (:node-var node)
   (:generator 50
     (pseudo-atomic
-     (allocation result (pad-data-block words) node)
+     (allocation result (pad-data-block words) node stack-allocate-p)
      (inst lea result (make-ea :byte :base result :disp lowtag))
      (when type
        (storew (logior (ash (1- words) n-widetag-bits) type)