(define-source-transform identity (x) `(prog1 ,x))
(define-source-transform values (x) `(prog1 ,x))
-;;; Bind the values and make a closure that returns them.
+;;; Bind the value and make a closure that returns it.
(define-source-transform constantly (value)
- (let ((rest (gensym "CONSTANTLY-REST-")))
- `(lambda (&rest ,rest)
- (declare (ignore ,rest))
- ,value)))
+ (with-unique-names (rest n-value)
+ `(let ((,n-value ,value))
+ (lambda (&rest ,rest)
+ (declare (ignore ,rest))
+ ,n-value))))
;;; If the function has a known number of arguments, then return a
;;; lambda with the appropriate fixed number of args. If the
;;; are equal to an intermediate convention for which they are
;;; considered different which is more natural for some of the
;;; optimisers.
-#!-negative-zero-is-not-zero
(defun convert-numeric-type (type)
(declare (type numeric-type type))
;;; Only convert real float interval delimiters types.
;;; Convert back from the intermediate convention for which -0.0 and
;;; 0.0 are considered different to the standard type convention for
;;; which and equal.
-#!-negative-zero-is-not-zero
(defun convert-back-numeric-type (type)
(declare (type numeric-type type))
;;; Only convert real float interval delimiters types.
type))
;;; Convert back a possible list of numeric types.
-#!-negative-zero-is-not-zero
(defun convert-back-numeric-type-list (type-list)
(typecase type-list
(list
(push type misc-types)))
#!+long-float
(when (null (set-difference '(-0l0 0l0) members))
- #!-negative-zero-is-not-zero
(push (specifier-type '(long-float 0l0 0l0)) misc-types)
- #!+negative-zero-is-not-zero
- (push (specifier-type '(long-float -0l0 0l0)) misc-types)
(setf members (set-difference members '(-0l0 0l0))))
(when (null (set-difference '(-0d0 0d0) members))
- #!-negative-zero-is-not-zero
(push (specifier-type '(double-float 0d0 0d0)) misc-types)
- #!+negative-zero-is-not-zero
- (push (specifier-type '(double-float -0d0 0d0)) misc-types)
(setf members (set-difference members '(-0d0 0d0))))
(when (null (set-difference '(-0f0 0f0) members))
- #!-negative-zero-is-not-zero
(push (specifier-type '(single-float 0f0 0f0)) misc-types)
- #!+negative-zero-is-not-zero
- (push (specifier-type '(single-float -0f0 0f0)) misc-types)
(setf members (set-difference members '(-0f0 0f0))))
(if members
(apply #'type-union (make-member-type :members members) misc-types)
(defun one-arg-derive-type (arg derive-fcn member-fcn
&optional (convert-type t))
(declare (type function derive-fcn)
- (type (or null function) member-fcn)
- #!+negative-zero-is-not-zero (ignore convert-type))
+ (type (or null function) member-fcn))
(let ((arg-list (prepare-arg-for-derive-type (continuation-type arg))))
(when arg-list
(flet ((deriver (x)
;; Otherwise convert to a numeric type.
(let ((result-type-list
(funcall derive-fcn (convert-member-type x))))
- #!-negative-zero-is-not-zero
(if convert-type
(convert-back-numeric-type-list result-type-list)
- result-type-list)
- #!+negative-zero-is-not-zero
- result-type-list)))
+ result-type-list))))
(numeric-type
- #!-negative-zero-is-not-zero
(if convert-type
(convert-back-numeric-type-list
(funcall derive-fcn (convert-numeric-type x)))
- (funcall derive-fcn x))
- #!+negative-zero-is-not-zero
- (funcall derive-fcn x))
+ (funcall derive-fcn x)))
(t
*universal-type*))))
;; Run down the list of args and derive the type of each one,
(defun two-arg-derive-type (arg1 arg2 derive-fcn fcn
&optional (convert-type t))
(declare (type function derive-fcn fcn))
- #!+negative-zero-is-not-zero
- (declare (ignore convert-type))
- (flet (#!-negative-zero-is-not-zero
- (deriver (x y same-arg)
+ (flet ((deriver (x y same-arg)
(cond ((and (member-type-p x) (member-type-p y))
(let* ((x (first (member-type-members x)))
(y (first (member-type-members y)))
(convert-back-numeric-type-list result)
result)))
(t
- *universal-type*)))
- #!+negative-zero-is-not-zero
- (deriver (x y same-arg)
- (cond ((and (member-type-p x) (member-type-p y))
- (let* ((x (first (member-type-members x)))
- (y (first (member-type-members y)))
- (result (with-float-traps-masked
- (:underflow :overflow :divide-by-zero)
- (funcall fcn x y))))
- (if result
- (make-member-type :members (list result)))))
- ((and (member-type-p x) (numeric-type-p y))
- (let ((x (convert-member-type x)))
- (funcall derive-fcn x y same-arg)))
- ((and (numeric-type-p x) (member-type-p y))
- (let ((y (convert-member-type y)))
- (funcall derive-fcn x y same-arg)))
- ((and (numeric-type-p x) (numeric-type-p y))
- (funcall derive-fcn x y same-arg))
- (t
*universal-type*))))
(let ((same-arg (same-leaf-ref-p arg1 arg2))
(a1 (prepare-arg-for-derive-type (continuation-type arg1)))
) ; PROGN
-
-;;; KLUDGE: All this ASH optimization is suppressed under CMU CL
-;;; because as of version 2.4.6 for Debian, CMU CL blows up on (ASH
-;;; 1000000000 -100000000000) (i.e. ASH of two bignums yielding zero)
-;;; and it's hard to avoid that calculation in here.
-#-(and cmu sb-xc-host)
-(progn
-
(defun ash-derive-type-aux (n-type shift same-arg)
(declare (ignore same-arg))
+ ;; KLUDGE: All this ASH optimization is suppressed under CMU CL for
+ ;; some bignum cases because as of version 2.4.6 for Debian and 18d,
+ ;; CMU CL blows up on (ASH 1000000000 -100000000000) (i.e. ASH of
+ ;; two bignums yielding zero) and it's hard to avoid that
+ ;; calculation in here.
+ #+(and cmu sb-xc-host)
+ (when (and (or (typep (numeric-type-low n-type) 'bignum)
+ (typep (numeric-type-high n-type) 'bignum))
+ (or (typep (numeric-type-low shift) 'bignum)
+ (typep (numeric-type-high shift) 'bignum)))
+ (return-from ash-derive-type-aux *universal-type*))
(flet ((ash-outer (n s)
(when (and (fixnump s)
(<= s 64)
(defoptimizer (ash derive-type) ((n shift))
(two-arg-derive-type n shift #'ash-derive-type-aux #'ash))
-) ; PROGN
#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(macrolet ((frob (fun)
(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)) and then do FLOOR.
+;;; mask. If CEILING, add in (1- (ABS Y)), do FLOOR and correct a
+;;; remainder.
(flet ((frob (y ceil-p)
(unless (constant-continuation-p y)
(give-up-ir1-transform))
(unless (= y-abs (ash 1 len))
(give-up-ir1-transform))
(let ((shift (- len))
- (mask (1- y-abs)))
- `(let ,(when ceil-p `((x (+ x ,(1- y-abs)))))
+ (mask (1- y-abs))
+ (delta (if ceil-p (* (signum y) (1- y-abs)) 0)))
+ `(let ((x (+ x ,delta)))
,(if (minusp y)
`(values (ash (- x) ,shift)
- (- (logand (- x) ,mask)))
+ (- (- (logand (- x) ,mask)) ,delta))
`(values (ash x ,shift)
- (logand x ,mask))))))))
+ (- (logand x ,mask) ,delta))))))))
(deftransform floor ((x y) (integer integer) *)
"convert division by 2^k to shift"
(frob y nil))
nil)))
(defoptimizer (coerce derive-type) ((value type))
- (let ((value-type (continuation-type value))
- (type-type (continuation-type type)))
- (labels
- ((good-cons-type-p (cons-type)
- ;; Make sure the cons-type we're looking at is something
- ;; we're prepared to handle which is basically something
- ;; that array-element-type can return.
- (or (and (member-type-p cons-type)
- (null (rest (member-type-members cons-type)))
- (null (first (member-type-members cons-type))))
- (let ((car-type (cons-type-car-type cons-type)))
- (and (member-type-p car-type)
- (null (rest (member-type-members car-type)))
- (or (symbolp (first (member-type-members car-type)))
- (numberp (first (member-type-members car-type)))
- (and (listp (first (member-type-members car-type)))
- (numberp (first (first (member-type-members
- car-type))))))
- (good-cons-type-p (cons-type-cdr-type cons-type))))))
- (unconsify-type (good-cons-type)
- ;; Convert the "printed" respresentation of a cons
- ;; specifier into a type specifier. That is, the specifier
- ;; (cons (eql signed-byte) (cons (eql 16) null)) is
- ;; converted to (signed-byte 16).
- (cond ((or (null good-cons-type)
- (eq good-cons-type 'null))
- nil)
- ((and (eq (first good-cons-type) 'cons)
- (eq (first (second good-cons-type)) 'member))
- `(,(second (second good-cons-type))
- ,@(unconsify-type (caddr good-cons-type))))))
- (coerceable-p (c-type)
- ;; Can the value be coerced to the given type? Coerce is
- ;; complicated, so we don't handle every possible case
- ;; here---just the most common and easiest cases:
- ;;
- ;; o Any real can be coerced to a float type.
- ;; o Any number can be coerced to a complex single/double-float.
- ;; o An integer can be coerced to an integer.
- (let ((coerced-type c-type))
- (or (and (subtypep coerced-type 'float)
- (csubtypep value-type (specifier-type 'real)))
- (and (subtypep coerced-type
- '(or (complex single-float)
- (complex double-float)))
- (csubtypep value-type (specifier-type 'number)))
- (and (subtypep coerced-type 'integer)
- (csubtypep value-type (specifier-type 'integer))))))
- (process-types (type)
- ;; FIXME:
- ;; This needs some work because we should be able to derive
- ;; the resulting type better than just the type arg of
- ;; coerce. That is, if x is (integer 10 20), the (coerce x
- ;; 'double-float) should say (double-float 10d0 20d0)
- ;; instead of just double-float.
- (cond ((member-type-p type)
- (let ((members (member-type-members type)))
- (if (every #'coerceable-p members)
- (specifier-type `(or ,@members))
- *universal-type*)))
- ((and (cons-type-p type)
- (good-cons-type-p type))
- (let ((c-type (unconsify-type (type-specifier type))))
- (if (coerceable-p c-type)
- (specifier-type c-type)
- *universal-type*)))
- (t
- *universal-type*))))
- (cond ((union-type-p type-type)
- (apply #'type-union (mapcar #'process-types
- (union-type-types type-type))))
- ((or (member-type-p type-type)
- (cons-type-p type-type))
- (process-types type-type))
- (t
- *universal-type*)))))
+ (cond
+ ((constant-continuation-p type)
+ ;; This branch is essentially (RESULT-TYPE-SPECIFIER-NTH-ARG 2),
+ ;; but dealing with the niggle that complex canonicalization gets
+ ;; in the way: (COERCE 1 'COMPLEX) returns 1, which is not of
+ ;; type COMPLEX.
+ (let* ((specifier (continuation-value type))
+ (result-typeoid (careful-specifier-type specifier)))
+ (cond
+ ((null result-typeoid) nil)
+ ((csubtypep result-typeoid (specifier-type 'number))
+ ;; the difficult case: we have to cope with ANSI 12.1.5.3
+ ;; Rule of Canonical Representation for Complex Rationals,
+ ;; which is a truly nasty delivery to field.
+ (cond
+ ((csubtypep result-typeoid (specifier-type 'real))
+ ;; cleverness required here: it would be nice to deduce
+ ;; that something of type (INTEGER 2 3) coerced to type
+ ;; DOUBLE-FLOAT should return (DOUBLE-FLOAT 2.0d0 3.0d0).
+ ;; FLOAT gets its own clause because it's implemented as
+ ;; a UNION-TYPE, so we don't catch it in the NUMERIC-TYPE
+ ;; logic below.
+ result-typeoid)
+ ((and (numeric-type-p result-typeoid)
+ (eq (numeric-type-complexp result-typeoid) :real))
+ ;; FIXME: is this clause (a) necessary or (b) useful?
+ result-typeoid)
+ ((or (csubtypep result-typeoid
+ (specifier-type '(complex single-float)))
+ (csubtypep result-typeoid
+ (specifier-type '(complex double-float)))
+ #!+long-float
+ (csubtypep result-typeoid
+ (specifier-type '(complex long-float))))
+ ;; float complex types are never canonicalized.
+ result-typeoid)
+ (t
+ ;; if it's not a REAL, or a COMPLEX FLOAToid, it's
+ ;; probably just a COMPLEX or equivalent. So, in that
+ ;; case, we will return a complex or an object of the
+ ;; provided type if it's rational:
+ (type-union result-typeoid
+ (type-intersection (continuation-type value)
+ (specifier-type 'rational))))))
+ (t result-typeoid))))
+ (t
+ ;; OK, the result-type argument isn't constant. However, there
+ ;; are common uses where we can still do better than just
+ ;; *UNIVERSAL-TYPE*: e.g. (COERCE X (ARRAY-ELEMENT-TYPE Y)),
+ ;; where Y is of a known type. See messages on cmucl-imp
+ ;; 2001-02-14 and sbcl-devel 2002-12-12. We only worry here
+ ;; about types that can be returned by (ARRAY-ELEMENT-TYPE Y), on
+ ;; the basis that it's unlikely that other uses are both
+ ;; time-critical and get to this branch of the COND (non-constant
+ ;; second argument to COERCE). -- CSR, 2002-12-16
+ (let ((value-type (continuation-type value))
+ (type-type (continuation-type type)))
+ (labels
+ ((good-cons-type-p (cons-type)
+ ;; Make sure the cons-type we're looking at is something
+ ;; we're prepared to handle which is basically something
+ ;; that array-element-type can return.
+ (or (and (member-type-p cons-type)
+ (null (rest (member-type-members cons-type)))
+ (null (first (member-type-members cons-type))))
+ (let ((car-type (cons-type-car-type cons-type)))
+ (and (member-type-p car-type)
+ (null (rest (member-type-members car-type)))
+ (or (symbolp (first (member-type-members car-type)))
+ (numberp (first (member-type-members car-type)))
+ (and (listp (first (member-type-members
+ car-type)))
+ (numberp (first (first (member-type-members
+ car-type))))))
+ (good-cons-type-p (cons-type-cdr-type cons-type))))))
+ (unconsify-type (good-cons-type)
+ ;; Convert the "printed" respresentation of a cons
+ ;; specifier into a type specifier. That is, the
+ ;; specifier (CONS (EQL SIGNED-BYTE) (CONS (EQL 16)
+ ;; NULL)) is converted to (SIGNED-BYTE 16).
+ (cond ((or (null good-cons-type)
+ (eq good-cons-type 'null))
+ nil)
+ ((and (eq (first good-cons-type) 'cons)
+ (eq (first (second good-cons-type)) 'member))
+ `(,(second (second good-cons-type))
+ ,@(unconsify-type (caddr good-cons-type))))))
+ (coerceable-p (c-type)
+ ;; Can the value be coerced to the given type? Coerce is
+ ;; complicated, so we don't handle every possible case
+ ;; here---just the most common and easiest cases:
+ ;;
+ ;; * Any REAL can be coerced to a FLOAT type.
+ ;; * Any NUMBER can be coerced to a (COMPLEX
+ ;; SINGLE/DOUBLE-FLOAT).
+ ;;
+ ;; FIXME I: we should also be able to deal with characters
+ ;; here.
+ ;;
+ ;; FIXME II: I'm not sure that anything is necessary
+ ;; here, at least while COMPLEX is not a specialized
+ ;; array element type in the system. Reasoning: if
+ ;; something cannot be coerced to the requested type, an
+ ;; error will be raised (and so any downstream compiled
+ ;; code on the assumption of the returned type is
+ ;; unreachable). If something can, then it will be of
+ ;; the requested type, because (by assumption) COMPLEX
+ ;; (and other difficult types like (COMPLEX INTEGER)
+ ;; aren't specialized types.
+ (let ((coerced-type c-type))
+ (or (and (subtypep coerced-type 'float)
+ (csubtypep value-type (specifier-type 'real)))
+ (and (subtypep coerced-type
+ '(or (complex single-float)
+ (complex double-float)))
+ (csubtypep value-type (specifier-type 'number))))))
+ (process-types (type)
+ ;; FIXME: This needs some work because we should be able
+ ;; to derive the resulting type better than just the
+ ;; type arg of coerce. That is, if X is (INTEGER 10
+ ;; 20), then (COERCE X 'DOUBLE-FLOAT) should say
+ ;; (DOUBLE-FLOAT 10d0 20d0) instead of just
+ ;; double-float.
+ (cond ((member-type-p type)
+ (let ((members (member-type-members type)))
+ (if (every #'coerceable-p members)
+ (specifier-type `(or ,@members))
+ *universal-type*)))
+ ((and (cons-type-p type)
+ (good-cons-type-p type))
+ (let ((c-type (unconsify-type (type-specifier type))))
+ (if (coerceable-p c-type)
+ (specifier-type c-type)
+ *universal-type*)))
+ (t
+ *universal-type*))))
+ (cond ((union-type-p type-type)
+ (apply #'type-union (mapcar #'process-types
+ (union-type-types type-type))))
+ ((or (member-type-p type-type)
+ (cons-type-p type-type))
+ (process-types type-type))
+ (t
+ *universal-type*)))))))
+
+(defoptimizer (compile derive-type) ((nameoid function))
+ (when (csubtypep (continuation-type nameoid)
+ (specifier-type 'null))
+ (values-specifier-type '(values function boolean boolean))))
+;;; FIXME: Maybe also STREAM-ELEMENT-TYPE should be given some loving
+;;; treatment along these lines? (See discussion in COERCE DERIVE-TYPE
+;;; optimizer, above).
(defoptimizer (array-element-type derive-type) ((array))
(let ((array-type (continuation-type array)))
(labels ((consify (list)
projects / sbcl.git / blobdiff