the symbol, prohibits both lexical and dynamic binding. This is mainly an
efficiency measure for threaded platforms, but also valueable in
expressing intent.
+ * optimization: the compiler uses a specialized version of FILL when the
+ element type is know in more cases, making eg. (UNSIGNED-BYTE 8) case
+ almost 90% faster.
* optimization: accesses to potentially non-simple arrays where element type
is known are 50% faster.
* optimization: compiler now generates faster array typechecking code.
"SAETP-N-BITS" "SAETP-TYPECODE" "SAETP-PRIMITIVE-TYPE-NAME"
"SAETP-N-PAD-ELEMENTS" "SAETP-SPECIFIER"
"SAETP-COMPLEX-TYPECODE" "SAETP-IMPORTANCE"
+ "SAETP-FIXNUM-P"
+ "VALID-BIT-BASH-SAETP-P"
"*SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*"
"SANCTIFY-FOR-EXECUTION"
"SAP-POINTER-SLOT" "SAP-REG-SC-NUMBER" "SAP-SIZE"
(end end)
:force-inline t
:check-fill-pointer t)
- (macrolet ((frob ()
- `(locally (declare (optimize (safety 0) (speed 3)))
- (do ((i start (1+ i)))
- ((= i end) sequence)
- (declare (index i))
- (setf (aref data i) item)))))
- (etypecase data
- #!+sb-unicode
- ((simple-array character (*))
- (let ((item (locally (declare (optimize (safety 3)))
- (the character item))))
- (frob)))
- ((simple-array base-char (*))
- (let ((item (locally (declare (optimize (safety 3)))
- (the base-char item))))
- (frob)))))))
+ ;; DEFTRANSFORM for FILL will turn these into
+ ;; calls to UB*-BASH-FILL.
+ (etypecase data
+ #!+sb-unicode
+ ((simple-array character (*))
+ (let ((item (locally (declare (optimize (safety 3)))
+ (the character item))))
+ (fill data item :start start :end end)))
+ ((simple-array base-char (*))
+ (let ((item (locally (declare (optimize (safety 3)))
+ (the base-char item))))
+ (fill data item :start start :end end))))))
(defun fill (sequence item &key (start 0) end)
#!+sb-doc
(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
(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))
initial-element-default
n-bits
primitive-type-name
- &key (n-pad-elements 0) complex-typecode (importance 0)
+ &key (n-pad-elements 0) complex-typecode (importance 0) fixnum-p
&aux (typecode
(symbol-value (symbolicate primitive-type-name "-WIDETAG")))))
(:copier nil))
;; the element type, e.g. #<BUILT-IN-CLASS BASE-CHAR (sealed)> or
;; #<SB-KERNEL:NUMERIC-TYPE (UNSIGNED-BYTE 4)>
(ctype nil :type (or ctype null))
+ ;; true if the elements are tagged fixnums
+ (fixnum-p nil :type boolean :read-only t)
;; what we get when the low-level vector-creation logic zeroes all
;; the bits (which also serves as the default value of MAKE-ARRAY's
;; :INITIAL-ELEMENT keyword)
:importance 12)
#!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
((unsigned-byte 29) 0 32 simple-array-unsigned-byte-29
- :importance 8)
+ :importance 8
+ :fixnum-p t)
((unsigned-byte 31) 0 32 simple-array-unsigned-byte-31
:importance 11)
((unsigned-byte 32) 0 32 simple-array-unsigned-byte-32
:importance 11)
#!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
((unsigned-byte 60) 0 64 simple-array-unsigned-byte-60
- :importance 8)
+ :importance 8
+ :fixnum-p t)
#!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
((unsigned-byte 63) 0 64 simple-array-unsigned-byte-63
:importance 9)
;; not (SIGNED-BYTE 30)
#!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
(fixnum 0 32 simple-array-signed-byte-30
- :importance 8)
+ :importance 8
+ :fixnum-p t)
((signed-byte 32) 0 32 simple-array-signed-byte-32
:importance 7)
;; KLUDGE: see above KLUDGE for the 32-bit case
#!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
(fixnum 0 64 simple-array-signed-byte-61
- :importance 8)
+ :importance 8
+ :fixnum-p t)
#!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
((signed-byte 64) 0 64 simple-array-signed-byte-64
:importance 7)
:importance 1)
(t 0 #.sb!vm:n-word-bits simple-vector :importance 18))))
+(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)))
+
(defvar sb!kernel::*specialized-array-element-types*
(map 'list
#'saetp-specifier
(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)
(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:
;;;
(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)
standard bashed)
;; fill vectors
;; a) the standard slow way
- (fill standard c :start offset :end (+ offset n))
+ (locally (declare (notinline fill))
+ (fill standard c :start offset :end (+ offset n)))
;; b) the blazingly fast way
(let ((value (loop for i from 0 by bitsize
until (= i sb-vm:n-word-bits)
;;; 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".)
-"1.0.28.54"
+"1.0.28.55"
projects / sbcl.git / commitdiff