'(if (< x 0) (- x) x))
;;; We don't want to clutter the bignum code.
-#!+x86
+#!+(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
`(sb!bignum:%bignum-ref-with-offset ,bignum
(truly-the bignum-index ,index) 0))
-#!+x86
+#!+(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)
(,fun-name thing index (,func off2 off1) ,@(when setter-p
'(value))))))))
-#!+x86
+#!+(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: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)))
index)))))
;;; Transform data vector access to a form that opens up optimization
-;;; opportunities.
-#!+x86
-(deftransform data-vector-ref ((array index) ((or simple-unboxed-array
- simple-vector)
- t))
+;;; 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)))
- (unless (array-type-p array-type)
+ (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 element-type
- sb!vm:*specialized-array-element-type-properties*
- :key #'sb!vm:saetp-specifier :test #'equal)))
- (unless (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits)
+ (saetp (find-saetp element-type)))
+ (when (< (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits)
(give-up-ir1-transform))
- `(data-vector-ref-with-offset array index 0))))
-
-#!+x86
-(deftransform data-vector-ref-with-offset ((array index offset)
- ((or simple-unboxed-array
- simple-vector)
- t t))
- (let ((array-type (lvar-type array)))
- (unless (array-type-p array-type)
- (give-up-ir1-transform))
- (let* ((element-type (type-specifier (array-type-specialized-element-type array-type)))
- (saetp (find element-type
- sb!vm:*specialized-array-element-type-properties*
- :key #'sb!vm:saetp-specifier :test #'equal)))
- (aver (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits))
(fold-index-addressing 'data-vector-ref-with-offset
(sb!vm:saetp-n-bits saetp)
sb!vm:other-pointer-lowtag
;;; Transform data vector access to a form that opens up optimization
;;; opportunities.
-#!+x86
-(deftransform data-vector-set ((array index new-value)
- ((or simple-unboxed-array simple-vector)
- t t))
- (let ((array-type (lvar-type array)))
- (unless (array-type-p array-type)
- (give-up-ir1-transform))
- (let* ((element-type (type-specifier (array-type-specialized-element-type array-type)))
- (saetp (find element-type
- sb!vm:*specialized-array-element-type-properties*
- :key #'sb!vm:saetp-specifier :test #'equal)))
- (unless (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits)
- (give-up-ir1-transform))
- `(data-vector-set-with-offset array index 0 new-value))))
+#!+(or x86 x86-64)
+(define-source-transform data-vector-set (array index new-value)
+ `(data-vector-set-with-offset ,array ,index 0 ,new-value))
-#!+x86
-(deftransform data-vector-set-with-offset ((array index offset new-value)
- ((or simple-unboxed-array
- simple-vector)
- t t t))
+#!+(or x86 x86-64)
+(deftransform data-vector-set-with-offset ((array index offset new-value))
(let ((array-type (lvar-type array)))
- (unless (array-type-p array-type)
+ (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 element-type
- sb!vm:*specialized-array-element-type-properties*
- :key #'sb!vm:saetp-specifier :test #'equal)))
- (aver (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits))
+ (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
;; declare it in the DEFKNOWN too.)
((simple-unboxed-array (*)) (vector-sap thing)))))
(declare (inline sapify))
- (without-gcing
+ (with-pinned-objects (dst src)
(memmove (sap+ (sapify dst) dst-start)
(sap+ (sapify src) src-start)
(- dst-end dst-start)))
\f
;;;; modular functions
-(define-good-modular-fun logand :unsigned)
-(define-good-modular-fun logior :unsigned)
-;;; FIXME: XOR? ANDC1, ANDC2? -- CSR, 2003-09-16
+;;;
+;;; FIXME: I think that the :GOODness of a modular function boils down
+;;; to whether the normal definition can be used in the middle of a
+;;; modular arrangement. LOGAND and LOGIOR can be for all unsigned
+;;; modular implementations, I believe, because for all unsigned
+;;; arguments of a given size the result of the ordinary definition is
+;;; the right one. This should follow through to other logical
+;;; functions, such as LOGXOR, should it not? -- CSR, 2007-12-29,
+;;; trying to understand a comment he wrote over four years
+;;; previously: "FIXME: XOR? ANDC1, ANDC2? -- CSR, 2003-09-16"
+(define-good-modular-fun logand :untagged nil)
+(define-good-modular-fun logior :untagged nil)
+(define-good-modular-fun logxor :untagged nil)
+(macrolet ((define-good-signed-modular-funs (&rest funs)
+ (let (result)
+ `(progn
+ ,@(dolist (fun funs (nreverse result))
+ (push `(define-good-modular-fun ,fun :untagged t) result)
+ (push `(define-good-modular-fun ,fun :tagged t) result))))))
+ (define-good-signed-modular-funs
+ logand logandc1 logandc2 logeqv logior lognand lognor lognot
+ logorc1 logorc2 logxor))
(macrolet
- ((def (name class width)
- (let ((type (ecase class
- (:unsigned 'unsigned-byte)
- (:signed 'signed-byte))))
+ ((def (name kind width signedp)
+ (let ((type (ecase signedp
+ ((nil) 'unsigned-byte)
+ ((t) 'signed-byte))))
`(progn
(defknown ,name (integer (integer 0)) (,type ,width)
(foldable flushable movable))
- (define-modular-fun-optimizer ash ((integer count) ,class :width width)
+ (define-modular-fun-optimizer ash ((integer count) ,kind ,signedp :width width)
(when (and (<= width ,width)
(or (and (constant-lvar-p count)
(plusp (lvar-value count)))
(csubtypep (lvar-type count)
(specifier-type '(and unsigned-byte fixnum)))))
- (cut-to-width integer ,class width)
+ (cut-to-width integer ,kind width ,signedp)
',name))
- (setf (gethash ',name (modular-class-versions (find-modular-class ',class)))
+ (setf (gethash ',name (modular-class-versions (find-modular-class ',kind ',signedp)))
`(ash ,',width))))))
;; 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 :signed 30)
- (def sb!vm::ash-left-mod32 :unsigned 32))
+ #!+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 :signed 61)
- (def sb!vm::ash-left-mod64 :unsigned 64)))
-
+ #!+x86-64 (def sb!vm::ash-left-smod61 :tagged 61 t)
+ (def sb!vm::ash-left-mod64 :untagged 64 nil)))
\f
;;;; word-wise logical operations
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