X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=f6caaaed4f3eae393faae6f01d8eb86947318e1e;hb=49c69bcd41790587cbcb0411c5c3497ee84f4343;hp=adb1dc2b9476fe17fde69a05fac62588bc037588;hpb=3a38ef48c9ae55b932b5639ac9ac3ccd56c7dd9f;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index adb1dc2..f6caaae 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -179,8 +179,14 @@ (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)) @@ -992,10 +998,13 @@ (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. @@ -2128,27 +2137,19 @@ ;; They must both be positive. (cond ((or (null x-len) (null y-len)) (specifier-type 'unsigned-byte)) - ((or (zerop x-len) (zerop y-len)) - (specifier-type '(integer 0 0))) (t - (specifier-type `(unsigned-byte ,(min x-len y-len))))) + (specifier-type `(unsigned-byte* ,(min x-len y-len))))) ;; X is positive, but Y might be negative. (cond ((null x-len) (specifier-type 'unsigned-byte)) - ((zerop x-len) - (specifier-type '(integer 0 0))) (t - (specifier-type `(unsigned-byte ,x-len))))) + (specifier-type `(unsigned-byte* ,x-len))))) ;; X might be negative. (if (not y-neg) ;; Y must be positive. (cond ((null y-len) (specifier-type 'unsigned-byte)) - ((zerop y-len) - (specifier-type '(integer 0 0))) - (t - (specifier-type - `(unsigned-byte ,y-len)))) + (t (specifier-type `(unsigned-byte* ,y-len)))) ;; Either might be negative. (if (and x-len y-len) ;; The result is bounded. @@ -2163,11 +2164,9 @@ (cond ((and (not x-neg) (not y-neg)) ;; Both are positive. - (if (and x-len y-len (zerop x-len) (zerop y-len)) - (specifier-type '(integer 0 0)) - (specifier-type `(unsigned-byte ,(if (and x-len y-len) - (max x-len y-len) - '*))))) + (specifier-type `(unsigned-byte* ,(if (and x-len y-len) + (max x-len y-len) + '*)))) ((not x-pos) ;; X must be negative. (if (not y-pos) @@ -2206,11 +2205,9 @@ (and (not x-pos) (not y-pos))) ;; Either both are negative or both are positive. The result ;; will be positive, and as long as the longer. - (if (and x-len y-len (zerop x-len) (zerop y-len)) - (specifier-type '(integer 0 0)) - (specifier-type `(unsigned-byte ,(if (and x-len y-len) - (max x-len y-len) - '*))))) + (specifier-type `(unsigned-byte* ,(if (and x-len y-len) + (max x-len y-len) + '*)))) ((or (and (not x-pos) (not y-neg)) (and (not y-neg) (not y-pos))) ;; Either X is negative and Y is positive of vice-versa. The @@ -2318,7 +2315,7 @@ (csubtypep size (specifier-type 'integer))) (let ((size-high (numeric-type-high size))) (if (and size-high (<= size-high sb!vm:n-word-bits)) - (specifier-type `(unsigned-byte ,size-high)) + (specifier-type `(unsigned-byte* ,size-high)) (specifier-type 'unsigned-byte))) *universal-type*))) @@ -2333,57 +2330,46 @@ (posn-high (numeric-type-high posn))) (if (and size-high posn-high (<= (+ size-high posn-high) sb!vm:n-word-bits)) - (specifier-type `(unsigned-byte ,(+ size-high posn-high))) + (specifier-type `(unsigned-byte* ,(+ size-high posn-high))) (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 + ;; KLUDGE: we need this cutoff here, otherwise we + ;; will merrily derive the type of %DPB as + ;; (UNSIGNED-BYTE 1073741822), and then attempt to + ;; canonicalize this type to (INTEGER 0 (1- (ASH 1 + ;; 1073741822))), with hilarious consequences. We + ;; cutoff at 4*SB!VM:N-WORD-BITS to allow inference + ;; over a reasonable amount of shifting, even on + ;; the alpha/32 port, where N-WORD-BITS is 32 but + ;; machine integers are 64-bits. -- CSR, + ;; 2003-09-12 + (<= (+ size-high posn-high) (* 4 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)