(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.
;;;
;;; Given the continuation ARG, derive the resulting type using the
-;;; DERIVE-FCN. DERIVE-FCN takes exactly one argument which is some
+;;; DERIVE-FUN. DERIVE-FUN takes exactly one argument which is some
;;; "atomic" continuation type like numeric-type or member-type
;;; (containing just one element). It should return the resulting
;;; type, which can be a list of types.
;;;
-;;; For the case of member types, if a member-fcn is given it is
+;;; For the case of member types, if a MEMBER-FUN is given it is
;;; called to compute the result otherwise the member type is first
-;;; converted to a numeric type and the derive-fcn is call.
-(defun one-arg-derive-type (arg derive-fcn member-fcn
+;;; converted to a numeric type and the DERIVE-FUN is called.
+(defun one-arg-derive-type (arg derive-fun member-fun
&optional (convert-type t))
- (declare (type function derive-fcn)
- (type (or null function) member-fcn))
+ (declare (type function derive-fun)
+ (type (or null function) member-fun))
(let ((arg-list (prepare-arg-for-derive-type (continuation-type arg))))
(when arg-list
(flet ((deriver (x)
(typecase x
(member-type
- (if member-fcn
+ (if member-fun
(with-float-traps-masked
(:underflow :overflow :divide-by-zero)
(make-member-type
:members (list
- (funcall member-fcn
+ (funcall member-fun
(first (member-type-members x))))))
;; Otherwise convert to a numeric type.
(let ((result-type-list
- (funcall derive-fcn (convert-member-type x))))
+ (funcall derive-fun (convert-member-type x))))
(if convert-type
(convert-back-numeric-type-list result-type-list)
result-type-list))))
(numeric-type
(if convert-type
(convert-back-numeric-type-list
- (funcall derive-fcn (convert-numeric-type x)))
- (funcall derive-fcn x)))
+ (funcall derive-fun (convert-numeric-type x)))
+ (funcall derive-fun x)))
(t
*universal-type*))))
;; Run down the list of args and derive the type of each one,
(first results)))))))
;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes
-;;; two arguments. DERIVE-FCN takes 3 args in this case: the two
+;;; two arguments. DERIVE-FUN takes 3 args in this case: the two
;;; original args and a third which is T to indicate if the two args
;;; really represent the same continuation. This is useful for
;;; deriving the type of things like (* x x), which should always be
;;; positive. If we didn't do this, we wouldn't be able to tell.
-(defun two-arg-derive-type (arg1 arg2 derive-fcn fcn
+(defun two-arg-derive-type (arg1 arg2 derive-fun fun
&optional (convert-type t))
- (declare (type function derive-fcn fcn))
+ (declare (type function derive-fun fun))
(flet ((deriver (x y same-arg)
(cond ((and (member-type-p x) (member-type-p y))
(let* ((x (first (member-type-members x)))
(result (with-float-traps-masked
(:underflow :overflow :divide-by-zero
:invalid)
- (funcall fcn x y))))
+ (funcall fun x y))))
(cond ((null result))
((and (floatp result) (float-nan-p result))
(make-numeric-type :class 'float
((and (member-type-p x) (numeric-type-p y))
(let* ((x (convert-member-type x))
(y (if convert-type (convert-numeric-type y) y))
- (result (funcall derive-fcn x y same-arg)))
+ (result (funcall derive-fun x y same-arg)))
(if convert-type
(convert-back-numeric-type-list result)
result)))
((and (numeric-type-p x) (member-type-p y))
(let* ((x (if convert-type (convert-numeric-type x) x))
(y (convert-member-type y))
- (result (funcall derive-fcn x y same-arg)))
+ (result (funcall derive-fun x y same-arg)))
(if convert-type
(convert-back-numeric-type-list result)
result)))
((and (numeric-type-p x) (numeric-type-p y))
(let* ((x (if convert-type (convert-numeric-type x) x))
(y (if convert-type (convert-numeric-type y) y))
- (result (funcall derive-fcn x y same-arg)))
+ (result (funcall derive-fun x y same-arg)))
(if convert-type
(convert-back-numeric-type-list result)
result)))
(t
(specifier-type 'integer))))))
-(macrolet ((deffrob (logfcn)
- (let ((fcn-aux (symbolicate logfcn "-DERIVE-TYPE-AUX")))
- `(defoptimizer (,logfcn derive-type) ((x y))
- (two-arg-derive-type x y #',fcn-aux #',logfcn)))))
+(macrolet ((deffrob (logfun)
+ (let ((fun-aux (symbolicate logfun "-DERIVE-TYPE-AUX")))
+ `(defoptimizer (,logfun derive-type) ((x y))
+ (two-arg-derive-type x y #',fun-aux #',logfun)))))
(deffrob logand)
(deffrob logior)
(deffrob logxor))
(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))
"Too many arguments (~D) to ~S ~S: uses at most ~D."
nargs fun string max)))))))
-(deftransform format ((dest control &rest args) (t simple-string &rest t) *
- :node node)
+(defoptimizer (format optimizer) ((dest control &rest args))
+ (when (constant-continuation-p control)
+ (let ((x (continuation-value control)))
+ (when (stringp x)
+ (check-format-args x args 'format)))))
- (cond
- ((policy node (> speed space))
- (unless (constant-continuation-p control)
- (give-up-ir1-transform "The control string is not a constant."))
- (check-format-args (continuation-value control) args 'format)
- (let ((arg-names (make-gensym-list (length args))))
- `(lambda (dest control ,@arg-names)
- (declare (ignore control))
- (format dest (formatter ,(continuation-value control)) ,@arg-names))))
- (t (when (constant-continuation-p control)
- (check-format-args (continuation-value control) args 'format))
- (give-up-ir1-transform))))
+(deftransform format ((dest control &rest args) (t simple-string &rest t) *
+ :policy (> speed space))
+ (unless (constant-continuation-p control)
+ (give-up-ir1-transform "The control string is not a constant."))
+ (let ((arg-names (make-gensym-list (length args))))
+ `(lambda (dest control ,@arg-names)
+ (declare (ignore control))
+ (format dest (formatter ,(continuation-value control)) ,@arg-names))))
(deftransform format ((stream control &rest args) (stream function &rest t) *
:policy (> speed space))
(macrolet
((def (name)
- `(deftransform ,name
- ((control &rest args) (simple-string &rest t) *)
+ `(defoptimizer (,name optimizer) ((control &rest args))
(when (constant-continuation-p control)
- (check-format-args (continuation-value control) args ',name))
- (give-up-ir1-transform))))
+ (let ((x (continuation-value control)))
+ (when (stringp x)
+ (check-format-args x args ',name)))))))
(def error)
(def warn)
#+sb-xc-host ; Only we should be using these
(def maybe-compiler-notify)
(def bug)))
-(deftransform cerror ((report control &rest args)
- (simple-string simple-string &rest t) *)
- (unless (and (constant-continuation-p control)
- (constant-continuation-p report))
- (give-up-ir1-transform))
- (multiple-value-bind (min1 max1)
- (handler-case (sb!format:%compiler-walk-format-string
- (continuation-value control) args)
- (sb!format:format-error (c)
- (compiler-warn "~A" c)))
- (when min1
- (multiple-value-bind (min2 max2)
- (handler-case (sb!format:%compiler-walk-format-string
- (continuation-value report) args)
- (sb!format:format-error (c)
- (compiler-warn "~A" c)))
- (when min2
- (let ((nargs (length args)))
- (cond
- ((< nargs (min min1 min2))
- (compiler-warn "Too few arguments (~D) to ~S ~S ~S: ~
- requires at least ~D."
- nargs 'cerror report control (min min1 min2)))
- ((> nargs (max max1 max2))
- (;; to get warned about probably bogus code at
- ;; cross-compile time.
- #+sb-xc-host compiler-warn
- ;; ANSI saith that too many arguments doesn't cause a
- ;; run-time error.
- #-sb-xc-host compiler-style-warn
- "Too many arguments (~D) to ~S ~S ~S: uses at most ~D."
- nargs 'cerror report control (max max1 max2)))))))))
- (give-up-ir1-transform))
+(defoptimizer (cerror optimizer) ((report control &rest args))
+ (when (and (constant-continuation-p control)
+ (constant-continuation-p report))
+ (let ((x (continuation-value control))
+ (y (continuation-value report)))
+ (when (and (stringp x) (stringp y))
+ (multiple-value-bind (min1 max1)
+ (handler-case
+ (sb!format:%compiler-walk-format-string x args)
+ (sb!format:format-error (c)
+ (compiler-warn "~A" c)))
+ (when min1
+ (multiple-value-bind (min2 max2)
+ (handler-case
+ (sb!format:%compiler-walk-format-string y args)
+ (sb!format:format-error (c)
+ (compiler-warn "~A" c)))
+ (when min2
+ (let ((nargs (length args)))
+ (cond
+ ((< nargs (min min1 min2))
+ (compiler-warn "Too few arguments (~D) to ~S ~S ~S: ~
+ requires at least ~D."
+ nargs 'cerror y x (min min1 min2)))
+ ((> nargs (max max1 max2))
+ (;; to get warned about probably bogus code at
+ ;; cross-compile time.
+ #+sb-xc-host compiler-warn
+ ;; ANSI saith that too many arguments doesn't cause a
+ ;; run-time error.
+ #-sb-xc-host compiler-style-warn
+ "Too many arguments (~D) to ~S ~S ~S: uses at most ~D."
+ nargs 'cerror y x (max max1 max2)))))))))))))
(defoptimizer (coerce derive-type) ((value type))
(cond
(format t "/(CONTINUATION-VALUE X)=~S~%" (continuation-value x)))
(format t "/MESSAGE=~S~%" (continuation-value message))
(give-up-ir1-transform "not a real transform"))
- (defun /report-continuation (&rest rest)
- (declare (ignore rest))))
+ (defun /report-continuation (x message)
+ (declare (ignore x message))))
projects / sbcl.git / blobdiff