From: Christophe Rhodes Date: Fri, 26 Apr 2002 20:54:58 +0000 (+0000) Subject: 0.7.3.5: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=0704fd3f3f027ec1be05ddb986b6ca538aa165ca;p=sbcl.git 0.7.3.5: Port fix to PCL due to Pierre Mai regarding MAKE-INSTANCES-OBSOLETE in the fast path New, slightly less bogus transforms for bitvector operations ... now we can deal with bitvectors with lengths close to ARRAY-DIMENSION-LIMIT Also write tests for both of these (thanks again to Pierre Mai) --- diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index e28bc13..feba317 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -196,18 +196,32 @@ bit-array-1 bit-array-2 result-bit-array)))) - (do ((index sb!vm:vector-data-offset (1+ index)) - (end (+ sb!vm:vector-data-offset - (truncate (the index - (+ (length bit-array-1) - sb!vm:n-word-bits -1)) - sb!vm:n-word-bits)))) - ((= index end) result-bit-array) - (declare (optimize (speed 3) (safety 0)) - (type index index end)) - (setf (%raw-bits result-bit-array index) - (,',wordfun (%raw-bits bit-array-1 index) - (%raw-bits bit-array-2 index)))))))) + (let ((length (length result-bit-array))) + (if (= length 0) + ;; We avoid doing anything to 0-length + ;; bit-vectors, or rather, the memory that + ;; follows them. Other divisible-by-32 cases + ;; are handled by the (1- length), below. + ;; CSR, 2002-04-24 + result-bit-array + (do ((index sb!vm:vector-data-offset (1+ index)) + (end-1 (+ sb!vm:vector-data-offset + ;; bit-vectors of length 1-32 + ;; need precisely one (SETF + ;; %RAW-BITS), done here in the + ;; epilogue. - CSR, 2002-04-24 + (truncate (truly-the index (1- length)) + sb!vm:n-word-bits)))) + ((= index end-1) + (setf (%raw-bits result-bit-array index) + (,',wordfun (%raw-bits bit-array-1 index) + (%raw-bits bit-array-2 index))) + result-bit-array) + (declare (optimize (speed 3) (safety 0)) + (type index index end-1)) + (setf (%raw-bits result-bit-array index) + (,',wordfun (%raw-bits bit-array-1 index) + (%raw-bits bit-array-2 index)))))))))) (def bit-and 32bit-logical-and) (def bit-ior 32bit-logical-or) (def bit-xor 32bit-logical-xor) @@ -230,17 +244,28 @@ (error "Argument and result bit arrays are not the same length:~ ~% ~S~% ~S" bit-array result-bit-array)))) - (do ((index sb!vm:vector-data-offset (1+ index)) - (end (+ sb!vm:vector-data-offset - (truncate (the index - (+ (length bit-array) - (1- sb!vm:n-word-bits))) - sb!vm:n-word-bits)))) - ((= index end) result-bit-array) - (declare (optimize (speed 3) (safety 0)) - (type index index end)) - (setf (%raw-bits result-bit-array index) - (32bit-logical-not (%raw-bits bit-array index)))))) + (let ((length (length result-bit-array))) + (if (= length 0) + ;; We avoid doing anything to 0-length bit-vectors, or + ;; rather, the memory that follows them. Other + ;; divisible-by-32 cases are handled by the (1- length), + ;; below. CSR, 2002-04-24 + result-bit-array + (do ((index sb!vm:vector-data-offset (1+ index)) + (end-1 (+ sb!vm:vector-data-offset + ;; bit-vectors of length 1-32 need precisely + ;; one (SETF %RAW-BITS), done here in the + ;; epilogue. - CSR, 2002-04-24 + (truncate (truly-the index (1- length)) + sb!vm:n-word-bits)))) + ((= index end-1) + (setf (%raw-bits result-bit-array index) + (32bit-logical-not (%raw-bits bit-array index))) + result-bit-array) + (declare (optimize (speed 3) (safety 0)) + (type index index end-1)) + (setf (%raw-bits result-bit-array index) + (32bit-logical-not (%raw-bits bit-array index)))))))) ;;;; %BYTE-BLT diff --git a/src/pcl/fast-init.lisp b/src/pcl/fast-init.lisp index b5cb581..b435376 100644 --- a/src/pcl/fast-init.lisp +++ b/src/pcl/fast-init.lisp @@ -491,7 +491,7 @@ initialize-instance-methods))))) (lambda (class1 initargs) (if (not (eq wrapper (class-wrapper class))) - (let* ((info (initialize-info class1 initargs)) + (let* ((info (initialize-info (coerce-to-class class1) initargs)) (fn (initialize-info-make-instance-function info))) (declare (type function fn)) (funcall fn class1 initargs)) @@ -534,7 +534,7 @@ (list wrapper *the-wrapper-of-t*)))) (lambda (class1 initargs) (if (not (eq wrapper (class-wrapper class))) - (let* ((info (initialize-info class1 initargs)) + (let* ((info (initialize-info (coerce-to-class class1) initargs)) (fn (initialize-info-make-instance-function info))) (declare (type function fn)) (funcall fn class1 initargs)) diff --git a/tests/bit-vector.impure-cload.lisp b/tests/bit-vector.impure-cload.lisp new file mode 100644 index 0000000..640470b --- /dev/null +++ b/tests/bit-vector.impure-cload.lisp @@ -0,0 +1,47 @@ +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +;;; the bitvector transforms were buggy prior to sbcl-0.7.3.4 under +;;; speed-optimizing regimes; in particular, they would fail if the +;;; vector length were near ARRAY-DIMENSION-LIMIT. Testing this takes +;;; up a certain amount of time... + +(declaim (optimize (speed 3) (safety 1) (space 0) (compilation-speed 0))) + +(defun bit-vector-test () + ;; deal with the potential length 0 special case + (let ((a (make-array 0 :element-type 'bit)) + (b (make-array 0 :element-type 'bit))) + (assert (equal (bit-not a) #*)) + (assert (equal (bit-xor a b a) #*)) + (assert (equal (bit-and a a b) #*))) + ;; also test some return values for sanity + (let ((a (make-array 33 :element-type 'bit :initial-element 0)) + (b (make-array 33 :element-type 'bit :initial-element 0))) + (assert (equal (bit-not a a) #*111111111111111111111111111111111)) + (setf (aref a 0) 0) ; a = #*011..1 + (setf (aref b 1) 1) ; b = #*010..0 + (assert (equal (bit-xor a b) #*001111111111111111111111111111111)) + (assert (equal (bit-and a b) #*010000000000000000000000000000000))) + ;; now test the biggy, mostly that it works... + (let ((a (make-array (1- array-dimension-limit) :element-type 'bit :initial-element 0)) + (b (make-array (1- array-dimension-limit) :element-type 'bit :initial-element 0))) + (bit-not a a) + (assert (= (aref a 0) 1)) + (assert (= (aref a (- array-dimension-limit 2)) 1)) + (bit-and a b a) + (assert (= (aref a 0) 0)) + (assert (= (aref a (- array-dimension-limit 2)) 0)))) + +(bit-vector-test) + +;;; success +(sb-ext:quit :unix-status 104) diff --git a/tests/clos.impure-cload.lisp b/tests/clos.impure-cload.lisp new file mode 100644 index 0000000..40b53e1 --- /dev/null +++ b/tests/clos.impure-cload.lisp @@ -0,0 +1,32 @@ +;;;; miscellaneous side-effectful tests of CLOS and file-compiler +;;;; optimizations + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +;;; Fix due to pmai, ported from CMUCL, regarding +;;; MAKE-INSTANCES-OBSOLETE: +(defclass mio-test () + ((test :initarg :test))) + +(defun mio-demo () + (let ((x (make-instance 'mio-test :test 42))) + (incf (slot-value x 'test)))) + +(defun mio-test () + (mio-demo) + (make-instances-obsolete 'mio-test) + (mio-demo)) + +(mio-test) + +;;; success +(sb-ext:quit :unix-status 104) \ No newline at end of file diff --git a/version.lisp-expr b/version.lisp-expr index de920e4..75d15b1 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.3.4" +"0.7.3.5"