Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/compiler array-tran.lisp, 1.90, 1.91 dump.lisp, 1.69, 1.70 seqtran.lisp, 1.101, 1.102
|
From: Nikodemus S. <de...@us...> - 2009-05-17 17:30:32
|
Update of /cvsroot/sbcl/sbcl/src/compiler In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv4676/src/compiler Modified Files: array-tran.lisp dump.lisp seqtran.lisp Log Message: 1.0.28.55: transform FILL to a UB*-BASH-FILL when possible The performance boost for all cases which previously used VECTOR-FILL* is quite noticeable. Also delay the FILL transform if the vector element type is not yet known. ...also one leftover #+sb-xc-host from the previous commit. Index: array-tran.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/array-tran.lisp,v retrieving revision 1.90 retrieving revision 1.91 diff -u -d -r1.90 -r1.91 --- array-tran.lisp 16 May 2009 12:23:13 -0000 1.90 +++ array-tran.lisp 17 May 2009 17:30:23 -0000 1.91 @@ -343,11 +343,14 @@ (not (eql default-initial-element (lvar-value initial-element))))) (let ((parameters (eliminate-keyword-args call 1 '((:element-type element-type) - (:initial-element initial-element))))) + (:initial-element initial-element)))) + (init (if (constant-lvar-p initial-element) + (lvar-value initial-element) + 'initial-element))) `(lambda (length ,@parameters) (declare (ignorable ,@parameters)) (truly-the ,result-spec - (fill ,alloc-form (the ,elt-spec initial-element)))))) + (fill ,alloc-form (the ,elt-spec ,init)))))) ;; just :ELEMENT-TYPE, or maybe with :INITIAL-ELEMENT EQL to the ;; default (t Index: dump.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/dump.lisp,v retrieving revision 1.69 retrieving revision 1.70 diff -u -d -r1.69 -r1.70 --- dump.lisp 17 May 2009 17:11:59 -0000 1.69 +++ dump.lisp 17 May 2009 17:30:23 -0000 1.70 @@ -610,10 +610,6 @@ (dump-complex-double-float (realpart x) (imagpart x) file)) #!+long-float ((complex long-float) - ;; (There's no easy way to mix #!+LONG-FLOAT and #-SB-XC-HOST - ;; conditionalization at read time, so we do this SB-XC-HOST - ;; conditional at runtime instead.) - #+sb-xc-host (error "can't dump COMPLEX-LONG-FLOAT in cross-compiler") (dump-fop 'fop-complex-long-float file) (dump-long-float (realpart x) file) (dump-long-float (imagpart x) file)) Index: seqtran.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/seqtran.lisp,v retrieving revision 1.101 retrieving revision 1.102 diff -u -d -r1.101 -r1.102 --- seqtran.lisp 1 May 2009 10:35:43 -0000 1.101 +++ seqtran.lisp 17 May 2009 17:30:23 -0000 1.102 @@ -516,9 +516,90 @@ (vector t &key (:start t) (:end t)) * :node node) - (let ((type (lvar-type seq)) - (element-type (type-specifier (extract-upgraded-element-type seq)))) - (cond ((and (neq '* element-type) (policy node (> speed space))) + (let* ((element-ctype (extract-upgraded-element-type seq)) + (element-type (type-specifier element-ctype)) + (type (lvar-type seq)) + (saetp (unless (eq *wild-type* element-ctype) + (find-saetp-by-ctype element-ctype)))) + (cond ((eq *wild-type* element-ctype) + (delay-ir1-transform node :constraint) + `(vector-fill* seq item start end)) + ((and saetp (sb!vm::valid-bit-bash-saetp-p saetp)) + (let* ((n-bits (sb!vm:saetp-n-bits saetp)) + (basher-name (format nil "UB~D-BASH-FILL" n-bits)) + (basher (or (find-symbol basher-name + (load-time-value (find-package :sb!kernel))) + (abort-ir1-transform + "Unknown fill basher, please report to sbcl-devel: ~A" + basher-name))) + (kind (cond ((sb!vm:saetp-fixnum-p saetp) :tagged) + ((member element-type '(character base-char)) :char) + ((eq element-type 'single-float) :single-float) + ((eq element-type 'double-float) :double-float) + (t :bits))) + ;; BASH-VALUE is a word that we can repeatedly smash + ;; on the array: for less-than-word sized elements it + ;; contains multiple copies of the fill item. + (bash-value + (if (constant-lvar-p item) + (let ((tmp (lvar-value item))) + (unless (ctypep tmp element-ctype) + (abort-ir1-transform "~S is not ~S" tmp element-type)) + (let* ((bits + (ldb (byte n-bits 0) + (ecase kind + (:tagged + (ash tmp sb!vm:n-fixnum-tag-bits)) + (:char + (char-code tmp)) + (:bits + tmp) + (:single-float + (single-float-bits tmp)) + (:double-float + (logior (ash (double-float-high-bits tmp) 32) + (double-float-low-bits tmp)))))) + (res bits)) + (loop for i of-type sb!vm:word from n-bits by n-bits + until (= i sb!vm:n-word-bits) + do (setf res (ldb (byte sb!vm:n-word-bits 0) + (logior res (ash bits i))))) + res)) + `(let* ((bits (ldb (byte ,n-bits 0) + ,(ecase kind + (:tagged + `(ash item ,sb!vm:n-fixnum-tag-bits)) + (:char + `(char-code item)) + (:bits + `item) + (:single-float + `(single-float-bits item)) + (:double-float + `(logior (ash (double-float-high-bits item) 32) + (double-float-low-bits item)))))) + (res bits)) + (declare (type sb!vm:word res)) + ,@(unless (= sb!vm:n-word-bits n-bits) + `((loop for i of-type sb!vm:word from ,n-bits by ,n-bits + until (= i sb!vm:n-word-bits) + do (setf res + (ldb (byte ,sb!vm:n-word-bits 0) + (logior res (ash bits (truly-the (integer 0 ,(- sb!vm:n-word-bits n-bits)) i)))))))) + res)))) + (values + `(with-array-data ((data seq) + (start start) + (end end) + :check-fill-pointer t) + (declare (type (simple-array ,element-type 1) data)) + (declare (type index start end)) + (declare (optimize (safety 0) (speed 3)) + (muffle-conditions compiler-note)) + (,basher ,bash-value data start (- end start)) + seq) + `((declare (type ,element-type item)))))) + ((policy node (> speed space)) (values `(with-array-data ((data seq) (start start) @@ -625,20 +706,6 @@ (def!constant vector-data-bit-offset (* sb!vm:vector-data-offset sb!vm:n-word-bits)) -(eval-when (:compile-toplevel) -(defun valid-bit-bash-saetp-p (saetp) - ;; BIT-BASHing isn't allowed on simple vectors that contain pointers - (and (not (eq t (sb!vm:saetp-specifier saetp))) - ;; Disallowing (VECTOR NIL) also means that we won't transform - ;; sequence functions into bit-bashing code and we let the - ;; generic sequence functions signal errors if necessary. - (not (zerop (sb!vm:saetp-n-bits saetp))) - ;; Due to limitations with the current BIT-BASHing code, we can't - ;; BIT-BASH reliably on arrays whose element types are larger - ;; than the word size. - (<= (sb!vm:saetp-n-bits saetp) sb!vm:n-word-bits))) -) ; EVAL-WHEN - ;;; FIXME: In the copy loops below, we code the loops in a strange ;;; fashion: ;;; @@ -694,7 +761,7 @@ (unless (<= 0 start2 end2 len2) (sequence-bounding-indices-bad-error seq2 start2 end2)))) ,',(cond - ((and saetp (valid-bit-bash-saetp-p saetp)) + ((and saetp (sb!vm:valid-bit-bash-saetp-p saetp)) (let* ((n-element-bits (sb!vm:saetp-n-bits saetp)) (bash-function (intern (format nil "UB~D-BASH-COPY" n-element-bits) |