From 084168e1524a6493bc0f9d1697753d31239b158d Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 15 Mar 2004 15:55:06 +0000 Subject: [PATCH] 0.8.8.26: Merge patches from NJF (sbcl-devel 2003-03-11) ... more #!-SB-DOC ... fewer :TEST-NOT ... less OAOOM Explain what's happening around MAYBE-FP-WAIT (thanks to Nikodemus Siivola sbcl-devel) Patch threads.impure.lisp to allow writing the C file (Nikodemus Siivola sbcl-devel 2004-02-27) Fix for foreign double access on Darwin (CSR sbcl-devel 2004-02-23) --- src/assembly/assemfile.lisp | 8 +-- src/code/array.lisp | 1 + src/code/hash-table.lisp | 2 +- src/code/host-alieneval.lisp | 2 +- src/code/target-hash-table.lisp | 141 ++++++++++++++++----------------------- src/compiler/ir1util.lisp | 2 +- src/compiler/main.lisp | 2 +- src/compiler/seqtran.lisp | 4 +- src/compiler/x86/float.lisp | 12 +++- src/pcl/std-class.lisp | 2 +- version.lisp-expr | 2 +- 11 files changed, 79 insertions(+), 99 deletions(-) diff --git a/src/assembly/assemfile.lisp b/src/assembly/assemfile.lisp index 191df4e..ac8ab34 100644 --- a/src/assembly/assemfile.lisp +++ b/src/assembly/assemfile.lisp @@ -120,9 +120,9 @@ `(:target ,(reg-spec-temp reg))))) (defun emit-vop (name options vars) - (let* ((args (remove :arg vars :key #'reg-spec-kind :test-not #'eq)) - (temps (remove :temp vars :key #'reg-spec-kind :test-not #'eq)) - (results (remove :res vars :key #'reg-spec-kind :test-not #'eq)) + (let* ((args (remove :arg vars :key #'reg-spec-kind :test #'neq)) + (temps (remove :temp vars :key #'reg-spec-kind :test #'neq)) + (results (remove :res vars :key #'reg-spec-kind :test #'neq)) (return-style (or (cadr (assoc :return-style options)) :raw)) (cost (or (cadr (assoc :cost options)) 247)) (vop (make-symbol "VOP"))) @@ -164,7 +164,7 @@ ,@(apply #'append (mapcar #'cdr (remove :ignore call-temps - :test-not #'eq :key #'car)))) + :test #'neq :key #'car)))) ,@(remove-if (lambda (x) (member x '(:return-style :cost))) options diff --git a/src/code/array.lisp b/src/code/array.lisp index 71ce324..733b8c3 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -969,6 +969,7 @@ (defmacro def-bit-array-op (name function) `(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array) + #!+sb-doc ,(format nil "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~ BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~ diff --git a/src/code/hash-table.lisp b/src/code/hash-table.lisp index c352a17..1690fd3 100644 --- a/src/code/hash-table.lisp +++ b/src/code/hash-table.lisp @@ -61,7 +61,7 @@ ;; This table parallels the KV table, and can be used to store the ;; hash associated with the key, saving recalculation. Could be ;; useful for EQL, and EQUAL hash tables. This table is not needed - ;; for EQ hash tables, and when present the value of #x8000000 + ;; for EQ hash tables, and when present the value of #x80000000 ;; represents EQ-based hashing on the respective key. (hash-vector nil :type (or null (simple-array (unsigned-byte 32) (*))))) diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index 0003d8b..e9fe96a 100644 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -22,7 +22,7 @@ (defun guess-alignment (bits) (cond ((null bits) nil) - #!-x86 ((> bits 32) 64) + #!-(or x86 (and ppc darwin)) ((> bits 32) 64) ((> bits 16) 32) ((> bits 8) 16) ((> bits 1) 8) diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp index 26d751e..c28e640 100644 --- a/src/code/target-hash-table.lisp +++ b/src/code/target-hash-table.lisp @@ -82,6 +82,10 @@ (defconstant +min-hash-table-size+ 16) (defconstant +min-hash-table-rehash-threshold+ (float 1/16 1.0)) +;; as explained by pmai on openprojects #lisp IRC 2002-07-30: #x80000000 +;; is bigger than any possible nonEQ hash value, and thus indicates an +;; empty slot; and EQ hash tables don't use HASH-TABLE-HASH-VECTOR +(defconstant +magic-hash-vector-value+ #x80000000) (defun make-hash-table (&key (test 'eql) (size +min-hash-table-size+) @@ -160,6 +164,7 @@ :element-type '(unsigned-byte 32) :initial-element 0)) ;; needs to be the same length as the KV vector + ;; (FIXME: really? why doesn't the code agree?) (next-vector (make-array size+1 :element-type '(unsigned-byte 32))) (kv-vector (make-array (* 2 size+1) @@ -178,15 +183,7 @@ :hash-vector (unless (eq test 'eq) (make-array size+1 :element-type '(unsigned-byte 32) - ;; as explained by pmai on - ;; openprojects #lisp IRC - ;; 2002-07-30: #x80000000 is - ;; bigger than any possible nonEQ - ;; hash value, and thus indicates - ;; an empty slot; and EQ hash - ;; tables don't use - ;; HASH-TABLE-HASH-VECTOR - :initial-element #x80000000))))) + :initial-element +magic-hash-vector-value+))))) (declare (type index size+1 scaled-size length)) ;; Set up the free list, all free. These lists are 0 terminated. (do ((i 1 (1+ i))) @@ -254,7 +251,7 @@ (new-hash-vector (when old-hash-vector (make-array new-size :element-type '(unsigned-byte 32) - :initial-element #x80000000))) + :initial-element +magic-hash-vector-value+))) (old-index-vector (hash-table-index-vector table)) (new-length (almost-primify (truncate (/ (float new-size) @@ -267,6 +264,11 @@ ;; Disable GC tricks on the OLD-KV-VECTOR. (set-header-data old-kv-vector sb!vm:vector-normal-subtype) + ;; FIXME: here and in several other places in the hash table code, + ;; loops like this one are used when FILL or REPLACE would be + ;; appropriate. why are standard CL functions not used? + ;; Performance issues? General laziness? -- NJF, 2004-03-10 + ;; Copy over the kv-vector. The element positions should not move ;; in case there are active scans. (dotimes (i (* old-size 2)) @@ -293,7 +295,7 @@ (hash-table-next-free-kv table)) (setf (hash-table-next-free-kv table) i)) ((and new-hash-vector - (not (= (aref new-hash-vector i) #x80000000))) + (not (= (aref new-hash-vector i) +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)) @@ -338,8 +340,7 @@ (size (length next-vector)) (index-vector (hash-table-index-vector table)) (length (length index-vector))) - (declare (type index size length) - (type (simple-array (unsigned-byte 32) (*)))) + (declare (type index size length)) ;; Disable GC tricks, they will be re-enabled during the re-hash ;; if necesary. @@ -361,7 +362,7 @@ ;; Slot is empty, push it onto free list. (setf (aref next-vector i) (hash-table-next-free-kv table)) (setf (hash-table-next-free-kv table) i)) - ((and hash-vector (not (= (aref hash-vector i) #x80000000))) + ((and hash-vector (not (= (aref hash-vector i) +magic-hash-vector-value+))) ;; Can use the existing hash value (not EQ based) (let* ((hashing (aref hash-vector i)) (index (rem hashing length)) @@ -516,7 +517,7 @@ (when hash-vector (if (not eq-based) (setf (aref hash-vector free-kv-slot) hashing) - (aver (= (aref hash-vector free-kv-slot) #x80000000)))) + (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) @@ -551,74 +552,46 @@ (hash-vector (hash-table-hash-vector hash-table)) (test-fun (hash-table-test-fun hash-table))) (declare (type index index next)) - (cond ((zerop next) - nil) - ((if (or eq-based (not hash-vector)) - (eq key (aref table (* 2 next))) - (and (= hashing (aref hash-vector next)) - (funcall test-fun key (aref table (* 2 next))))) - - ;; FIXME: Substantially the same block of code seems to - ;; appear in all three cases. (In the first case, it - ;; appear bare; in the other two cases, it's wrapped in - ;; DO.) It should be defined in a separate (possibly - ;; inline) DEFUN or FLET. - - ;; Mark slot as empty. - (setf (aref table (* 2 next)) +empty-ht-slot+ - (aref table (1+ (* 2 next))) +empty-ht-slot+) - ;; Update the index-vector pointer. - (setf (aref index-vector index) (aref next-vector next)) - ;; Push KV slot onto free chain. - (setf (aref next-vector next) - (hash-table-next-free-kv hash-table)) - (setf (hash-table-next-free-kv hash-table) next) - (when hash-vector - (setf (aref hash-vector next) #x80000000)) - (decf (hash-table-number-entries hash-table)) - t) - ;; Search next-vector chain for a matching key. - ((or eq-based (not hash-vector)) - ;; EQ based - (do ((prior next next) - (next (aref next-vector next) (aref next-vector next))) - ((zerop next) nil) - (declare (type index next)) - (when (eq key (aref table (* 2 next))) - ;; Mark slot as empty. - (setf (aref table (* 2 next)) +empty-ht-slot+ - (aref table (1+ (* 2 next))) +empty-ht-slot+) - ;; Update the prior pointer in the chain to skip this. - (setf (aref next-vector prior) (aref next-vector next)) - ;; Push KV slot onto free chain. - (setf (aref next-vector next) - (hash-table-next-free-kv hash-table)) - (setf (hash-table-next-free-kv hash-table) next) - (when hash-vector - (setf (aref hash-vector next) #x80000000)) - (decf (hash-table-number-entries hash-table)) - (return t)))) - (t - ;; not EQ based - (do ((prior next next) - (next (aref next-vector next) (aref next-vector next))) - ((zerop next) nil) - (declare (type index next)) - (when (and (= hashing (aref hash-vector next)) - (funcall test-fun key (aref table (* 2 next)))) - ;; Mark slot as empty. - (setf (aref table (* 2 next)) +empty-ht-slot+) - (setf (aref table (1+ (* 2 next))) +empty-ht-slot+) - ;; Update the prior pointer in the chain to skip this. - (setf (aref next-vector prior) (aref next-vector next)) - ;; Push KV slot onto free chain. - (setf (aref next-vector next) - (hash-table-next-free-kv hash-table)) - (setf (hash-table-next-free-kv hash-table) next) - (when hash-vector - (setf (aref hash-vector next) #x80000000)) - (decf (hash-table-number-entries hash-table)) - (return t))))))))) + (flet ((clear-slot (chain-vector prior-slot-location slot-location) + ;; Mark slot as empty. + (setf (aref table (* 2 slot-location)) +empty-ht-slot+ + (aref table (1+ (* 2 slot-location))) +empty-ht-slot+) + ;; Update the prior pointer in the chain to skip this. + (setf (aref chain-vector prior-slot-location) + (aref next-vector slot-location)) + ;; Push KV slot onto free chain. + (setf (aref next-vector slot-location) + (hash-table-next-free-kv hash-table)) + (setf (hash-table-next-free-kv hash-table) slot-location) + (when hash-vector + (setf (aref hash-vector slot-location) +magic-hash-vector-value+)) + (decf (hash-table-number-entries hash-table)) + t)) + (cond ((zerop next) + nil) + ((if (or eq-based (not hash-vector)) + (eq key (aref table (* 2 next))) + (and (= hashing (aref hash-vector next)) + (funcall test-fun key (aref table (* 2 next))))) + (clear-slot index-vector index next)) + ;; Search next-vector chain for a matching key. + ((or eq-based (not hash-vector)) + ;; EQ based + (do ((prior next next) + (next (aref next-vector next) (aref next-vector next))) + ((zerop next) nil) + (declare (type index next)) + (when (eq key (aref table (* 2 next))) + (return-from remhash (clear-slot next-vector prior next))))) + (t + ;; not EQ based + (do ((prior next next) + (next (aref next-vector next) (aref next-vector next))) + ((zerop next) nil) + (declare (type index next)) + (when (and (= hashing (aref hash-vector next)) + (funcall test-fun key (aref table (* 2 next)))) + (return-from remhash (clear-slot next-vector prior next))))))))))) (defun clrhash (hash-table) #!+sb-doc @@ -652,7 +625,7 @@ ;; Clear the hash-vector. (when hash-vector (dotimes (i size) - (setf (aref hash-vector i) #x80000000)))) + (setf (aref hash-vector i) +magic-hash-vector-value+)))) (setf (hash-table-number-entries hash-table) 0) hash-table) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 2dfcfef..a8d177c 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1458,7 +1458,7 @@ (flet ((frob (l) (find home l :key #'node-home-lambda - :test-not #'eq))) + :test #'neq))) (or (frob (leaf-refs var)) (frob (basic-var-sets var))))))))) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 06067d1..67ac123 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -216,7 +216,7 @@ (dolist (kind '(:variable :function :type)) (let ((summary (mapcar #'undefined-warning-name - (remove kind undefs :test-not #'eq + (remove kind undefs :test #'neq :key #'undefined-warning-kind)))) (when summary (if (eq kind :variable) diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 9e124db..f13cd2e 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -1056,8 +1056,8 @@ ;;; perhaps it's worth optimizing the -if-not versions in the same ;;; way as the others? ;;; -;;; FIXME: Maybe remove uses of these deprecated functions (and -;;; definitely of :TEST-NOT) within the implementation of SBCL. +;;; FIXME: Maybe remove uses of these deprecated functions within the +;;; implementation of SBCL. (macrolet ((define-find-position-if-not (fun-name values-index) `(deftransform ,fun-name ((predicate sequence &key from-end (start 0) diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp index e5b1942..d3fd720 100644 --- a/src/compiler/x86/float.lisp +++ b/src/compiler/x86/float.lisp @@ -62,11 +62,17 @@ ;;; ;;; NOTE-NEXT-INSTRUCTION, if supplied, is to be passed to ;;; #'NOTE-NEXT-INSTRUCTION. +;;; +;;; Until 2004-03-15, the implementation of this was buggy; it +;;; unconditionally emitted the WAIT instruction. It turns out that +;;; this is the right thing to do anyway; omitting them can lead to +;;; system corruption on conforming code. -- CSR (defun maybe-fp-wait (node &optional note-next-instruction) + #+nil (when (policy node (or (= debug 3) (> safety speed)))) - (when note-next-instruction - (note-next-instruction note-next-instruction :internal-error)) - (inst wait)) + (when note-next-instruction + (note-next-instruction note-next-instruction :internal-error)) + (inst wait)) ;;; complex float stack EAs (macrolet ((ea-for-cxf-stack (tn kind slot &optional base) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 5e0249a..b03b1f1 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -498,7 +498,7 @@ dupes))) (let* ((slot (car slots)) (oslots (remove (slot-definition-name slot) (cdr slots) - :test-not #'string= :key #'slot-definition-name))) + :test #'string/= :key #'slot-definition-name))) (when oslots (pushnew (cons (slot-definition-name slot) (mapcar #'slot-definition-name oslots)) diff --git a/version.lisp-expr b/version.lisp-expr index 150d4f7..1efb96d 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -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".) -"0.8.8.25" +"0.8.8.26" -- 1.7.10.4