(t
;; (float x (+0.0)) => (or (member -0.0) (float x (0.0)))
;; (float x -0.0) => (or (member -0.0) (float x (0.0)))
- (list (make-member-type :members (list (float -0.0 hi-val)))
+ (list (make-member-type :members (list (float (load-time-value (make-unportable-float :single-float-negative-zero)) hi-val)))
(make-numeric-type :class (numeric-type-class type)
:format (numeric-type-format type)
:complexp :real
(t
type-list)))
-;;; FIXME: MAKE-CANONICAL-UNION-TYPE and CONVERT-MEMBER-TYPE probably
-;;; belong in the kernel's type logic, invoked always, instead of in
-;;; the compiler, invoked only during some type optimizations. (In
-;;; fact, as of 0.pre8.100 or so they probably are, under
-;;; MAKE-MEMBER-TYPE, so probably this code can be deleted)
-
;;; Take a list of types and return a canonical type specifier,
;;; combining any MEMBER types together. If both positive and negative
;;; MEMBER types are present they are converted to a float type.
;;; XXX This would be far simpler if the type-union methods could handle
;;; member/number unions.
-(defun make-canonical-union-type (type-list)
+;;;
+;;; If we're about to generate an overly complex union of numeric types, start
+;;; collapse the ranges together.
+;;;
+;;; FIXME: The MEMBER canonicalization parts of MAKE-DERIVED-UNION-TYPE and
+;;; entire CONVERT-MEMBER-TYPE probably belong in the kernel's type logic,
+;;; invoked always, instead of in the compiler, invoked only during some type
+;;; optimizations.
+(defvar *derived-numeric-union-complexity-limit* 6)
+
+(defun make-derived-union-type (type-list)
(let ((xset (alloc-xset))
(fp-zeroes '())
- (misc-types '()))
+ (misc-types '())
+ (numeric-type *empty-type*))
(dolist (type type-list)
(cond ((member-type-p type)
(mapc-member-type-members
(pushnew member fp-zeroes))
(add-to-xset member xset)))
type))
+ ((numeric-type-p type)
+ (let ((*approximate-numeric-unions*
+ (when (and (union-type-p numeric-type)
+ (nthcdr *derived-numeric-union-complexity-limit*
+ (union-type-types numeric-type)))
+ t)))
+ (setf numeric-type (type-union type numeric-type))))
(t
(push type misc-types))))
(if (and (xset-empty-p xset) (not fp-zeroes))
- (apply #'type-union misc-types)
- (apply #'type-union (make-member-type :xset xset :fp-zeroes fp-zeroes) misc-types))))
+ (apply #'type-union numeric-type misc-types)
+ (apply #'type-union (make-member-type :xset xset :fp-zeroes fp-zeroes)
+ numeric-type misc-types))))
;;; Convert a member type with a single member to a numeric type.
(defun convert-member-type (arg)
(setf results (append results result))
(push result results))))
(if (rest results)
- (make-canonical-union-type results)
+ (make-derived-union-type results)
(first results)))))))
;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes
(setf results (append results result))
(push result results))))))
(if (rest results)
- (make-canonical-union-type results)
+ (make-derived-union-type results)
(first results)))))))
\f
#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
#'%unary-truncate-derive-type-aux
#'%unary-truncate))
+(defoptimizer (%unary-truncate/single-float derive-type) ((number))
+ (one-arg-derive-type number
+ #'%unary-truncate-derive-type-aux
+ #'%unary-truncate))
+
+(defoptimizer (%unary-truncate/double-float derive-type) ((number))
+ (one-arg-derive-type number
+ #'%unary-truncate-derive-type-aux
+ #'%unary-truncate))
+
(defoptimizer (%unary-ftruncate derive-type) ((number))
(let ((divisor (specifier-type '(integer 1 1))))
(one-arg-derive-type number
(ftruncate-derive-type-quot-aux n divisor nil))
#'%unary-ftruncate)))
+(defoptimizer (%unary-round derive-type) ((number))
+ (one-arg-derive-type number
+ (lambda (n)
+ (block nil
+ (unless (numeric-type-real-p n)
+ (return *empty-type*))
+ (let* ((interval (numeric-type->interval n))
+ (low (interval-low interval))
+ (high (interval-high interval)))
+ (when (consp low)
+ (setf low (car low)))
+ (when (consp high)
+ (setf high (car high)))
+ (specifier-type
+ `(integer ,(if low
+ (round low)
+ '*)
+ ,(if high
+ (round high)
+ '*))))))
+ #'%unary-round))
+
;;; Define optimizers for FLOOR and CEILING.
(macrolet
((def (name q-name r-name)
(hi-res (if hi (isqrt hi) '*)))
(specifier-type `(integer ,lo-res ,hi-res))))))
+(defoptimizer (char-code derive-type) ((char))
+ (let ((type (type-intersection (lvar-type char) (specifier-type 'character))))
+ (cond ((member-type-p type)
+ (specifier-type
+ `(member
+ ,@(loop for member in (member-type-members type)
+ when (characterp member)
+ collect (char-code member)))))
+ ((sb!kernel::character-set-type-p type)
+ (specifier-type
+ `(or
+ ,@(loop for (low . high)
+ in (character-set-type-pairs type)
+ collect `(integer ,low ,high)))))
+ ((csubtypep type (specifier-type 'base-char))
+ (specifier-type
+ `(mod ,base-char-code-limit)))
+ (t
+ (specifier-type
+ `(mod ,char-code-limit))))))
+
(defoptimizer (code-char derive-type) ((code))
(let ((type (lvar-type code)))
;; FIXME: unions of integral ranges? It ought to be easier to do
(values (type= (numeric-contagion x y)
(numeric-contagion y y)))))))
+(def!type exact-number ()
+ '(or rational (complex rational)))
+
;;; Fold (+ x 0).
;;;
-;;; If y is not constant, not zerop, or is contagious, or a positive
-;;; float +0.0 then give up.
-(deftransform + ((x y) (t (constant-arg t)) *)
+;;; Only safely applicable for exact numbers. For floating-point
+;;; x, one would have to first show that neither x or y are signed
+;;; 0s, and that x isn't an SNaN.
+(deftransform + ((x y) (exact-number (constant-arg (eql 0))) *)
"fold zero arg"
- (let ((val (lvar-value y)))
- (unless (and (zerop val)
- (not (and (floatp val) (plusp (float-sign val))))
- (not-more-contagious y x))
- (give-up-ir1-transform)))
'x)
;;; Fold (- x 0).
-;;;
-;;; If y is not constant, not zerop, or is contagious, or a negative
-;;; float -0.0 then give up.
-(deftransform - ((x y) (t (constant-arg t)) *)
+(deftransform - ((x y) (exact-number (constant-arg (eql 0))) *)
"fold zero arg"
- (let ((val (lvar-value y)))
- (unless (and (zerop val)
- (not (and (floatp val) (minusp (float-sign val))))
- (not-more-contagious y x))
- (give-up-ir1-transform)))
'x)
;;; Fold (OP x +/-1)
-(macrolet ((def (name result minus-result)
- `(deftransform ,name ((x y) (t (constant-arg real)) *)
- "fold identity operations"
- (let ((val (lvar-value y)))
- (unless (and (= (abs val) 1)
- (not-more-contagious y x))
- (give-up-ir1-transform))
- (if (minusp val) ',minus-result ',result)))))
+;;;
+;;; %NEGATE might not always signal correctly.
+(macrolet
+ ((def (name result minus-result)
+ `(deftransform ,name ((x y)
+ (exact-number (constant-arg (member 1 -1))))
+ "fold identity operations"
+ (if (minusp (lvar-value y)) ',minus-result ',result))))
(def * x (%negate x))
(def / x (%negate x))
(def expt x (/ 1 x)))
((= val -1/2) '(/ (sqrt x)))
(t (give-up-ir1-transform)))))
+(deftransform expt ((x y) ((constant-arg (member -1 -1.0 -1.0d0)) integer) *)
+ "recode as an ODDP check"
+ (let ((val (lvar-value x)))
+ (if (eql -1 val)
+ '(- 1 (* 2 (logand 1 y)))
+ `(if (oddp y)
+ ,val
+ ,(abs val)))))
+
;;; KLUDGE: Shouldn't (/ 0.0 0.0), etc. cause exceptions in these
;;; transformations?
;;; Perhaps we should have to prove that the denominator is nonzero before
(def eq)
(def char=))
-;;; True if EQL comparisons involving type can be simplified to EQ.
-(defun eq-comparable-type-p (type)
- (csubtypep type (specifier-type '(or fixnum (not number)))))
-
;;; This is similar to SIMPLE-EQUALITY-TRANSFORM, except that we also
;;; try to convert to a type-specific predicate or EQ:
;;; -- If both args are characters, convert to CHAR=. This is better than
(cond ((or (and (csubtypep x-type (specifier-type 'float))
(csubtypep y-type (specifier-type 'float)))
(and (csubtypep x-type (specifier-type '(complex float)))
- (csubtypep y-type (specifier-type '(complex float)))))
+ (csubtypep y-type (specifier-type '(complex float))))
+ #!+complex-float-vops
+ (and (csubtypep x-type (specifier-type '(or single-float (complex single-float))))
+ (csubtypep y-type (specifier-type '(or single-float (complex single-float)))))
+ #!+complex-float-vops
+ (and (csubtypep x-type (specifier-type '(or double-float (complex double-float))))
+ (csubtypep y-type (specifier-type '(or double-float (complex double-float))))))
;; They are both floats. Leave as = so that -0.0 is
;; handled correctly.
(give-up-ir1-transform))
;;; error messages, and those don't need to be particularly fast.
#+sb-xc
(deftransform format ((dest control &rest args) (t simple-string &rest t) *
- :policy (> speed space))
+ :policy (>= speed space))
(unless (constant-lvar-p control)
(give-up-ir1-transform "The control string is not a constant."))
(let ((arg-names (make-gensym-list (length args))))
(declare (ignore control))
(format dest (formatter ,(lvar-value control)) ,@arg-names))))
-(deftransform format ((stream control &rest args) (stream function &rest t) *
- :policy (> speed space))
+(deftransform format ((stream control &rest args) (stream function &rest t))
(let ((arg-names (make-gensym-list (length args))))
`(lambda (stream control ,@arg-names)
(funcall control stream ,@arg-names)
nil)))
-(deftransform format ((tee control &rest args) ((member t) function &rest t) *
- :policy (> speed space))
+(deftransform format ((tee control &rest args) ((member t) function &rest t))
(let ((arg-names (make-gensym-list (length args))))
`(lambda (tee control ,@arg-names)
(declare (ignore tee))
:format-arguments
(list nargs 'cerror y x (max max1 max2))))))))))))))
-(defoptimizer (coerce derive-type) ((value type))
+(defoptimizer (coerce derive-type) ((value type) node)
(cond
((constant-lvar-p type)
;; This branch is essentially (RESULT-TYPE-SPECIFIER-NTH-ARG 2),
(type-union result-typeoid
(type-intersection (lvar-type value)
(specifier-type 'rational))))))
- (t result-typeoid))))
+ ((and (policy node (zerop safety))
+ (csubtypep result-typeoid (specifier-type '(array * (*)))))
+ ;; At zero safety the deftransform for COERCE can elide dimension
+ ;; checks for the things like (COERCE X '(SIMPLE-VECTOR 5)) -- so we
+ ;; need to simplify the type to drop the dimension information.
+ (let ((vtype (simplify-vector-type result-typeoid)))
+ (if vtype
+ (specifier-type vtype)
+ result-typeoid)))
+ (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
(eq (first (second good-cons-type)) 'member))
`(,(second (second good-cons-type))
,@(unconsify-type (caddr good-cons-type))))))
- (coerceable-p (c-type)
+ (coerceable-p (part)
;; 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:
;; 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))))))
+ (let ((coerced-type (careful-specifier-type part)))
+ (when coerced-type
+ (or (and (csubtypep coerced-type (specifier-type 'float))
+ (csubtypep value-type (specifier-type 'real)))
+ (and (csubtypep coerced-type
+ (specifier-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
(specifier-type (consify element-type)))
(t
(error "can't understand type ~S~%" element-type))))))
- (cond ((array-type-p array-type)
- (get-element-type array-type))
- ((union-type-p array-type)
- (apply #'type-union
- (mapcar #'get-element-type (union-type-types array-type))))
- (t
- *universal-type*)))))
+ (labels ((recurse (type)
+ (cond ((array-type-p type)
+ (get-element-type type))
+ ((union-type-p type)
+ (apply #'type-union
+ (mapcar #'recurse (union-type-types type))))
+ (t
+ *universal-type*))))
+ (recurse array-type)))))
-;;; Like CMU CL, we use HEAPSORT. However, other than that, this code
-;;; isn't really related to the CMU CL code, since instead of trying
-;;; to generalize the CMU CL code to allow START and END values, this
-;;; code has been written from scratch following Chapter 7 of
-;;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir.
(define-source-transform sb!impl::sort-vector (vector start end predicate key)
;; Like CMU CL, we use HEAPSORT. However, other than that, this code
;; isn't really related to the CMU CL code, since instead of trying
(start-1 (1- ,',start))
(current-heap-size (- ,',end ,',start))
(keyfun ,keyfun))
- (declare (type (integer -1 #.(1- most-positive-fixnum))
+ (declare (type (integer -1 #.(1- sb!xc:most-positive-fixnum))
start-1))
(declare (type index current-heap-size))
(declare (type function keyfun))
projects / sbcl.git / blobdiff