0.9.1.51:

	* Improve UB*-BASH-COPY by forcing the compiler to use fixnum
	  arithmetic on word-sized copying--avoids spurious fixnum
	  arithmetic overflow checking.  This should improve the
	  performance of REPLACE on character strings on 32-bit platforms;
	* ...use ~D instead of ~A to form UB*-BASH-* function names,
	  protecting ourselves against arbitrary *PRINT-BASE*s;
	* ...belatedly improve test suite for bashing functions to
	  print out the function being tested.  Doing this at least
	  partly assures the user that the test run has not hung.

diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp
index a0c8319..6afe33c 100644 (file)
--- a/src/code/bit-bash.lisp
+++ b/src/code/bit-bash.lisp
@@ -110,7 +110,7 @@
 
 ;;; Align the SAP to a word boundary, and update the offset accordingly.
 (defmacro !define-sap-fixer (bitsize)
-  (let ((name (intern (format nil "FIX-SAP-AND-OFFSET-UB~A" bitsize))))
+  (let ((name (intern (format nil "FIX-SAP-AND-OFFSET-UB~D" bitsize))))
     `(progn
       (declaim (inline ,name))
       (defun ,name (sap offset)
@@ -128,6 +128,10 @@
                        ((8 16 32 64) '(logand address sb!vm:fixnum-tag-mask)))
                      offset)))))))
 
+;;; We cheat a little bit by using TRULY-THE in the copying function to
+;;; force the compiler to generate good code in the (= BITSIZE
+;;; SB!VM:N-WORD-BITS) case.  We don't use TRULY-THE in the other cases
+;;; to give the compiler freedom to generate better code.
 (defmacro !define-byte-bashers (bitsize)
   (let* ((bytes-per-word (/ n-word-bits bitsize))
          (byte-offset `(integer 0 (,bytes-per-word)))
@@ -149,17 +153,17 @@
          (offset `(integer 0 ,max-bytes))
          (max-word-offset (ceiling max-bytes bytes-per-word))
          (word-offset `(integer 0 ,max-word-offset))
-         (fix-sap-and-offset-name (intern (format nil "FIX-SAP-AND-OFFSET-UB~A" bitsize)))
-         (constant-bash-name (intern (format nil "CONSTANT-UB~A-BASH" bitsize) (find-package "SB!KERNEL")))
-         (array-fill-name (intern (format nil "UB~A-BASH-FILL" bitsize) (find-package "SB!KERNEL")))
-         (system-area-fill-name (intern (format nil "SYSTEM-AREA-UB~A-FILL" bitsize) (find-package "SB!KERNEL")))
-         (unary-bash-name (intern (format nil "UNARY-UB~A-BASH" bitsize) (find-package "SB!KERNEL")))
-         (array-copy-name (intern (format nil "UB~A-BASH-COPY" bitsize) (find-package "SB!KERNEL")))
-         (system-area-copy-name (intern (format nil "SYSTEM-AREA-UB~A-COPY" bitsize) (find-package "SB!KERNEL")))
+         (fix-sap-and-offset-name (intern (format nil "FIX-SAP-AND-OFFSET-UB~D" bitsize)))
+         (constant-bash-name (intern (format nil "CONSTANT-UB~D-BASH" bitsize) (find-package "SB!KERNEL")))
+         (array-fill-name (intern (format nil "UB~D-BASH-FILL" bitsize) (find-package "SB!KERNEL")))
+         (system-area-fill-name (intern (format nil "SYSTEM-AREA-UB~D-FILL" bitsize) (find-package "SB!KERNEL")))
+         (unary-bash-name (intern (format nil "UNARY-UB~D-BASH" bitsize) (find-package "SB!KERNEL")))
+         (array-copy-name (intern (format nil "UB~D-BASH-COPY" bitsize) (find-package "SB!KERNEL")))
+         (system-area-copy-name (intern (format nil "SYSTEM-AREA-UB~D-COPY" bitsize) (find-package "SB!KERNEL")))
          (array-copy-to-system-area-name
-          (intern (format nil "COPY-UB~A-TO-SYSTEM-AREA" bitsize) (find-package "SB!KERNEL")))
+          (intern (format nil "COPY-UB~D-TO-SYSTEM-AREA" bitsize) (find-package "SB!KERNEL")))
          (system-area-copy-to-array-name
-          (intern (format nil "COPY-UB~A-FROM-SYSTEM-AREA" bitsize)
+          (intern (format nil "COPY-UB~D-FROM-SYSTEM-AREA" bitsize)
                   (find-package "SB!KERNEL"))))
     `(progn
       (declaim (inline ,constant-bash-name ,unary-bash-name))
@@ -199,6 +203,13 @@
                                                      (word-logical-andc2 (funcall dst-ref-fn dst dst-word-offset)
                                                                          mask))))
                          (incf dst-word-offset))))
+                  (let ((end (+ dst-word-offset interior)))
+                    (declare (type ,word-offset end))
+                    (do ()
+                        ((>= dst-word-offset end))
+                      (funcall dst-set-fn dst dst-word-offset value)
+                      (incf dst-word-offset)))
+                  #+nil
                   (dotimes (i interior)
                     (funcall dst-set-fn dst dst-word-offset value)
                     (incf dst-word-offset))
@@ -334,10 +345,19 @@
                                 (incf src-word-offset)
                                 (incf dst-word-offset))))
                          ;; Copy the interior words.
-                         (dotimes (i interior)
-                           (funcall dst-set-fn dst dst-word-offset (funcall src-ref-fn src src-word-offset))
-                           (incf src-word-offset)
-                           (incf dst-word-offset))
+                         (let ((end ,(if (= bytes-per-word 1)
+                                         `(truly-the ,word-offset
+                                           (+ dst-word-offset interior))
+                                         `(+ dst-word-offset interior))))
+                           (declare (type ,word-offset end))
+                           (do ()
+                               ((>= dst-word-offset end))
+                             (funcall dst-set-fn dst dst-word-offset
+                                      (funcall src-ref-fn src src-word-offset))
+                             ,(if (= bytes-per-word 1)
+                                  `(setf src-word-offset (truly-the ,word-offset (+ src-word-offset 1)))
+                                  `(incf src-word-offset))
+                             (incf dst-word-offset)))
                          ,@(unless (= bytes-per-word 1)
                             `((unless (zerop final-bytes)
                                 ;; We are only writing part of the last word.
@@ -350,8 +370,14 @@
                                                             (word-logical-andc2 orig mask))))))))
                         (t
                          ;; We need to loop from right to left.
-                         (incf dst-word-offset words)
-                         (incf src-word-offset words)
+                         ,(if (= bytes-per-word 1)
+                              `(setf dst-word-offset (truly-the ,word-offset
+                                                      (+ dst-word-offset words)))
+                              `(incf dst-word-offset words))
+                         ,(if (= bytes-per-word 1)
+                              `(setf src-word-offset (truly-the ,word-offset
+                                                      (+ src-word-offset words)))
+                              `(incf src-word-offset words))
                          ,@(unless (= bytes-per-word 1)
                             `((unless (zerop final-bytes)
                                 (let ((mask (start-mask (* final-bytes ,bitsize)))
@@ -361,10 +387,13 @@
                                   (funcall dst-set-fn dst dst-word-offset
                                            (word-logical-or (word-logical-and value mask)
                                                             (word-logical-andc2 orig mask)))))))
-                         (dotimes (i interior)
-                           (decf src-word-offset)
-                           (decf dst-word-offset)
-                           (funcall dst-set-fn dst dst-word-offset (funcall src-ref-fn src src-word-offset)))
+                         (let ((end (- dst-word-offset interior)))
+                           (do ()
+                               ((<= dst-word-offset end))
+                             (decf src-word-offset)
+                             (decf dst-word-offset)
+                             (funcall dst-set-fn dst dst-word-offset
+                                      (funcall src-ref-fn src src-word-offset))))
                          ,@(unless (= bytes-per-word 1)
                             `((unless (zerop dst-byte-offset)
                                 ;; We are only writing part of the last word.
@@ -396,7 +425,8 @@
                            (declare (type word prev next))
                            (flet ((get-next-src ()
                                     (setf prev next)
-                                    (setf next (funcall src-ref-fn src (incf src-word-offset)))))
+                                    (setf next (funcall src-ref-fn src
+                                                        (setf src-word-offset (incf src-word-offset))))))
                              (declare (inline get-next-src))
                              ,@(unless (= bytes-per-word 1)
                                 `((unless (zerop dst-byte-offset)
@@ -411,14 +441,17 @@
                                                (word-logical-or (word-logical-and value mask)
                                                                 (word-logical-andc2 orig mask))))
                                     (incf dst-word-offset))))
-                             (dotimes (i interior)
-                               (get-next-src)
-                               (let ((value (word-logical-or
-                                             (shift-towards-end next (* (- src-shift) ,bitsize))
-                                             (shift-towards-start prev (* src-shift ,bitsize)))))
-                                 (declare (type word value))
-                                 (funcall dst-set-fn dst dst-word-offset value)
-                                 (incf dst-word-offset)))
+                             (let ((end (+ dst-word-offset interior)))
+                               (declare (type ,word-offset end))
+                               (do ()
+                                   ((>= dst-word-offset end))
+                                 (get-next-src)
+                                 (let ((value (word-logical-or
+                                               (shift-towards-end next (* (- src-shift) ,bitsize))
+                                               (shift-towards-start prev (* src-shift ,bitsize)))))
+                                   (declare (type word value))
+                                   (funcall dst-set-fn dst dst-word-offset value)
+                                   (incf dst-word-offset))))
                              ,@(unless (= bytes-per-word 1)
                                 `((unless (zerop final-bytes)
                                     (let ((value
@@ -438,8 +471,7 @@
                         (t
                          ;; We need to loop from right to left.
                          (incf dst-word-offset words)
-                         (incf src-word-offset
-                               (1- (ceiling (+ src-byte-offset length) ,bytes-per-word)))
+                         (incf src-word-offset (1- (ceiling (+ src-byte-offset length) ,bytes-per-word)))
                          (let ((next 0)
                                (prev (funcall src-ref-fn src src-word-offset)))
                            (declare (type word prev next))
@@ -461,14 +493,16 @@
                                                (word-logical-or (word-logical-and value mask)
                                                                 (word-logical-andc2 orig mask)))))))
                              (decf dst-word-offset)
-                             (dotimes (i interior)
-                               (get-next-src)
-                               (let ((value (word-logical-or
-                                             (shift-towards-end next (* (- src-shift) ,bitsize))
-                                             (shift-towards-start prev (* src-shift ,bitsize)))))
-                                 (declare (type word value))
-                                 (funcall dst-set-fn dst dst-word-offset value)
-                                 (decf dst-word-offset)))
+                             (let ((end (- dst-word-offset interior)))
+                               (do ()
+                                   ((<= dst-word-offset end))
+                                 (get-next-src)
+                                 (let ((value (word-logical-or
+                                               (shift-towards-end next (* (- src-shift) ,bitsize))
+                                               (shift-towards-start prev (* src-shift ,bitsize)))))
+                                   (declare (type word value))
+                                   (funcall dst-set-fn dst dst-word-offset value)
+                                   (decf dst-word-offset))))
                              ,@(unless (= bytes-per-word 1)
                                 `((unless (zerop dst-byte-offset)
                                     (if (> src-byte-offset dst-byte-offset)

diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index 969c562..d658516 100644 (file)
--- a/src/code/stream.lisp
+++ b/src/code/stream.lisp
@@ -466,7 +466,7 @@
                          (find 'character
                                sb!vm:*specialized-array-element-type-properties*
                                :key #'sb!vm:saetp-specifier)))
-                       (bash-function (intern (format nil "UB~A-BASH-COPY" n-character-array-bits)
+                       (bash-function (intern (format nil "UB~D-BASH-COPY" n-character-array-bits)
                                               (find-package "SB!KERNEL"))))
                   bash-function)
                 ibuf +ansi-stream-in-buffer-extra+

diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp
index 1f3f2ae..e8848a2 100644 (file)
--- a/src/compiler/generic/vm-fndb.lisp
+++ b/src/compiler/generic/vm-fndb.lisp
@@ -320,22 +320,22 @@
 (macrolet ((define-known-copiers ()
             `(progn
               ,@(loop for i = 1 then (* i 2)
-                      collect `(defknown ,(intern (format nil "UB~A-BASH-COPY" i)
+                      collect `(defknown ,(intern (format nil "UB~D-BASH-COPY" i)
                                                   (find-package "SB!KERNEL"))
                                 ((simple-unboxed-array (*)) index (simple-unboxed-array (*)) index index)
                                 (values)
                                 ())
-                      collect `(defknown ,(intern (format nil "SYSTEM-AREA-UB~A-COPY" i)
+                      collect `(defknown ,(intern (format nil "SYSTEM-AREA-UB~D-COPY" i)
                                                   (find-package "SB!KERNEL"))
                                 (system-area-pointer index system-area-pointer index index)
                                 (values)
                                 ())
-                      collect `(defknown ,(intern (format nil "COPY-UB~A-TO-SYSTEM-AREA" i)
+                      collect `(defknown ,(intern (format nil "COPY-UB~D-TO-SYSTEM-AREA" i)
                                                   (find-package "SB!KERNEL"))
                                 ((simple-unboxed-array (*)) index system-area-pointer index index)
                                 (values)
                                 ())
-                      collect `(defknown ,(intern (format nil "COPY-UB~A-FROM-SYSTEM-AREA" i)
+                      collect `(defknown ,(intern (format nil "COPY-UB~D-FROM-SYSTEM-AREA" i)
                                                   (find-package "SB!KERNEL"))
                                 (system-area-pointer index (simple-unboxed-array (*)) index index)
                                 (values)

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index ed8cae7..a7a33b7 100644 (file)
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -703,7 +703,7 @@
              collect
              (let* ((sequence-type `(simple-array ,(sb!vm:saetp-specifier saetp) (*)))
                     (n-element-bits (sb!vm:saetp-n-bits saetp))
-                    (bash-function (intern (format nil "UB~A-BASH-COPY" n-element-bits)
+                    (bash-function (intern (format nil "UB~D-BASH-COPY" n-element-bits)
                                             (find-package "SB!KERNEL"))))
                `(deftransform replace ((seq1 seq2 &key (start1 0) (start2 0) end1 end2)
                                        (,sequence-type ,sequence-type &rest t)
@@ -737,7 +737,7 @@
              collect
              (let* ((sequence-type `(simple-array ,(sb!vm:saetp-specifier saetp) (*)))
                     (n-element-bits (sb!vm:saetp-n-bits saetp))
-                    (bash-function (intern (format nil "UB~A-BASH-COPY" n-element-bits)
+                    (bash-function (intern (format nil "UB~D-BASH-COPY" n-element-bits)
                                            (find-package "SB!KERNEL"))))
                `(deftransform subseq ((seq start &optional end)
                                       (,sequence-type t &optional t)
@@ -764,7 +764,7 @@
              collect
              (let* ((sequence-type `(simple-array ,(sb!vm:saetp-specifier saetp) (*)))
                     (n-element-bits (sb!vm:saetp-n-bits saetp))
-                    (bash-function (intern (format nil "UB~A-BASH-COPY" n-element-bits)
+                    (bash-function (intern (format nil "UB~D-BASH-COPY" n-element-bits)
                                            (find-package "SB!KERNEL"))))
                `(deftransform copy-seq ((seq) (,sequence-type)
                                         ,sequence-type)

diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp
index 2570a73..acb8dab 100644 (file)
--- a/tests/seq.impure.lisp
+++ b/tests/seq.impure.lisp
@@ -924,6 +924,7 @@
          (fill-amounts (collect-fill-amounts n-power))
          (bash-function (intern (format nil "UB~A-BASH-FILL" bitsize)
                                 (find-package "SB-KERNEL"))))
+    (format t "~&/Function ~A..." bash-function)
     (loop for offset from padding-amount below (* 2 padding-amount) do
           (dolist (c (fill-bytes-for-testing bitsize))
             (dolist (n fill-amounts)
@@ -955,6 +956,7 @@
          (fill-amounts (collect-fill-amounts n-power))
          (bash-function (intern (format nil "UB~A-BASH-COPY" bitsize)
                                 (find-package "SB-KERNEL"))))
+    (format t "~&/Function ~A..." bash-function)
     (do ((source-offset padding-amount (1+ source-offset)))
         ((>= source-offset (* padding-amount 2))
          ;; success!

diff --git a/version.lisp-expr b/version.lisp-expr
index cea0dac..c38b598 100644 (file)
--- 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.9.1.50"
+"0.9.1.51"