index offset &optional setter-p)
(multiple-value-bind (func index-args) (extract-fun-args index '(+ -) 2)
(destructuring-bind (x constant) index-args
- (declare (ignorable x))
- (unless (constant-lvar-p constant)
+ (unless (and (constant-lvar-p constant)
+ ;; we lose if the remaining argument isn't a fixnum
+ (csubtypep (lvar-type x) (specifier-type 'fixnum)))
(give-up-ir1-transform))
- (let ((value (lvar-value constant)))
+ (let ((value (lvar-value constant))
+ new-offset)
(unless (and (integerp value)
(sb!vm::foldable-constant-offset-p
element-size lowtag data-offset
- (funcall func value (lvar-value offset))))
+ (setf new-offset (funcall func (lvar-value offset)
+ value))))
(give-up-ir1-transform "constant is too large for inlining"))
(splice-fun-args index func 2)
`(lambda (thing index off1 off2 ,@(when setter-p
'(value)))
- (,fun-name thing index (,func off2 off1) ,@(when setter-p
- '(value))))))))
+ (declare (ignore off1 off2))
+ (,fun-name thing index ',new-offset ,@(when setter-p
+ '(value))))))))
#!+(or x86 x86-64)
(deftransform sb!bignum:%bignum-ref-with-offset
(define-source-transform %set-funcallable-instance-layout (x val)
`(setf (%funcallable-instance-info ,x 0) (the layout ,val)))
\f
-;;;; character support
-
-;;; In our implementation there are really only BASE-CHARs.
-#+nil
-(define-source-transform characterp (obj)
- `(base-char-p ,obj))
-\f
;;;; simplifying HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET
(deftransform hairy-data-vector-ref ((string index) (simple-string t))
((simple-array nil (*))
(data-vector-ref string index))))))
-(deftransform hairy-data-vector-ref ((array index) (array t) *)
+;;; This and the corresponding -SET transform work equally well on non-simple
+;;; arrays, but after benchmarking (on x86), Nikodemus didn't find any cases
+;;; where it actually helped with non-simple arrays -- to the contrary, it
+;;; only made for bigger and up to 100% slower code.
+(deftransform hairy-data-vector-ref ((array index) (simple-array t) *)
"avoid runtime dispatch on array element type"
- (let ((element-ctype (extract-upgraded-element-type array))
- (declared-element-ctype (extract-declared-element-type array)))
+ (let* ((type (lvar-type array))
+ (element-ctype (array-type-upgraded-element-type type))
+ (declared-element-ctype (array-type-declared-element-type type)))
(declare (type ctype element-ctype))
(when (eq *wild-type* element-ctype)
(give-up-ir1-transform
((simple-array nil (*))
(data-vector-set string index new-value))))))
+;;; This and the corresponding -REF transform work equally well on non-simple
+;;; arrays, but after benchmarking (on x86), Nikodemus didn't find any cases
+;;; where it actually helped with non-simple arrays -- to the contrary, it
+;;; only made for bigger and up 1o 100% slower code.
(deftransform hairy-data-vector-set ((array index new-value)
- (array t t)
+ (simple-array t t)
*)
"avoid runtime dispatch on array element type"
- (let ((element-ctype (extract-upgraded-element-type array))
- (declared-element-ctype (extract-declared-element-type array)))
+ (let* ((type (lvar-type array))
+ (element-ctype (array-type-upgraded-element-type type))
+ (declared-element-ctype (array-type-declared-element-type type)))
(declare (type ctype element-ctype))
(when (eq *wild-type* element-ctype)
(give-up-ir1-transform
sb!vm:vector-data-offset
index offset t))))
-(defoptimizer (%data-vector-and-index derive-type) ((array index))
- (let ((atype (lvar-type array)))
+(defun maybe-array-data-vector-type-specifier (array-lvar)
+ (let ((atype (lvar-type array-lvar)))
(when (array-type-p atype)
- (values-specifier-type
- `(values (simple-array ,(type-specifier
- (array-type-specialized-element-type atype))
- (*))
- index)))))
+ (let ((dims (array-type-dimensions atype)))
+ (if (or (array-type-complexp atype)
+ (eq '* dims)
+ (notevery #'integerp dims))
+ `(simple-array ,(type-specifier
+ (array-type-specialized-element-type atype))
+ (*))
+ `(simple-array ,(type-specifier
+ (array-type-specialized-element-type atype))
+ (,(apply #'* dims))))))))
+
+(macrolet ((def (name)
+ `(defoptimizer (,name derive-type) ((array-lvar))
+ (let ((spec (maybe-array-data-vector-type-specifier array-lvar)))
+ (when spec
+ (specifier-type spec))))))
+ (def %array-data-vector)
+ (def array-storage-vector))
+
+(defoptimizer (%data-vector-and-index derive-type) ((array index))
+ (let ((spec (maybe-array-data-vector-type-specifier array)))
+ (when spec
+ (values-specifier-type `(values ,spec index)))))
(deftransform %data-vector-and-index ((%array %index)
(simple-array t)
'(if (array-header-p %array)
(values (%array-data-vector %array) %index)
(values %array %index)))
-
-;;; transforms for getting at simple arrays of (UNSIGNED-BYTE N) when (< N 8)
-;;;
-;;; FIXME: In CMU CL, these were commented out with #+NIL. Why? Should
-;;; we fix them or should we delete them? (Perhaps these definitions
-;;; predate the various DATA-VECTOR-REF-FOO VOPs which have
-;;; (:TRANSLATE DATA-VECTOR-REF), and are redundant now?)
-#+nil
-(macrolet
- ((frob (type bits)
- (let ((elements-per-word (truncate sb!vm:n-word-bits bits)))
- `(progn
- (deftransform data-vector-ref ((vector index)
- (,type *))
- `(multiple-value-bind (word bit)
- (floor index ,',elements-per-word)
- (ldb ,(ecase sb!vm:target-byte-order
- (:little-endian '(byte ,bits (* bit ,bits)))
- (:big-endian '(byte ,bits (- sb!vm:n-word-bits
- (* (1+ bit) ,bits)))))
- (%vector-raw-bits vector word))))
- (deftransform data-vector-set ((vector index new-value)
- (,type * *))
- `(multiple-value-bind (word bit)
- (floor index ,',elements-per-word)
- (setf (ldb ,(ecase sb!vm:target-byte-order
- (:little-endian '(byte ,bits (* bit ,bits)))
- (:big-endian
- '(byte ,bits (- sb!vm:n-word-bits
- (* (1+ bit) ,bits)))))
- (%vector-raw-bits vector word))
- new-value)))))))
- (frob simple-bit-vector 1)
- (frob (simple-array (unsigned-byte 2) (*)) 2)
- (frob (simple-array (unsigned-byte 4) (*)) 4))
\f
;;;; BIT-VECTOR hackery
(values)))
\f
;;;; transforms for EQL of floating point values
-
+#!-float-eql-vops
(deftransform eql ((x y) (single-float single-float))
'(= (single-float-bits x) (single-float-bits y)))
+#!-float-eql-vops
(deftransform eql ((x y) (double-float double-float))
'(and (= (double-float-low-bits x) (double-float-low-bits y))
(= (double-float-high-bits x) (double-float-high-bits y))))
;; This should really be dependent on SB!VM:N-WORD-BITS, but since we
;; don't have a true Alpha64 port yet, we'll have to stick to
;; SB!VM:N-MACHINE-WORD-BITS for the time being. --njf, 2004-08-14
- #!+#.(cl:if (cl:= 32 sb!vm:n-machine-word-bits) '(and) '(or))
- (progn
- #!+x86 (def sb!vm::ash-left-smod30 :tagged 30 t)
- (def sb!vm::ash-left-mod32 :untagged 32 nil))
- #!+#.(cl:if (cl:= 64 sb!vm:n-machine-word-bits) '(and) '(or))
- (progn
- #!+x86-64 (def sb!vm::ash-left-smod61 :tagged 61 t)
- (def sb!vm::ash-left-mod64 :untagged 64 nil)))
+ #.`(progn
+ #!+(or x86 x86-64)
+ (def sb!vm::ash-left-modfx
+ :tagged ,(- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits) t)
+ (def ,(intern (format nil "ASH-LEFT-MOD~D" sb!vm:n-machine-word-bits)
+ "SB!VM")
+ :untagged ,sb!vm:n-machine-word-bits nil)))
\f
;;;; word-wise logical operations
projects / sbcl.git / blobdiff