(define-source-transform logorc1 (x y) `(logior (lognot ,x) ,y))
(define-source-transform logorc2 (x y) `(logior ,x (lognot ,y)))
(define-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
-(define-source-transform logbitp (index integer)
- `(not (zerop (logand (ash 1 ,index) ,integer))))
+
+(deftransform logbitp
+ ((index integer) (unsigned-byte (or (signed-byte #.sb!vm:n-word-bits)
+ (unsigned-byte #.sb!vm:n-word-bits))))
+ `(if (>= index #.sb!vm:n-word-bits)
+ (minusp integer)
+ (not (zerop (logand integer (ash 1 index))))))
+
(define-source-transform byte (size position)
`(cons ,size ,position))
(define-source-transform byte-size (spec) `(car ,spec))
(member (first members))
(member-type (type-of member)))
(aver (not (rest members)))
- (specifier-type `(,(if (subtypep member-type 'integer)
- 'integer
- member-type)
- ,member ,member))))
+ (specifier-type (cond ((typep member 'integer)
+ `(integer ,member ,member))
+ ((memq member-type '(short-float single-float
+ double-float long-float))
+ `(,member-type ,member ,member))
+ (t
+ member-type)))))
;;; This is used in defoptimizers for computing the resulting type of
;;; a function.
(specifier-type 'unsigned-byte)))
*universal-type*)))
-(defoptimizer (%dpb derive-type) ((newbyte size posn int))
+(defun %deposit-field-derive-type-aux (size posn int)
(let ((size (continuation-type size))
(posn (continuation-type posn))
(int (continuation-type int)))
- (if (and (numeric-type-p size)
- (csubtypep size (specifier-type 'integer))
- (numeric-type-p posn)
- (csubtypep posn (specifier-type 'integer))
- (numeric-type-p int)
- (csubtypep int (specifier-type 'integer)))
- (let ((size-high (numeric-type-high size))
- (posn-high (numeric-type-high posn))
- (high (numeric-type-high int))
- (low (numeric-type-low int)))
- (if (and size-high posn-high high low
- (<= (+ size-high posn-high) sb!vm:n-word-bits))
- (specifier-type
- (list (if (minusp low) 'signed-byte 'unsigned-byte)
- (max (integer-length high)
- (integer-length low)
- (+ size-high posn-high))))
- *universal-type*))
- *universal-type*)))
+ (when (and (numeric-type-p size)
+ (numeric-type-p posn)
+ (numeric-type-p int))
+ (let ((size-high (numeric-type-high size))
+ (posn-high (numeric-type-high posn))
+ (high (numeric-type-high int))
+ (low (numeric-type-low int)))
+ (when (and size-high posn-high high low
+ (<= (+ size-high posn-high) sb!vm:n-word-bits))
+ (let ((raw-bit-count (max (integer-length high)
+ (integer-length low)
+ (+ size-high posn-high))))
+ (specifier-type
+ (if (minusp low)
+ `(signed-byte ,(1+ raw-bit-count))
+ `(unsigned-byte ,raw-bit-count)))))))))
+
+(defoptimizer (%dpb derive-type) ((newbyte size posn int))
+ (%deposit-field-derive-type-aux size posn int))
(defoptimizer (%deposit-field derive-type) ((newbyte size posn int))
- (let ((size (continuation-type size))
- (posn (continuation-type posn))
- (int (continuation-type int)))
- (if (and (numeric-type-p size)
- (csubtypep size (specifier-type 'integer))
- (numeric-type-p posn)
- (csubtypep posn (specifier-type 'integer))
- (numeric-type-p int)
- (csubtypep int (specifier-type 'integer)))
- (let ((size-high (numeric-type-high size))
- (posn-high (numeric-type-high posn))
- (high (numeric-type-high int))
- (low (numeric-type-low int)))
- (if (and size-high posn-high high low
- (<= (+ size-high posn-high) sb!vm:n-word-bits))
- (specifier-type
- (list (if (minusp low) 'signed-byte 'unsigned-byte)
- (max (integer-length high)
- (integer-length low)
- (+ size-high posn-high))))
- *universal-type*))
- *universal-type*)))
+ (%deposit-field-derive-type-aux size posn int))
(deftransform %ldb ((size posn int)
(fixnum fixnum integer)
`(- (ash x ,len))
`(ash x ,len))))
-;;; If both arguments and the result are (UNSIGNED-BYTE 32), try to
-;;; come up with a ``better'' multiplication using multiplier
-;;; recoding. There are two different ways the multiplier can be
-;;; recoded. The more obvious is to shift X by the correct amount for
-;;; each bit set in Y and to sum the results. But if there is a string
-;;; of bits that are all set, you can add X shifted by one more then
-;;; the bit position of the first set bit and subtract X shifted by
-;;; the bit position of the last set bit. We can't use this second
-;;; method when the high order bit is bit 31 because shifting by 32
-;;; doesn't work too well.
-(deftransform * ((x y)
- ((unsigned-byte 32) (unsigned-byte 32))
- (unsigned-byte 32))
- "recode as shift and add"
- (unless (constant-continuation-p y)
- (give-up-ir1-transform))
- (let ((y (continuation-value y))
- (result nil)
- (first-one nil))
- (labels ((tub32 (x) `(truly-the (unsigned-byte 32) ,x))
- (add (next-factor)
- (setf result
- (tub32
- (if result
- `(+ ,result ,(tub32 next-factor))
- next-factor)))))
- (declare (inline add))
- (dotimes (bitpos 32)
- (if first-one
- (when (not (logbitp bitpos y))
- (add (if (= (1+ first-one) bitpos)
- ;; There is only a single bit in the string.
- `(ash x ,first-one)
- ;; There are at least two.
- `(- ,(tub32 `(ash x ,bitpos))
- ,(tub32 `(ash x ,first-one)))))
- (setf first-one nil))
- (when (logbitp bitpos y)
- (setf first-one bitpos))))
- (when first-one
- (cond ((= first-one 31))
- ((= first-one 30)
- (add '(ash x 30)))
- (t
- (add `(- ,(tub32 '(ash x 31)) ,(tub32 `(ash x ,first-one))))))
- (add '(ash x 31))))
- (or result 0)))
-
;;; If arg is a constant power of two, turn FLOOR into a shift and
;;; mask. If CEILING, add in (1- (ABS Y)), do FLOOR and correct a
;;; remainder.
;; multiplication and division for small integral powers.
(unless (not-more-contagious y x)
(give-up-ir1-transform))
- (cond ((zerop val) '(float 1 x))
+ (cond ((zerop val)
+ (let ((x-type (continuation-type x)))
+ (cond ((csubtypep x-type (specifier-type '(or rational
+ (complex rational))))
+ '1)
+ ((csubtypep x-type (specifier-type 'real))
+ `(if (rationalp x)
+ 1
+ (float 1 x)))
+ ((csubtypep x-type (specifier-type 'complex))
+ ;; both parts are float
+ `(1+ (* x ,val)))
+ (t (give-up-ir1-transform)))))
((= val 2) '(* x x))
((= val -2) '(/ (* x x)))
((= val 3) '(* x x x))
projects / sbcl.git / blobdiff