(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
#'%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)
(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
(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))
(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