(define-source-transform long-float-p (x) `(double-float-p ,x))
(define-source-transform compiled-function-p (x)
- `(functionp ,x))
+ #!-sb-eval
+ `(functionp ,x)
+ #!+sb-eval
+ (once-only ((x x))
+ `(and (functionp ,x)
+ (not (sb!eval:interpreted-function-p ,x)))))
(define-source-transform char-int (x)
`(char-code ,x))
(deftransform abs ((x) (rational))
'(if (< x 0) (- x) x))
+;;; We don't want to clutter the bignum code.
+#!+(or x86 x86-64)
+(define-source-transform sb!bignum:%bignum-ref (bignum index)
+ ;; KLUDGE: We use TRULY-THE here because even though the bignum code
+ ;; is (currently) compiled with (SAFETY 0), the compiler insists on
+ ;; inserting CAST nodes to ensure that INDEX is of the correct type.
+ ;; These CAST nodes do not generate any type checks, but they do
+ ;; interfere with the operation of FOLD-INDEX-ADDRESSING, below.
+ ;; This scenario is a problem for the more user-visible case of
+ ;; folding as well. --njf, 2006-12-01
+ `(sb!bignum:%bignum-ref-with-offset ,bignum
+ (truly-the bignum-index ,index) 0))
+
+#!+(or x86 x86-64)
+(defun fold-index-addressing (fun-name element-size lowtag data-offset
+ 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)
+ (give-up-ir1-transform))
+ (let ((value (lvar-value constant)))
+ (unless (and (integerp value)
+ (sb!vm::foldable-constant-offset-p
+ element-size lowtag data-offset
+ (funcall func value (lvar-value offset))))
+ (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))))))))
+
+#!+(or x86 x86-64)
+(deftransform sb!bignum:%bignum-ref-with-offset
+ ((bignum index offset) * * :node node)
+ (fold-index-addressing 'sb!bignum:%bignum-ref-with-offset
+ sb!vm:n-word-bits sb!vm:other-pointer-lowtag
+ sb!vm:bignum-digits-offset
+ index offset))
+
+#!+x86
+(progn
+(define-source-transform sb!kernel:%vector-raw-bits (thing index)
+ `(sb!kernel:%raw-bits-with-offset ,thing ,index 2))
+
+(define-source-transform sb!kernel:%raw-bits (thing index)
+ `(sb!kernel:%raw-bits-with-offset ,thing ,index 0))
+
+(define-source-transform sb!kernel:%set-vector-raw-bits (thing index value)
+ `(sb!kernel:%set-raw-bits-with-offset ,thing ,index 2 ,value))
+
+(define-source-transform sb!kernel:%set-raw-bits (thing index value)
+ `(sb!kernel:%set-raw-bits-with-offset ,thing ,index 0 ,value))
+
+(deftransform sb!kernel:%raw-bits-with-offset ((thing index offset) * * :node node)
+ (fold-index-addressing 'sb!kernel:%raw-bits-with-offset
+ sb!vm:n-word-bits sb!vm:other-pointer-lowtag
+ 0 index offset))
+
+(deftransform sb!kernel:%set-raw-bits-with-offset ((thing index offset value) * *)
+ (fold-index-addressing 'sb!kernel:%set-raw-bits-with-offset
+ sb!vm:n-word-bits sb!vm:other-pointer-lowtag
+ 0 index offset t))
+) ; PROGN
+
;;; The layout is stored in slot 0.
(define-source-transform %instance-layout (x)
`(truly-the layout (%instance-ref ,x 0)))
(define-source-transform %set-instance-layout (x val)
`(%instance-set ,x 0 (the layout ,val)))
+(define-source-transform %funcallable-instance-layout (x)
+ `(truly-the layout (%funcallable-instance-info ,x 0)))
+(define-source-transform %set-funcallable-instance-layout (x val)
+ `(setf (%funcallable-instance-info ,x 0) (the layout ,val)))
\f
;;;; character support
;; the other transform will kick in, so that's OK
(give-up-ir1-transform)
`(etypecase string
- ((simple-array character (*)) (data-vector-ref string index))
+ ((simple-array character (*))
+ (data-vector-ref string index))
#!+sb-unicode
- ((simple-array base-char (*)) (data-vector-ref string index))
- ((simple-array nil (*)) (data-vector-ref string index))))))
+ ((simple-array base-char (*))
+ (data-vector-ref string index))
+ ((simple-array nil (*))
+ (data-vector-ref string index))))))
(deftransform hairy-data-vector-ref ((array index) (array t) *)
"avoid runtime dispatch on array element type"
;; WITH-ARRAY-DATA. Since WITH-ARRAY-DATA is implemented as a
;; macro, and macros aren't expanded in transform output, we have
;; to hand-expand it ourselves.)
- (let ((element-type-specifier (type-specifier element-ctype)))
+ (let* ((element-type-specifier (type-specifier element-ctype)))
`(multiple-value-bind (array index)
(%data-vector-and-index array index)
(declare (type (simple-array ,element-type-specifier 1) array))
`(the ,(type-specifier declared-element-ctype)
,bare-form)))))))
-(deftransform data-vector-ref ((array index)
- (simple-array t))
+;;; Transform multi-dimensional array to one dimensional data vector
+;;; access.
+(deftransform data-vector-ref ((array index) (simple-array t))
(let ((array-type (lvar-type array)))
(unless (array-type-p array-type)
(give-up-ir1-transform))
(%array-data-vector array))
index)))))
+;;; Transform data vector access to a form that opens up optimization
+;;; opportunities. On platforms that support DATA-VECTOR-REF-WITH-OFFSET
+;;; DATA-VECTOR-REF is not supported at all.
+#!+(or x86 x86-64)
+(define-source-transform data-vector-ref (array index)
+ `(data-vector-ref-with-offset ,array ,index 0))
+
+#!+(or x86 x86-64)
+(deftransform data-vector-ref-with-offset ((array index offset))
+ (let ((array-type (lvar-type array)))
+ (when (or (not (array-type-p array-type))
+ (eql (array-type-specialized-element-type array-type)
+ *wild-type*))
+ (give-up-ir1-transform))
+ ;; It shouldn't be possible to get here with anything but a non-complex
+ ;; vector.
+ (aver (not (array-type-complexp array-type)))
+ (let* ((element-type (type-specifier (array-type-specialized-element-type array-type)))
+ (saetp (find-saetp element-type)))
+ (when (< (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits)
+ (give-up-ir1-transform))
+ (fold-index-addressing 'data-vector-ref-with-offset
+ (sb!vm:saetp-n-bits saetp)
+ sb!vm:other-pointer-lowtag
+ sb!vm:vector-data-offset
+ index offset))))
+
(deftransform hairy-data-vector-set ((string index new-value)
(simple-string t t))
(let ((ctype (lvar-type string)))
(the ,(type-specifier declared-element-ctype)
new-value))))))))
+;;; Transform multi-dimensional array to one dimensional data vector
+;;; access.
(deftransform data-vector-set ((array index new-value)
(simple-array t t))
(let ((array-type (lvar-type array)))
index
new-value)))))
+;;; Transform data vector access to a form that opens up optimization
+;;; opportunities.
+#!+(or x86 x86-64)
+(define-source-transform data-vector-set (array index new-value)
+ `(data-vector-set-with-offset ,array ,index 0 ,new-value))
+
+#!+(or x86 x86-64)
+(deftransform data-vector-set-with-offset ((array index offset new-value))
+ (let ((array-type (lvar-type array)))
+ (when (or (not (array-type-p array-type))
+ (eql (array-type-specialized-element-type array-type)
+ *wild-type*))
+ ;; We don't yet know the exact element type, but will get that
+ ;; knowledge after some more type propagation.
+ (give-up-ir1-transform))
+ (aver (not (array-type-complexp array-type)))
+ (let* ((element-type (type-specifier (array-type-specialized-element-type array-type)))
+ (saetp (find-saetp element-type)))
+ (when (< (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits)
+ (give-up-ir1-transform))
+ (fold-index-addressing 'data-vector-set-with-offset
+ (sb!vm:saetp-n-bits saetp)
+ sb!vm:other-pointer-lowtag
+ sb!vm:vector-data-offset
+ index offset t))))
+
(defoptimizer (%data-vector-and-index derive-type) ((array index))
(let ((atype (lvar-type array)))
(when (array-type-p atype)
;; epilogue. - CSR, 2002-04-24
(truncate (truly-the index (1- length))
sb!vm:n-word-bits))))
- ((= index end-1)
+ ((>= index end-1)
(setf (%raw-bits result-bit-array index)
(,',wordfun (%raw-bits bit-array-1 index)
(%raw-bits bit-array-2 index)))
;; the epilogue. - CSR, 2002-04-24
(truncate (truly-the index (1- length))
sb!vm:n-word-bits))))
- ((= index end-1)
+ ((>= index end-1)
(setf (%raw-bits result-bit-array index)
(word-logical-not (%raw-bits bit-array index)))
result-bit-array)
(do* ((i sb!vm:vector-data-offset (+ i 1))
(end-1 (+ sb!vm:vector-data-offset
(floor (1- length) sb!vm:n-word-bits))))
- ((= i end-1)
+ ((>= i end-1)
(let* ((extra (1+ (mod (1- length) sb!vm:n-word-bits)))
(mask (ash #.(1- (ash 1 sb!vm:n-word-bits))
(- extra sb!vm:n-word-bits)))
(end-1 (+ sb!vm:vector-data-offset
(truncate (truly-the index (1- length))
sb!vm:n-word-bits))))
- ((= index end-1)
+ ((>= index end-1)
(let* ((extra (1+ (mod (1- length) sb!vm:n-word-bits)))
(mask (ash #.(1- (ash 1 sb!vm:n-word-bits))
(- extra sb!vm:n-word-bits)))
(%raw-bits sequence index))))
(declare (type (integer 1 #.sb!vm:n-word-bits) extra))
(declare (type sb!vm:word mask bits))
- ;; could consider LOGNOT for the zero case instead of
- ;; doing the subtraction...
- (incf count ,(if (constant-lvar-p item)
- (if (zerop (lvar-value item))
- '(- extra (logcount bits))
- '(logcount bits))
- '(if (zerop item)
- (- extra (logcount bits))
- (logcount bits))))))
+ (incf count (logcount bits))
+ ,(if (constant-lvar-p item)
+ (if (zerop (lvar-value item))
+ '(- length count)
+ 'count)
+ '(if (zerop item)
+ (- length count)
+ count))))
(declare (type index index count end-1)
(optimize (speed 3) (safety 0)))
- (incf count ,(if (constant-lvar-p item)
- (if (zerop (lvar-value item))
- '(- sb!vm:n-word-bits (logcount (%raw-bits sequence index)))
- '(logcount (%raw-bits sequence index)))
- '(if (zerop item)
- (- sb!vm:n-word-bits (logcount (%raw-bits sequence index)))
- (logcount (%raw-bits sequence index)))))))))
+ (incf count (logcount (%raw-bits sequence index)))))))
(deftransform fill ((sequence item) (simple-bit-vector bit) *
:policy (>= speed space))
;; in the epilogue. - CSR, 2002-04-24
(truncate (truly-the index (1- length))
sb!vm:n-word-bits))))
- ((= index end-1)
+ ((>= index end-1)
(setf (%raw-bits sequence index) value)
sequence)
(declare (optimize (speed 3) (safety 0))
(truncate length sb!vm:n-word-bytes)
(do ((index sb!vm:vector-data-offset (1+ index))
(end (+ times sb!vm:vector-data-offset)))
- ((= index end)
+ ((>= index end)
(let ((place (* times sb!vm:n-word-bytes)))
(declare (fixnum place))
(dotimes (j rem sequence)
result)
adds
shifts)))
+
+\f
+;;; Transform GET-LISP-OBJ-ADDRESS for constant immediates, since the normal
+;;; VOP can't handle them.
+
+(deftransform sb!vm::get-lisp-obj-address ((obj) ((constant-arg fixnum)))
+ (ash (lvar-value obj) sb!vm::n-fixnum-tag-bits))
+
+(deftransform sb!vm::get-lisp-obj-address ((obj) ((constant-arg character)))
+ (logior sb!vm::character-widetag
+ (ash (char-code (lvar-value obj)) sb!vm::n-widetag-bits)))
projects / sbcl.git / blobdiff