From: Juho Snellman Date: Tue, 21 Aug 2007 05:18:42 +0000 (+0000) Subject: 1.0.8.44: Fix EQUALP on structures with raw slots X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=c55397520c6238fb878bb80ed6687da1700b66ca;p=sbcl.git 1.0.8.44: Fix EQUALP on structures with raw slots * Old version was basically accessing raw slots with %INSTANCE-REF, and doing EQUALP on the results. This was most obviously wrong for raw slots that were larger than a word (double-floats on 32-bit platforms). Less obviously this is also wrong for some float corner-cases, like negative zeroes. * Add RAW-INSTANCE-SLOTS-EQUALP which instead grovels the layout for the slot definitions and determines the proper accessor functions for each slot from that. * Reported by Vjacheslav Fyodorov. --- diff --git a/NEWS b/NEWS index 90a6eb7..cf05800 100644 --- a/NEWS +++ b/NEWS @@ -31,6 +31,11 @@ changes in sbcl-1.0.9 relative to sbcl-1.0.8: command was used. * bug fix: Branch forms are again annotated as branches in the sb-cover annotations. + * bug fix: GCD on MOST-NEGATIVE-FIXNUM no longer causes an infinite loop + on x86-64. (reported by Gregory Vanuxem) + * bug fix: EQUALP could return wrong results for structures with raw + slots (slots with a :TYPE of SINGLE-FLOAT, DOUBLE-FLOAT, or a machine + word). (reported by Vjacheslav Fyodorov) changes in sbcl-1.0.8 relative to sbcl-1.0.7: * enhancement: experimental macro SB-EXT:COMPARE-AND-SWAP provides diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index bebbbf1..5797c73 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1442,7 +1442,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "PARSE-DEFMACRO" "PARSE-UNKNOWN-TYPE" "PARSE-UNKNOWN-TYPE-SPECIFIER" "PATHNAME-DESIGNATOR" #!+(or x86 x86-64) "*PSEUDO-ATOMIC-BITS*" - "PUNT-PRINT-IF-TOO-LONG" "READER-IMPOSSIBLE-NUMBER-ERROR" + "PUNT-PRINT-IF-TOO-LONG" + "RAW-INSTANCE-SLOTS-EQUALP" + "READER-IMPOSSIBLE-NUMBER-ERROR" "READER-PACKAGE-ERROR" "READER-EOF-ERROR" "RESTART-DESIGNATOR" "RUN-PENDING-FINALIZERS" diff --git a/src/code/pred.lisp b/src/code/pred.lisp index 7d006cc..ee5c9e8 100644 --- a/src/code/pred.lisp +++ b/src/code/pred.lisp @@ -317,18 +317,21 @@ length and have identical components. Other arrays must be EQ to be EQUAL." (hash-table-equalp x y))) ((%instancep x) (let* ((layout-x (%instance-layout x)) - (len (layout-length layout-x))) + (raw-len (layout-n-untagged-slots layout-x)) + (total-len (layout-length layout-x)) + (normal-len (- total-len raw-len))) (and (%instancep y) (eq layout-x (%instance-layout y)) (structure-classoid-p (layout-classoid layout-x)) - (do ((i 1 (1+ i))) - ((= i len) t) - (declare (fixnum i)) + (dotimes (i normal-len t) (let ((x-el (%instance-ref x i)) (y-el (%instance-ref y i))) (unless (or (eq x-el y-el) (equalp x-el y-el)) - (return nil))))))) + (return nil)))) + (if (zerop raw-len) + t + (raw-instance-slots-equalp layout-x x y))))) ((vectorp x) (let ((length (length x))) (and (vectorp y) diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 176c4f5..f179459 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -417,6 +417,31 @@ (%raw-instance-ref/word structure i))) res)) + + + +;; Do an EQUALP comparison on the raw slots (only, not the normal slots) of a +;; structure. +(defun raw-instance-slots-equalp (layout x y) + ;; This implementation sucks, but hopefully EQUALP on raw structures + ;; won't be a major bottleneck for anyone. It'd be tempting to do + ;; all this with %RAW-INSTANCE-REF/WORD and bitwise comparisons, but + ;; that'll fail in some cases. For example -0.0 and 0.0 are EQUALP + ;; but have different bit patterns. -- JES, 2007-08-21 + (loop with i = -1 + for dsd in (dd-slots (layout-info layout)) + for raw-type = (dsd-raw-type dsd) + for rsd = (when raw-type + (find raw-type + *raw-slot-data-list* + :key 'raw-slot-data-raw-type)) + for accessor = (when rsd + (raw-slot-data-accessor-name rsd)) + always (or (not accessor) + (progn + (incf i) + (equalp (funcall accessor x i) + (funcall accessor y i)))))) ;;; default PRINT-OBJECT method diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp index 7e5fad9..b80e723 100644 --- a/tests/defstruct.impure.lisp +++ b/tests/defstruct.impure.lisp @@ -699,5 +699,19 @@ (sb-kernel:layout-invalid () :error2)))))) -;;; success -(format t "~&/returning success~%") +;; EQUALP didn't work for structures with float slots (reported by +;; Vjacheslav Fyodorov). +(defstruct raw-slot-equalp-bug + (b 0s0 :type single-float) + c + (a 0d0 :type double-float)) + +(with-test (:name raw-slot-equalp) + (assert (equalp (make-raw-slot-equalp-bug :a 1d0 :b 2s0) + (make-raw-slot-equalp-bug :a 1d0 :b 2s0))) + (assert (equalp (make-raw-slot-equalp-bug :a 1d0 :b 0s0) + (make-raw-slot-equalp-bug :a 1d0 :b -0s0))) + (assert (not (equalp (make-raw-slot-equalp-bug :a 1d0 :b 2s0) + (make-raw-slot-equalp-bug :a 1d0 :b 3s0)))) + (assert (not (equalp (make-raw-slot-equalp-bug :a 1d0 :b 2s0) + (make-raw-slot-equalp-bug :a 2d0 :b 2s0))))) diff --git a/version.lisp-expr b/version.lisp-expr index f774a42..f92ff4b 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".) -"1.0.8.43" +"1.0.8.44"