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 (file)
--- 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))))))))
 \f
 ;;;; %BYTE-BLT
 

diff --git a/src/pcl/fast-init.lisp b/src/pcl/fast-init.lisp
index b5cb581..b435376 100644 (file)
--- 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 (file)
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)
+\f
+;;; 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 (file)
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)
+\f
+;;; 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 (file)
--- 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"