From b08e81cd5a06fe5d792f0be1d1c2bf3409a4ae60 Mon Sep 17 00:00:00 2001 From: Nathan Froyd Date: Fri, 17 Jun 2005 19:23:29 +0000 Subject: [PATCH] 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. --- src/code/bit-bash.lisp | 112 ++++++++++++++++++++++++------------- src/code/stream.lisp | 2 +- src/compiler/generic/vm-fndb.lisp | 8 +-- src/compiler/seqtran.lisp | 6 +- tests/seq.impure.lisp | 2 + version.lisp-expr | 2 +- 6 files changed, 84 insertions(+), 48 deletions(-) diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp index a0c8319..6afe33c 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4