diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp index b68444ba62607aec65ff64c0f24894e07a76ee07..ad6cecfc9f6946d551e7b0efffe962dd305deb1a 100644 --- a/compiler/float-tran.lisp +++ b/compiler/float-tran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.47 1997/12/12 15:19:03 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.48 1997/12/14 14:10:27 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -249,40 +249,40 @@ #+propagate-float-type (progn -(macrolet - ((frob (name) - `(defoptimizer (,name derive-type) ((f ex)) - (flet ((scale-bound (x n) - ;; We need to be a bit careful here and catch any - ;; overflows that might occur. We can ignore - ;; underflows which become zeros. - (set-bound - (handler-case - (scale-float (bound-value x) n) - (floating-point-overflow () - nil)) - (consp x)))) - (let ((f-type (continuation-type f)) - (ex-type (continuation-type ex))) - (when (and (numeric-type-p f-type) - (numeric-type-p ex-type)) - (let ((f-lo (numeric-type-low f-type)) - (f-hi (numeric-type-high f-type)) - (ex-lo (numeric-type-low ex-type)) - (ex-hi (numeric-type-high ex-type)) - (new-lo nil) - (new-hi nil)) - (when (and f-hi ex-hi) - (setf new-hi (scale-bound f-hi ex-hi))) - (when (and f-lo ex-lo) - (setf new-lo (scale-bound f-lo ex-lo))) - (make-numeric-type :class (numeric-type-class f-type) - :format (numeric-type-format f-type) - :complexp :real - :low new-lo - :high new-hi)))))))) - (frob scale-single-float) - (frob scale-double-float)) + +(defun scale-float-derive-type-aux (f ex same-arg) + (declare (ignore same-arg)) + (flet ((scale-bound (x n) + ;; We need to be a bit careful here and catch any overflows + ;; that might occur. We can ignore underflows which become + ;; zeros. + (set-bound + (handler-case + (scale-float (bound-value x) n) + (floating-point-overflow () + nil)) + (consp x)))) + (when (and (numeric-type-p f) (numeric-type-p ex)) + (let ((f-lo (numeric-type-low f)) + (f-hi (numeric-type-high f)) + (ex-lo (numeric-type-low ex)) + (ex-hi (numeric-type-high ex)) + (new-lo nil) + (new-hi nil)) + (when (and f-hi ex-hi) + (setf new-hi (scale-bound f-hi ex-hi))) + (when (and f-lo ex-lo) + (setf new-lo (scale-bound f-lo ex-lo))) + (make-numeric-type :class (numeric-type-class f) + :format (numeric-type-format f) + :complexp :real + :low new-lo + :high new-hi))))) +;;; +(defoptimizer (scale-single-float derive-type) ((f ex)) + (two-arg-derive-type f ex #'scale-float-derive-type-aux)) +(defoptimizer (scale-double-float derive-type) ((f ex)) + (two-arg-derive-type f ex #'scale-float-derive-type-aux)) ;;; toy@rtp.ericsson.se: ;;; @@ -291,24 +291,25 @@ ;;; defined range. Quite useful if we want to convert some type of ;;; bounded integer into a float. -(macrolet ((frob (fun type) - `(defoptimizer (,fun derive-type) ((num)) - (let ((num-type (continuation-type num))) - (if (or (numeric-type-p num-type) - (union-type-p num-type)) - (elfun-derive-type-union - num-type - (constantly t) - #'(lambda (lo hi) - ;; When converting a number to a float, the - ;; limits on the resulting float are obviously - ;; the same as the original number. - (values lo hi ',type)) - (specifier-type ',type)) - *universal-type*))))) +(macrolet + ((frob (fun type) + (let ((aux-name (concatenate 'string (string fun) "-DERIVE-TYPE-AUX"))) + `(progn + (defun ,(intern aux-name) (num) + ;; When converting a number to a float, the limits are + ;; the same. + (let* ((lo (bound-func #'(lambda (x) + (coerce x ',type)) + (numeric-type-low num))) + (hi (bound-func #'(lambda (x) + (coerce x ',type)) + (numeric-type-high num)))) + (specifier-type `(,',type ,(or lo '*) ,(or hi '*))))) + + (defoptimizer (,fun derive-type) ((num)) + (one-arg-derive-type num #',(intern aux-name))))))) (frob %single-float single-float) (frob %double-float double-float)) - ) ; end progn @@ -582,64 +583,6 @@ ,(or hi '*)) (complex ,f-type))))) -(defun elfun-derive-type-1 (num cond limit-fun default-type) - (declare (type numeric-type num)) - (cond ((eq (numeric-type-complexp num) :complex) - ;; If the argument is complex, we return a complex, without - ;; bounds. - (make-numeric-type :class (numeric-type-class num) - :format (numeric-type-format num) - :complexp :complex)) - ((and (numeric-type-real-p num) - (funcall cond (numeric-type-low num) (numeric-type-high num))) - (with-float-traps-masked (:underflow :overflow) - ;; The call to the limit-fun has (most) traps disabled. It - ;; can naively compute the result and return infinity for - ;; the value. We convert the infinity to nil as needed. - (multiple-value-bind (lo-lim hi-lim float-type) - (funcall limit-fun - (numeric-type-low num) - (numeric-type-high num)) - (make-numeric-type :class 'float - :format (or float-type - (elfun-float-format - (numeric-type-format num))) - :complexp :real - :low (if (and (floatp lo-lim) - (float-infinity-p lo-lim)) - nil - lo-lim) - :high (if (and (floatp hi-lim) - (float-infinity-p hi-lim)) - nil - hi-lim))))) - (default-type - default-type) - (t - (float-or-complex-type num)))) - -;;; Same as ELFUN-DERIVE-TYPE-1 except we can handle simple -;;; NUMERIC-TYPEs and UNION-TYPEs. -(defun elfun-derive-type-union - (type cond limit-fun - &optional default-type) - (cond ((union-type-p type) - ;; For a UNION-TYPE, run down the list of unions and derive - ;; the resulting type of each union and make a UNION-TYPE of - ;; the results. - (let ((result '())) - (dolist (interval (union-type-types type)) - (let ((derived-type (elfun-derive-type-1 interval cond limit-fun default-type))) - (if (union-type-p derived-type) - ;; Insert union types in to the result - (dolist (item (union-type-types derived-type)) - (push item result)) - (push derived-type result)))) - (make-union-type (derive-merged-union-types result)))) - ((numeric-type-p type) - (elfun-derive-type-1 type cond limit-fun default-type)) - (t - (specifier-type 'number)))) ) ; end progn #+propagate-fun-type @@ -652,22 +595,40 @@ ;;; Handle these monotonic increasing functions whose domain is ;;; possibly part of the real line -(macrolet ((frob (name cond def-lo-bnd def-hi-bnd) - (let ((num (gensym)) - (lo-bnd (gensym)) - (hi-bnd (gensym))) - `(defoptimizer (,name derive-type) ((,num)) - (elfun-derive-type-union - (continuation-type ,num) - ,cond - #'(lambda (,lo-bnd ,hi-bnd) - ;; Since the function is monotonic increasing, the - ;; lower bound and the upper bound are the values - ;; of the function at the bounds of the input - ;; range. - (values (or (bound-func #',name ,lo-bnd) ,def-lo-bnd) - (or (bound-func #',name ,hi-bnd) ,def-hi-bnd)))))))) +(defun elfun-derive-type-simple (arg fcn cond default-lo default-hi) + (etypecase arg + (numeric-type + (cond ((eq (numeric-type-complexp arg) :complex) + (make-numeric-type :class (numeric-type-class arg) + :format (numeric-type-format arg) + :complexp :complex + :low nil + :high nil)) + ((numeric-type-real-p arg) + (let ((lo (numeric-type-low arg)) + (hi (numeric-type-high arg))) + (if (funcall cond lo hi) + (make-numeric-type + :class 'float + :format (or (numeric-type-format arg) 'single-float) + :low (or (bound-func fcn lo) default-lo) + :high (or (bound-func fcn hi) default-hi)) + (float-or-complex-type arg)))) + (t + (float-or-complex-type arg default-lo default-hi)))))) + +(macrolet + ((frob (name cond def-lo-bnd def-hi-bnd) + (let ((num (gensym))) + `(progn + (defoptimizer (,name derive-type) ((,num)) + (one-arg-derive-type + ,num + #'(lambda (arg) + (elfun-derive-type-simple arg #',name + ,cond + ,def-lo-bnd ,def-hi-bnd)))))))) ;; These functions are easy because they are defined for the whole ;; real line. (frob exp (constantly t) @@ -684,8 +645,7 @@ ;; return value of (OR FLOAT (COMPLEX FLOAT)) is ok as the default. (frob sqrt #'(lambda (lo hi) (declare (ignore hi)) - (and lo - (>= (bound-value lo) 0))) + (and lo (> (bound-value lo) 0))) 0 nil) (frob asin #'(lambda (lo hi) (and lo hi @@ -702,25 +662,44 @@ (<= (bound-value hi) 1))) -1 1)) - -;;; acos is monotonic decreasing, so we need to swap the function +;;; Acos is monotonic decreasing, so we need to swap the function ;;; values at the lower and upper bounds of the input domain. +;;; +(defun acos-derive-type-aux (arg) + (etypecase arg + (numeric-type + (cond ((eq (numeric-type-complexp arg) :complex) + (make-numeric-type :class (numeric-type-class arg) + :format (numeric-type-format arg) + :complexp :complex + :low nil + :high nil)) + ((numeric-type-real-p arg) + (let ((float-type (or (numeric-type-format arg) 'float)) + (lo (numeric-type-low arg)) + (hi (numeric-type-high arg))) + (cond + ((and lo hi + (>= (bound-value lo) -1) + (<= (bound-value hi) 1)) + (setf lo (or (bound-func #'acos (numeric-type-high arg)) 0)) + (setf hi (or (bound-func #'acos (numeric-type-low arg)) pi)) + (specifier-type `(,float-type + ,(and lo (coerce lo float-type)) + ,(and hi (coerce hi float-type))))) + (t + (float-or-complex-type arg 0 pi))))) + (t + (float-or-complex-type arg 0 pi)))))) +;;; (defoptimizer (acos derive-type) ((num)) - (elfun-derive-type-union - (continuation-type num) - #'(lambda (lo hi) - (and lo hi - (>= (bound-value lo) -1) - (<= (bound-value hi) 1))) - #'(lambda (lo hi) - (values (bound-func #'acos hi) - (bound-func #'acos lo))))) + (one-arg-derive-type num #'acos-derive-type-aux)) ;;; Compute bounds for (expt x y). This should be easy since (expt x ;;; y) = (exp (* y (log x))). However, computations done this way ;;; have too much roundoff. Thus we have to do it the hard way. - +;;; (defun safe-expt (x y) (handler-case (expt x y) @@ -806,10 +785,10 @@ ;; X <= 1 (interval-expt-< x y)) (t - (destructuring-bind (left right) + (destructuring-bind (left right) (interval-split 1 x t t) - (list (interval-expt left y) - (interval-expt right y)))))) + (list (interval-expt left y) + (interval-expt right y)))))) (defun fixup-interval-expt (bnd x-int y-int x-type y-type) (declare (ignore x-int)) @@ -859,37 +838,36 @@ (t (flatten-helper (car x) (flatten-helper (cdr x) r))))) (flatten (x) (flatten-helper x nil))) - (let* ((x-int (numeric-type->interval x-type)) - (y-int (numeric-type->interval y-type)) - (bnd (interval-expt x-int y-int)) - (union '())) - (dolist (type (flatten bnd)) - (push (fixup-interval-expt type x-int y-int x-type y-type) - union)) - (let ((merged (derive-merged-union-types union))) - (assert (null (rest merged))) ; There should be only one thing left! - (first merged))))) + (let* ((x-int (numeric-type->interval x-type)) + (y-int (numeric-type->interval y-type)) + (bnd (interval-expt x-int y-int)) + (union '())) + (dolist (type (flatten bnd)) + (push (fixup-interval-expt type x-int y-int x-type y-type) union)) + (let ((merged (derive-merged-union-types union))) + (assert (null (rest merged))) ; There should be only one thing left! + (first merged))))) ;; Derive the type of (expt x-type y-type) (defun expt-derive-type-aux-numeric (x-type y-type) - (if (or (eq (numeric-type-complexp x-type) :complex) - (eq (numeric-type-complexp y-type) :complex)) - (numeric-contagion x-type y-type) - (if (eq (numeric-type-class y-type) 'integer) - ;; A real raised to an integer power is well-defined - (merged-interval-expt x-type y-type) - ;; A real raised to a non-integral power can be a float or - ;; a complex number. - (cond ((and (bound-value (numeric-type-low x-type)) - (>= (bound-value (numeric-type-low x-type)) 0)) - ;; A non-negative real to some power is fairly easy - ;; to handle. - (merged-interval-expt x-type y-type)) - (t - ;; A number to some power. We punt here. - (format t "x-type, y-type = ~a ~a~%" x-type y-type) - (error "Can't happen!") - (specifier-type '(or float (complex float)))))))) + (if (or (eq (numeric-type-complexp x-type) :complex) + (eq (numeric-type-complexp y-type) :complex)) + (numeric-contagion x-type y-type) + (if (eq (numeric-type-class y-type) 'integer) + ;; A real raised to an integer power is well-defined + (merged-interval-expt x-type y-type) + ;; A real raised to a non-integral power can be a float or + ;; a complex number. + (cond ((and (bound-value (numeric-type-low x-type)) + (>= (bound-value (numeric-type-low x-type)) 0)) + ;; A non-negative real to some power is fairly easy + ;; to handle. + (merged-interval-expt x-type y-type)) + (t + ;; A number to some power. We punt here. + (format t "x-type, y-type = ~a ~a~%" x-type y-type) + (error "Can't happen!") + (specifier-type '(or float (complex float)))))))) (defun expt-derive-type-aux (x-type y-type) (let ((result (expt-derive-type-aux-numeric x-type y-type))) @@ -899,124 +877,73 @@ (numeric-type-format result)))) -(defoptimizer (expt derive-type) ((x y)) - (let ((x-type (continuation-type x)) - (y-type (continuation-type y))) - (if (or (eq (numeric-type-complexp x-type) :complex) - (eq (numeric-type-complexp y-type) :complex)) - (numeric-contagion x-type y-type) - (if (eq (numeric-type-class y-type) 'integer) - ;; A real raised to an integer power is well-defined - (merged-interval-expt x-type y-type) - ;; A real raised to a non-integral power can be a float or - ;; a complex number. - (cond ((and (bound-value (numeric-type-low x-type)) - (>= (bound-value (numeric-type-low x-type)) 0)) - ;; A non-negative real to some power is fairly easy - ;; to handle. - (derive-real-numeric-or-union-type - x-type y-type #'expt-derive-type-aux)) - - (t - ;; A number to some power. We punt here. - (float-or-complex-type - (numeric-contagion x-type y-type)))))))) - +;;; Note must assume that a type including 0.0 may also include -0.0 +;;; and thus the result may be -infinity + i*pi. +;;; +(defun log-derive-type-aux-1 (arg) + (elfun-derive-type-simple + arg #'log #'(lambda (lo hi) + (declare (ignore hi)) + (and lo (> (bound-value lo) 0))) + nil nil)) + +(defun log-derive-type-aux (x y same-arg) + (let ((log-x (log-derive-type-aux-1 x)) + (log-y (log-derive-type-aux-1 y)) + (result '())) + ;; log-x or log-y might be union types. We need to run through + ;; the union types ourselves because /-derive-type-aux doesn't. + (dolist (x-type (prepare-arg-for-derive-type log-x)) + (dolist (y-type (prepare-arg-for-derive-type log-y)) + (push (/-derive-type-aux x-type y-type same-arg) result))) + (setf result (flatten-list result)) + (if (rest result) + (make-union-type result) + (first result)))) (defoptimizer (log derive-type) ((x &optional y)) - (flet ((derive-type (arg) - (elfun-derive-type-union - (continuation-type arg) - #'(lambda (lo hi) - (declare (ignore hi)) - (and lo - (>= (bound-value lo) 0))) - #'(lambda (lo hi) - (values - (if (zerop (bound-value lo)) - nil - (set-bound (log (bound-value lo)) (consp lo))) - (if hi - (set-bound (log (bound-value hi)) (consp hi)) - nil)))))) - (cond ((null y) - ;; The easy one arg case - (derive-type x)) - (t - ;; The hard case with a base given. Use the definition of - ;; (log x y) = (/ (log x) (log y)) to figure out what the - ;; answer should be. - (let ((log-x (derive-type x)) - (log-y (derive-type y))) - (cond ((and (numeric-type-real-p log-x) - (numeric-type-real-p log-y)) - ;; This stolen from the optimizer for /. - (derive-real-numeric-or-union-type - log-x log-y - #'(lambda (x y) - (declare (type numeric-type x y)) - (let ((result - (interval-div (numeric-type->interval x) - (numeric-type->interval y))) - (result-type (numeric-contagion x y))) - ;; If the result type is a float, we need - ;; to be sure to coerce the bounds into the - ;; correct type. - (when (eq (numeric-type-class result-type) 'float) - (setf result (interval-func - #'(lambda (x) - (coerce x (or (numeric-type-format result-type) - 'float))) - result))) - (values (interval-low result) - (interval-high result) - (numeric-type-class result-type) - (numeric-type-format result-type)))))) - (t - ;; The result can be a float or a complex. Get - ;; the right type of float, if possible. - (float-or-complex-type - (numeric-contagion - (continuation-type x) - (continuation-type y)))))))))) + (if y + (two-arg-derive-type x y #'log-derive-type-aux) + (one-arg-derive-type x #'log-derive-type-aux-1))) + + +(defun atan-derive-type-aux-1 (y) + (elfun-derive-type-simple + y #'atan (constantly t) #.(- (/ pi 2)) #.(/ pi 2))) + +(defun atan-derive-type-aux-2 (y x same-arg) + (declare (ignore same-arg)) + ;; The hard case with two args. We just return the max bounds. + (cond ((and (numeric-type-real-p x) + (numeric-type-real-p y)) + (make-numeric-type + :class 'float + :format (float-format-max + (numeric-type-format y) + (numeric-type-format x)) + :complexp :real + :low #.(- pi) + :high #.pi)) + (t + ;; The result is a float or a complex number + (float-or-complex-type (numeric-contagion x y))))) (defoptimizer (atan derive-type) ((y &optional x)) (cond ((null x) - ;; Let's handle the easy one arg case - (elfun-derive-type-union - (continuation-type y) - #'(lambda (lo hi) - (declare (ignore lo hi)) - t) - #'(lambda (lo hi) - (values (or (bound-func #'atan lo) #.(- (/ pi 2))) - (or (bound-func #'atan hi) #.(/ pi 2)))))) + (one-arg-derive-type y #'atan-derive-type-aux-1)) (t - ;; Here is the hard case with two args. However, we punt on - ;; it, and just return the max bounds. - (when (numeric-type-real-p (continuation-type x)) - (make-numeric-type - :class 'float - :format (float-format-max - (numeric-type-format (continuation-type y)) - (numeric-type-format (continuation-type x))) - :complexp :real - :low #.(- pi) - :high #.pi))))) - + (two-arg-derive-type y x #'atan-derive-type-aux-2)))) + + +(defun cosh-derive-type-aux (x) + (elfun-derive-type-simple + (if (numeric-type-real-p x) + (abs-derive-type-aux x) + x) + #'cosh (constantly t) 0 nil)) (defoptimizer (cosh derive-type) ((num)) - (elfun-derive-type-union - (continuation-type num) - #'(lambda (lo hi) - (declare (ignore lo hi)) - t) - #'(lambda (lo hi) - ;; Note that cosh(x) = cosh(|x|), and that cosh is monotonic - ;; increasing for the positive line. - (let ((x (interval-abs (make-interval :low lo :high hi)))) - (values (bound-func #'cosh (interval-low x)) - (bound-func #'cosh (interval-high x))))))) + (one-arg-derive-type num #'cosh-derive-type-aux)) (defun phase-derive-type-aux (type) @@ -1067,42 +994,7 @@ :high pi)))) (defoptimizer (phase derive-type) ((num)) - (let ((type (continuation-type num))) - (cond ((numeric-type-real-p type) - (let ((res (phase-derive-type-aux type))) - (if (listp res) - (make-union-type res) - res))) - ((union-type-p type) - ;; Run down the list and process each type - (let ((result '())) - (dolist (interval (union-type-types type)) - (let ((res-1 (phase-derive-type-aux interval))) - (cond ((listp res-1) - (push (first res-1) result) - (push (second res-1) result)) - (t - (push res-1 result))))) - (make-union-type (derive-merged-union-types result))))))) - - -;;; Conjugate always returns the same type as the input type. -;;; -(defoptimizer (conjugate derive-type) ((num)) - (continuation-type num)) - -(defoptimizer (cis derive-type) ((num)) - (let ((num-type (continuation-type num))) - (flet ((cis-type (x) - ;; Cis of a double-float is (complex double-float). - ;; Otherwise it's (complex single-float). - (if (eq (numeric-type-format x) 'double-float) - (c::specifier-type '(complex double-float)) - (c::specifier-type '(complex single-float))))) - (if (union-type-p num-type) - (make-union-type (mapcar #'cis-type - (union-type-types num-type))) - (cis-type num-type))))) + (one-arg-derive-type num #'phase-derive-type-aux)) ) ;end progn for propagate-fun-type @@ -1117,133 +1009,120 @@ ;;; Make REALPART and IMAGPART return the appropriate types. This ;;; should help a lot in optimized code. -(defoptimizer (realpart derive-type) ((num)) - (flet ((realpart-derive (type) + +(defun realpart-derive-type-aux (type) (cond ((numeric-type-real-p type) - ;; The realpart of a real has the same type and - ;; range as the input. + ;; The realpart of a real has the same type and range as + ;; the input. (make-numeric-type :class (numeric-type-class type) :format (numeric-type-format type) :complexp :real :low (numeric-type-low type) :high (numeric-type-high type))) - (t - ;; We have a complex number. The result has the - ;; same type as the real part, except that it's - ;; real, not complex, obviously. - (make-numeric-type :class (numeric-type-class type) - :format (numeric-type-format type) - :complexp :real - :low (numeric-type-low type) - :high (numeric-type-high type)))))) - (let ((type (continuation-type num))) - (cond ((union-type-p type) - (let ((result '())) - (dolist (x (union-type-types type)) - (push (realpart-derive x) result)) - (make-union-type result))) - (t - (realpart-derive type)))))) - -(defoptimizer (imagpart derive-type) ((num)) - (flet ((imagpart-derive (type) - (cond ((numeric-type-real-p type) - ;; The imagpart of a real has the same type as the input, - ;; except that it's zero - (make-numeric-type :class (numeric-type-class type) - :format (numeric-type-format type) - :complexp :real - :low 0 - :high 0)) (t ;; We have a complex number. The result has the same type - ;; as the imaginary part, except that it's real, not complex, + ;; as the real part, except that it's real, not complex, ;; obviously. (make-numeric-type :class (numeric-type-class type) :format (numeric-type-format type) :complexp :real :low (numeric-type-low type) - :high (numeric-type-high type)))))) - (let ((type (continuation-type num))) - (cond ((union-type-p type) - (let ((result '())) - (dolist (x (union-type-types type)) - (push (imagpart-derive x) result)) - (make-union-type result))) - (t - (imagpart-derive type)))))) + :high (numeric-type-high type))))) + +(defoptimizer (realpart derive-type) ((num)) + (one-arg-derive-type num #'realpart-derive-type-aux)) + +(defun imagpart-derive-type-aux (type) + (cond ((numeric-type-real-p type) + ;; The imagpart of a real has the same type as the input, + ;; except that it's zero + (make-numeric-type :class (numeric-type-class type) + :format (numeric-type-format type) + :complexp :real + :low 0 + :high 0)) + (t + ;; We have a complex number. The result has the same type as + ;; the imaginary part, except that it's real, not complex, + ;; obviously. + (make-numeric-type :class (numeric-type-class type) + :format (numeric-type-format type) + :complexp :real + :low (numeric-type-low type) + :high (numeric-type-high type))))) + +(defoptimizer (imagpart derive-type) ((num)) + (one-arg-derive-type num #'imagpart-derive-type-aux)) + +(defun complex-derive-type-aux-1 (re-type) + (if (numeric-type-p re-type) + (make-numeric-type :class (numeric-type-class re-type) + :format (numeric-type-format re-type) + :complexp (if (csubtypep re-type + (specifier-type 'rational)) + :real + :complex) + :low (numeric-type-low re-type) + :high (numeric-type-high re-type)) + (specifier-type 'complex))) + +(defun complex-derive-type-aux-2 (re-type im-type same-arg) + (declare (ignore same-arg) + (optimize (debug 3) (safety 3))) + (if (and (numeric-type-p re-type) + (numeric-type-p im-type)) + ;; Need to check to make sure numeric-contagion returns the + ;; right type for what we want here. + + ;; Also, what about rational canonicalization, like (complex 5 0) + ;; is 5? So, if the result must be complex, we make it so. + ;; If the result might be complex, which happens only if the + ;; arguments are rational, we make it a union type of (or + ;; rational (complex rational)). + (let* ((element-type (numeric-contagion re-type im-type)) + (rat-result-p (csubtypep element-type + (specifier-type 'rational)))) + (if rat-result-p + (make-union-type + (list element-type + (specifier-type + `(complex ,(numeric-type-class element-type))))) + (make-numeric-type :class (numeric-type-class element-type) + :format (numeric-type-format element-type) + :complexp (if rat-result-p + :real + :complex)))) + (specifier-type 'complex))) (defoptimizer (complex derive-type) ((re &optional im)) (if im - (let ((re-type (continuation-type re)) - (im-type (continuation-type im))) - (if (and (numeric-type-p re-type) - (numeric-type-p im-type)) - ;; Need to check to make sure numeric-contagion returns - ;; the right type for what we want here. - - ;; Also, what about rational canonicalization, like - ;; (complex 5 0) is 5? So, if the result must be complex, - ;; we make it so. If the result might be complex, which - ;; happens only if the arguments are rational, we make it - ;; a union type of (or rational (complex rational)). - (let* ((element-type (numeric-contagion re-type im-type)) - (rat-result-p (csubtypep element-type - (specifier-type 'rational)))) - (if rat-result-p - (make-union-type - (list element-type - (specifier-type `(complex ,(numeric-type-class element-type))))) - (make-numeric-type :class (numeric-type-class element-type) - :format (numeric-type-format element-type) - :complexp (if rat-result-p - :real - :complex)))) - (specifier-type 'complex))) - (let ((re-type (continuation-type re))) - (if (numeric-type-p re-type) - (make-numeric-type :class (numeric-type-class re-type) - :format (numeric-type-format re-type) - :complexp (if (csubtypep re-type - (specifier-type 'rational)) - :real - :complex) - :low (numeric-type-low re-type) - :high (numeric-type-high re-type)) - (specifier-type 'complex))))) - -(macrolet ((frob (op type) - `(deftransform ,op ((w z) ((complex ,type) (complex ,type)) *) - '(complex (,op (realpart w) (realpart z)) - (,op (imagpart w) (imagpart z)))))) - ;; Complex addition and subtraction - (frob + single-float) - (frob + double-float) - (frob - single-float) - (frob - double-float)) + (two-arg-derive-type re im #'complex-derive-type-aux-2) + (one-arg-derive-type re #'complex-derive-type-aux-1))) + +;;; Define some transforms for complex operations. We do this in lieu +;;; of complex operation VOPs. +;;; (macrolet ((frob (type) `(progn + ;; Complex addition and subtraction + (deftransform + ((w z) ((complex ,type) (complex ,type)) *) + '(complex (+ (realpart w) (realpart z)) + (+ (imagpart w) (imagpart z)))) + (deftransform - ((w z) ((complex ,type) (complex ,type)) *) + '(complex (- (realpart w) (realpart z)) + (- (imagpart w) (imagpart z)))) + ;; Add and subtract a complex and a float (deftransform + ((w z) ((complex ,type) ,type) *) '(complex (+ (realpart w) z) (imagpart w))) (deftransform + ((z w) (,type (complex ,type)) *) - '(complex (+ (realpart w) z) (imagpart w)))))) - ;; Add and sub between a complex number and a float. - (frob single-float) - (frob double-float)) - -(macrolet ((frob (type) - `(progn + '(complex (+ (realpart w) z) (imagpart w))) + ;; Add and subtract a float and a complex number (deftransform - ((w z) ((complex ,type) ,type) *) '(complex (- (realpart w) z) (imagpart w))) (deftransform - ((z w) (,type (complex ,type)) *) - '(complex (- z (realpart w)) (- (imagpart w))))))) - ;; Add and sub between a complex number and a float. - (frob single-float) - (frob double-float)) - -(macrolet ((frob (type) - `(progn + '(complex (- z (realpart w)) (- (imagpart w)))) + ;; Multiply and divide two complex numbers (deftransform * ((x y) ((complex ,type) (complex ,type)) *) '(let* ((rx (realpart x)) (ix (imagpart x)) @@ -1264,73 +1143,84 @@ (let* ((r (/ ry iy)) (dn (* iy (+ 1 (* r r))))) (complex (/ (+ (* rx r) ix) dn) - (/ (- (* ix r) rx) dn))))))))) - ;; Multiplication and division for complex numbers - (frob single-float) - (frob double-float)) - -(macrolet ((frob (type) - `(progn + (/ (- (* ix r) rx) dn)))))) + ;; Multiplye a complex by a float or vice versa (deftransform * ((w z) ((complex ,type) ,type) *) '(complex (* (realpart w) z) (* (imagpart w) z))) (deftransform * ((z w) (,type (complex ,type)) *) - '(complex (* (realpart w) z) (* (imagpart w) z)))))) - (frob single-float) - (frob double-float)) + '(complex (* (realpart w) z) (* (imagpart w) z))) + ;; Divide a complex by a float + (deftransform / ((w z) ((complex ,type) ,type) *) + '(complex (/ (realpart w) z) (/ (imagpart w) z))) + ;; Conjugate of a float or complex number + (deftransform conjugate ((z) ((complex ,type)) *) + '(complex (realpart z) (- (imagpart z)))) + ;; Cis. + (deftransform cis ((z) ((,type)) *) + '(complex (cos z) (sin z)))))) -(macrolet ((frob (type) - `(deftransform / ((w z) ((complex ,type) ,type) *) - '(complex (/ (realpart w) z) (/ (imagpart w) z))))) - (frob single-float) - (frob double-float)) - -(macrolet ((frob (type) - `(deftransform conjugate ((z) ((complex ,type)) *) - '(complex (realpart z) (- (imagpart z)))))) (frob single-float) (frob double-float)) -(macrolet ((frob (type) - `(deftransform cis ((z) ((,type)) *) - '(complex (cos z) (sin z))))) - (frob single-float) - (frob double-float)) ;;; Here are simple optimizers for sin, cos, and tan. They do not ;;; produce a minimal range for the result; the result is the widest ;;; possible answer. This gets around the problem of doing range ;;; reduction correctly but still provides useful results when the ;;; inputs are union types. -;;; -;;; However, there appears to be a harmless bug somewhere. The result -;;; type of (sin z) where z is complex is (complex (float -1.0 1.0)). -;;; This is wrong, but it seems the compiler doesn't produce a -;;; type-check to see if the elements of the complex are really (float -;;; -1.0 1.0). #+propagate-fun-type (progn +(defun sincos-derive-type-aux (arg) + (etypecase arg + (numeric-type + (cond ((eq (numeric-type-complexp arg) :complex) + (make-numeric-type :class (numeric-type-class arg) + :format (numeric-type-format arg) + :complexp :complex + :low nil + :high nil)) + ((numeric-type-real-p arg) + (let ((float-type (or (numeric-type-format arg) 'float))) + (specifier-type `(,float-type + ,(coerce -1 float-type) + ,(coerce 1 float-type))))) + (t + (float-or-complex-type arg -1 1)))))) + (defoptimizer (sin derive-type) ((num)) - (elfun-derive-type-union - (continuation-type num) - (constantly t) - #'(lambda (lo hi) - (declare (ignore lo hi)) - (values -1d0 1d0)))) + (one-arg-derive-type num #'sincos-derive-type-aux)) (defoptimizer (cos derive-type) ((num)) - (elfun-derive-type-union - (continuation-type num) - (constantly t) - #'(lambda (lo hi) - (declare (ignore lo hi)) - (values -1d0 1d0)))) + (one-arg-derive-type num #'sincos-derive-type-aux)) + + +(defun tan-derive-type-aux (arg) + (etypecase arg + (numeric-type + (cond ((eq (numeric-type-complexp arg) :complex) + (make-numeric-type :class (numeric-type-class arg) + :format (numeric-type-format arg) + :complexp :complex + :low nil + :high nil)) + ((numeric-type-real-p arg) + (let ((float-type (or (numeric-type-format arg) 'float))) + (specifier-type float-type))) + (t + (float-or-complex-type arg)))))) (defoptimizer (tan derive-type) ((num)) - (elfun-derive-type-union - (continuation-type num) - (constantly t) - #'(lambda (lo hi) - (declare (ignore lo hi)) - (values nil nil)))) -) ; end progn + (one-arg-derive-type num #'tan-derive-type-aux)) + +;;; conjugate always returns the same type as the input type +(defoptimizer (conjugate derive-type) ((num)) + (continuation-type num)) + +(defoptimizer (cis derive-type) ((num)) + (one-arg-derive-type num + #'(lambda (arg) + (c::specifier-type + `(complex ,(or (numeric-type-format arg) 'single-float)))))) + +) ; end progn diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp index 1301148d6849a99664da816a7a9b8a9e90dc7f5c..93470a95308f5d977b674efc34176b3ba9de2061 100644 --- a/compiler/srctran.lisp +++ b/compiler/srctran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.63 1997/12/11 22:28:50 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.64 1997/12/14 14:10:24 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -298,7 +298,7 @@ (%make-interval :low (normalize-bound low) :high (normalize-bound high)))) -(proclaim '(inline bound-value set-bound bound-func)) +(proclaim '(inline bound-value set-bound)) ;;; Extract the numeric value of a bound. Return NIL, if X is NIL. (defun bound-value (x) @@ -314,7 +314,14 @@ (defun bound-func (f x) (and x (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero) - (set-bound (funcall f (bound-value x)) (consp x))))) + ;; With these traps masked, we might get things like infinity + ;; or negative infinity returned. Check for this and return + ;; NIL to indicate unbounded. + (let ((y (funcall f (bound-value x)))) + (if (and (floatp y) + (float-infinity-p y)) + nil + (set-bound (funcall f (bound-value x)) (consp x))))))) ;;; Apply a binary operator OP to two bounds X and Y. The result is ;;; NIL if either is NIL. Otherwise bound is computed and the result @@ -776,166 +783,112 @@ :low low :high high)) (numeric-contagion x y)))) -;;; Derive-Real-Type -- Internal -;;; -;;; Same as derive-integer-type except it can handle float types. -;;; This also contains derive-integer-type as a special case. -;;; -#+propagate-float-type +#+(or propagate-float-type propagate-fun-type) (progn -;;; Some functions only take one argument but derive-real-type assumes -;;; two. For those cases of one argument functions, set IGNORE-Y to T -;;; because we don't want derive-real-type to process the second -;;; argument because it's meaningless. -(defun derive-real-type (x y fun) - (declare (type continuation x y) (type function fun)) - (let ((x (continuation-type x)) - (y (continuation-type y))) - (derive-real-numeric-or-union-type x y fun))) - -;;; Some notes: This routine can handle X and Y if they are -;;; numeric-types or unions of numeric types. If this is not true, -;;; general numeric contagion holds. In particular if X is a member -;;; type, we could conceivably compute the right thing by looking -;;; inside the elements of the member type. We don't do this yet. -;;; Perhaps it would be better to let the user say so. Instead of -;;; saying (member 1 2 4), you should say (or (integer 1 1) (integer 2 -;;; 2) (integer 4 4)). -;;; -(defun derive-real-numeric-or-union-type (x y fun) - (labels ((combine (lx ly) - ;; Creates a new list containing all possible pairs from - ;; LX and LY. - (let ((result '())) - (dolist (ix lx) - (dolist (iy ly) - (push (list ix iy) result))) - (nreverse result))) - (listify (object) - ;; If object is a union type, get the list of the types. - ;; Otherwise make a list containing the single object. - (typecase object - (union-type - (union-type-types object)) - (t - (list object))))) - (let ((all (combine (listify x) - (listify y))) - (result '())) - (dolist (item all) - (destructuring-bind (ix iy) - item - (push (derive-simple-real-type ix iy fun) result))) - (setf result (derive-merged-union-types result)) - (if (cdr result) +;; Simple utility to flatten a list +(defun flatten-list (x) + (labels ((flatten-helper (x r);; 'r' is the stuff to the 'right'. + (cond ((null x) r) + ((atom x) + (cons x r)) + (t (flatten-helper (car x) + (flatten-helper (cdr x) r)))))) + (flatten-helper x nil))) + +(defun prepare-arg-for-derive-type (arg) + ;; Take some type of continuation and massage it so that we get a + ;; list of the constituent types. If ARG is *EMPTY-TYPE*, return + ;; NIL to indicate failure. + ;; + ;; WARNING: For some reason if ARG is of type (member 1 a), this + ;; routine only gets (member 1). I don't know why. + (flet ((listify (arg) + (typecase arg + (numeric-type + (list arg)) + (union-type + (union-type-types arg)) + (t + (list arg)))) + (convert-member-type (type) + ;; Run down the list of members and convert to the + ;; appropriate numeric-type. + (mapcar #'(lambda (element) + (if (numberp element) + (let ((type (type-of element))) + (specifier-type `(,(if (subtypep type 'integer) + 'integer + type) ,element ,element))) + *empty-type*)) + (member-type-members type)))) + (when (eq arg *empty-type*) + (return-from prepare-arg-for-derive-type nil)) + ;; Make sure all args are some type of numeric-type. For member + ;; types, convert the list of members into a union of equivalent + ;; numeric-types. + (let ((new-args (flatten-list (mapcar #'(lambda (x) + (if (member-type-p x) + (convert-member-type x) + x)) + (listify arg))))) + (if (member *empty-type* new-args) + nil + new-args)))) + + +;;; ONE-ARG-DERIVE-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 +;;; "atomic" continuation type like numeric-type. It should return +;;; the resulting type, which can be a list of types. +;;; +(defun one-arg-derive-type (arg derive-fcn) + (let ((arg-list (prepare-arg-for-derive-type (continuation-type arg))) + (result '())) + (when arg-list + ;; Run down the list of args and derive the type of each one and + ;; save all of the results in a list. + (setf result (flatten-list (mapcar derive-fcn arg-list))) + (if (rest result) + (make-union-type result) + (first result))))) + +;;; TWO-ARG-DERIVE-TYPE +;;; +;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes +;;; two arguments. DERIVE-FCN 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) + (let ((same-arg (same-leaf-ref-p arg1 arg2)) + (a1 (prepare-arg-for-derive-type (continuation-type arg1))) + (a2 (prepare-arg-for-derive-type (continuation-type arg2))) + (result '())) + (when (and a1 a2) + (if same-arg + ;; Since the args are the same continuation, just run down on + ;; of the lists. + (dolist (x a1) + (push (funcall derive-fcn x x same-arg) result)) + ;; Try all pairwise combinations and gather the result + (dolist (x a1) + (dolist (y a2) + (push (or (funcall derive-fcn x y same-arg) + (numeric-contagion x y)) + result)))) + (setf result (flatten-list result)) + (if (rest result) (make-union-type result) (first result))))) -;;; Merge the first interval in the list with the rest of intervals in -;;; the list. The list of intervals MUST be sorted in ascending order -;;; of lower limits. -;;; -(defun merge-types-aux (tlist) - (let* ((cur (first tlist)) - (cur-interval (if (numeric-type-real-p cur) - (numeric-type->interval cur) - nil)) - (res '())) - (dolist (this-interval (rest tlist) (cons cur res)) - (let ((this (if (numeric-type-real-p this-interval) - (numeric-type->interval this-interval) - nil))) - ;; If the current interval is complex (cur-interval is nil) or - ;; the next interval is complex (this is nil), we just simply - ;; add that to the resulting list. That is we don't try to - ;; merge complex types at all. - ;; - ;; If interval intersects cur or if they are adjacent, we can - ;; merge them together, but only if they are the same type of - ;; number. If they are different, we can't merge them. - (cond ((and cur-interval this - (eq (numeric-type-class cur) - (numeric-type-class this-interval)) - (eq (numeric-type-format cur) - (numeric-type-format this-interval)) - (or (interval-intersect-p cur-interval this) - (interval-adjacent-p cur-interval this))) - (let ((result (interval-merge-pair cur-interval this))) - (when result - (setf cur-interval result) - (setf (numeric-type-low cur) (interval-low result)) - (setf (numeric-type-high cur) (interval-high result))))) - (t - (push this-interval res))))))) - -;;; Compare the first element with the rest to merge whatever we can -;;; into the first element. The first element is totally merged, so -;;; we only need to consider whatever is left. -;;; -(defun merge-types (ilist &optional (result '())) - (cond ((null ilist) - result) - ((cdr ilist) - (let ((new-types (merge-types-aux ilist))) - (merge-types (rest new-types) (cons (first new-types) result)))) - (t - (cons (first ilist) result)))) - -(defun derive-merged-union-types (types) - (labels ((num-interval-< (a b) - (when (and (numeric-type-p a) - (numeric-type-p b)) - (let ((a-lo (numeric-type-low a)) - (b-lo (numeric-type-low b))) - (cond ((null a-lo) - ;; A has lower bound of -infinity, so it's - ;; lower than B, no matter what B is. - t) - ((null b-lo) - ;; At this point A has a numeric lower bound, - ;; but B has -infinity, so A is not lower than - ;; B. - nil) - (t - ;; Both A and B have numeric lower bounds. - ;; Make the right decision - (let ((av (bound-value a-lo)) - (bv (bound-value b-lo))) - (cond ((< av bv) - ;; Obviously - t) - ((= av bv) - ;; Bounds are equal. A is lower - ;; unless A is open and B is closed. - (or (numberp a-lo) (consp b-lo))) - (t - nil))))))))) - (merge-types (stable-sort types #'num-interval-<)))) - -(defun derive-simple-real-type (x y fun) - (declare (type function fun)) - ;; We handle the case of real operands. For the other cases, we use - ;; general numeric contagion. - (if (and (numeric-type-p x) (numeric-type-p y) - (eq (numeric-type-complexp x) :real) - (eq (numeric-type-complexp y) :real)) - (multiple-value-bind (low high type format) - (funcall fun x y) - (flet ((valid-bound-p (bnd) - (or (eq bnd '*) - (eq bnd nil) - (numberp bnd) - (and (consp bnd) - (numberp (first bnd)))))) - (assert (and (valid-bound-p low) - (valid-bound-p high))) - (make-numeric-type :class type - :complexp :real - :format format - :low low - :high high))) - (numeric-contagion x y))) ) ; end progn @@ -993,127 +946,137 @@ #+propagate-float-type (progn +(defun +-derive-type-aux (x y same-arg) + (if (and (numeric-type-real-p x) + (numeric-type-real-p y)) + (let ((result + (if same-arg + (let ((x-int (numeric-type->interval x))) + (interval-add x-int x-int)) + (interval-add (numeric-type->interval x) + (numeric-type->interval y)))) + (result-type (numeric-contagion x y))) + ;; If the result type is a float, we need to be sure to coerce + ;; the bounds into the correct type. + (when (eq (numeric-type-class result-type) 'float) + (setf result (interval-func + #'(lambda (x) + (coerce x (or (numeric-type-format result-type) + 'float))) + result))) + (make-numeric-type + :class (if (and (eq (numeric-type-class x) 'integer) + (eq (numeric-type-class y) 'integer)) + ;; The sum of integers is always an integer + 'integer + (numeric-type-class result-type)) + :format (numeric-type-format result-type) + :low (interval-low result) + :high (interval-high result))) + ;; General contagion + (numeric-contagion x y))) + + (defoptimizer (+ derive-type) ((x y)) - (let ((same-arg (same-leaf-ref-p x y))) - (derive-real-type - x y - #'(lambda (x y) - (declare (type numeric-type x y)) - (let ((result - (if same-arg - (let ((x-int (numeric-type->interval x))) - (interval-add x-int x-int)) - (interval-add (numeric-type->interval x) - (numeric-type->interval y)))) - (result-type (numeric-contagion x y))) - ;; If the result type is a float, we need to be sure to - ;; coerce the bounds into the correct type. - (when (eq (numeric-type-class result-type) 'float) - (setf result (interval-func - #'(lambda (x) - (coerce x (or (numeric-type-format result-type) - 'float))) - result))) - (values (interval-low result) - (interval-high result) - (if (and (eq (numeric-type-class x) 'integer) - (eq (numeric-type-class y) 'integer)) - ;; The sum of integers is always an integer - 'integer - (numeric-type-class result-type)) - (numeric-type-format result-type))))))) + (two-arg-derive-type x y #'+-derive-type-aux)) + +(defun --derive-type-aux (x y same-arg) + (if (and (numeric-type-real-p x) + (numeric-type-real-p y)) + (let ((result + ;; (- x x) is always 0. + (if same-arg + (make-interval :low 0 :high 0) + (interval-sub (numeric-type->interval x) + (numeric-type->interval y)))) + (result-type (numeric-contagion x y))) + ;; If the result type is a float, we need to be sure to coerce + ;; the bounds into the correct type. + (when (eq (numeric-type-class result-type) 'float) + (setf result (interval-func + #'(lambda (x) + (coerce x (or (numeric-type-format result-type) + 'float))) + result))) + (make-numeric-type + :class (if (and (eq (numeric-type-class x) 'integer) + (eq (numeric-type-class y) 'integer)) + ;; The difference of integers is always an integer + 'integer + (numeric-type-class result-type)) + :format (numeric-type-format result-type) + :low (interval-low result) + :high (interval-high result))) + ;; General contagion + (numeric-contagion x y))) (defoptimizer (- derive-type) ((x y)) - (let ((same-arg (same-leaf-ref-p x y))) - (derive-real-type - x y - #'(lambda (x y) - (declare (type numeric-type x y)) - (let ((result - ;; (- x x) is always 0. - (if same-arg - (make-interval :low 0 :high 0) - (interval-sub (numeric-type->interval x) - (numeric-type->interval y)))) - (result-type (numeric-contagion x y))) - ;; If the result type is a float, we need to be sure to - ;; coerce the bounds into the correct type. - (when (eq (numeric-type-class result-type) 'float) - (setf result (interval-func - #'(lambda (x) - (coerce x (or (numeric-type-format result-type) - 'float))) - result))) - (values (interval-low result) - (interval-high result) - (if (and (eq (numeric-type-class x) 'integer) - (eq (numeric-type-class y) 'integer)) - ;; The difference of integers is always an integer - 'integer - (numeric-type-class result-type)) - (numeric-type-format result-type))))))) + (two-arg-derive-type x y #'--derive-type-aux)) + +(defun *-derive-type-aux (x y same-arg) + (if (and (numeric-type-real-p x) + (numeric-type-real-p y)) + (let ((result + ;; (* x x) is always positive, so take care to do it + ;; right. + (if same-arg + (interval-sqr (numeric-type->interval x)) + (interval-mul (numeric-type->interval x) + (numeric-type->interval y)))) + (result-type (numeric-contagion x y))) + ;; If the result type is a float, we need to be sure to coerce + ;; the bounds into the correct type. + (when (eq (numeric-type-class result-type) 'float) + (setf result (interval-func + #'(lambda (x) + (coerce x (or (numeric-type-format result-type) + 'float))) + result))) + (make-numeric-type + :class (if (and (eq (numeric-type-class x) 'integer) + (eq (numeric-type-class y) 'integer)) + ;; The product of integers is always an integer + 'integer + (numeric-type-class result-type)) + :format (numeric-type-format result-type) + :low (interval-low result) + :high (interval-high result))) + (numeric-contagion x y))) (defoptimizer (* derive-type) ((x y)) - (let ((same-arg (same-leaf-ref-p x y))) - (derive-real-type - x y - #'(lambda (x y) - (let ((result - ;; (* x x) is always positive, so take care to do it - ;; right. - (if same-arg - (interval-sqr (numeric-type->interval x)) - (interval-mul (numeric-type->interval x) - (numeric-type->interval y)))) - (result-type (numeric-contagion x y))) - ;; If the result type is a float, we need to be sure to - ;; coerce the bounds into the correct type. - (when (eq (numeric-type-class result-type) 'float) - (setf result (interval-func - #'(lambda (x) - (coerce x (or (numeric-type-format result-type) - 'float))) - result))) - (values (interval-low result) - (interval-high result) - (if (and (eq (numeric-type-class x) 'integer) - (eq (numeric-type-class y) 'integer)) - ;; The product of integers is always an integer - 'integer - (numeric-type-class result-type)) - (numeric-type-format result-type))))))) - + (two-arg-derive-type x y #'*-derive-type-aux)) + +(defun /-derive-type-aux (x y same-arg) + (if (and (numeric-type-real-p x) + (numeric-type-real-p y)) + (let ((result + ;; (/ x x) is always 1, except if x can contain 0. In + ;; that case, we shouldn't optimize the division away + ;; because we want 0/0 to signal an error. + (if (and same-arg + (not (interval-contains-p + 0 (interval-closure (numeric-type->interval y))))) + (make-interval :low 1 :high 1) + (interval-div (numeric-type->interval x) + (numeric-type->interval y)))) + (result-type (numeric-contagion x y))) + ;; If the result type is a float, we need to be sure to coerce + ;; the bounds into the correct type. + (when (eq (numeric-type-class result-type) 'float) + (setf result (interval-func + #'(lambda (x) + (coerce x (or (numeric-type-format result-type) + 'float))) + result))) + (make-numeric-type :class (numeric-type-class result-type) + :format (numeric-type-format result-type) + :low (interval-low result) + :high (interval-high result))) + (numeric-contagion x y))) (defoptimizer (/ derive-type) ((x y)) - (let ((same-arg (same-leaf-ref-p x y))) - (derive-real-type - x y - #'(lambda (x y) - (declare (type numeric-type x y)) - (let ((result - ;; (/ x x) is always 1, except if x can contain 0. In - ;; that case, we shouldn't optimize the division away - ;; because we want 0/0 to signal an error. - (if (and same-arg - (not (interval-contains-p 0 - (interval-closure (numeric-type->interval y))))) - (make-interval :low 1 :high 1) - (interval-div (numeric-type->interval x) - (numeric-type->interval y)))) - (result-type (numeric-contagion x y))) - ;; If the result type is a float, we need to be sure to - ;; coerce the bounds into the correct type. - (when (eq (numeric-type-class result-type) 'float) - (setf result (interval-func - #'(lambda (x) - (coerce x (or (numeric-type-format result-type) - 'float))) - result))) - (values (interval-low result) - (interval-high result) - (numeric-type-class result-type) - (numeric-type-format result-type))))))) + (two-arg-derive-type x y #'/-derive-type-aux)) ) ;end progn @@ -1165,24 +1128,31 @@ (derive-integer-type int int (frob lognot)))) #+propagate-float-type -(macrolet ((frob (fun) - `#'(lambda (type type2) - (declare (ignore type2)) - (let ((lo (numeric-type-low type)) - (hi (numeric-type-high type))) - (values (if hi (,fun hi) nil) - (if lo (,fun lo) nil) - (numeric-type-class type) - (numeric-type-format type)))))) - - (defoptimizer (%negate derive-type) ((num)) - (flet ((negate-bound (b) - (set-bound (- (bound-value b)) (consp b)))) - (derive-real-type num num (frob negate-bound)))) - - (defoptimizer (lognot derive-type) ((int)) - (derive-integer-type int int (frob lognot)))) +(defoptimizer (lognot derive-type) ((int)) + (derive-integer-type int int + #'(lambda (type type2) + (declare (ignore type2)) + (let ((lo (numeric-type-low type)) + (hi (numeric-type-high type))) + (values (if hi (lognot hi) nil) + (if lo (lognot lo) nil) + (numeric-type-class type) + (numeric-type-format type)))))) +#+propagate-float-type +(defoptimizer (%negate derive-type) ((num)) + (flet ((negate-bound (b) + (set-bound (- (bound-value b)) (consp b)))) + (one-arg-derive-type num + #'(lambda (type) + (let ((lo (numeric-type-low type)) + (hi (numeric-type-high type)) + (result (copy-numeric-type type))) + (setf (numeric-type-low result) + (if hi (negate-bound hi) nil)) + (setf (numeric-type-high result) + (if lo (negate-bound lo) nil)) + result))))) #-propagate-float-type (defoptimizer (abs derive-type) ((num)) @@ -1204,44 +1174,29 @@ nil))) (numeric-contagion type type)))) -(defun abs-derive-type-aux (type &optional (result '())) - (cond ((null type) - result) - ((atom type) - (cons (cond - ((eq (numeric-type-complexp type) :complex) - ;; The absolute value of a complex number is always - ;; a non-negative float. - (make-numeric-type :class 'float - :format (elfun-float-format - (numeric-type-format type)) - :complexp :real - :low 0 - :high nil)) - ((eq (numeric-type-complexp type) :real) - ;; The absolute value of a real number is a - ;; non-negative real of the same type. - (let ((abs-bnd (interval-abs (numeric-type->interval type)))) - (make-numeric-type :class (numeric-type-class type) - :format (numeric-type-format type) - :complexp :real - :low (interval-low abs-bnd) - :high (interval-high abs-bnd))))) - result)) - ((listp type) - (abs-derive-type-aux (rest type) - (append (abs-derive-type-aux (first type)) - result))))) - +#+propagate-float-type +(defun abs-derive-type-aux (type) + (cond ((eq (numeric-type-complexp type) :complex) + ;; The absolute value of a complex number is always a + ;; non-negative float. + (make-numeric-type :class 'float + :format (elfun-float-format + (numeric-type-format type)) + :complexp :real + :low 0 + :high nil)) + (t + ;; The absolute value of a real number is a non-negative real + ;; of the same type. + (let ((abs-bnd (interval-abs (numeric-type->interval type)))) + (make-numeric-type :class (numeric-type-class type) + :format (numeric-type-format type) + :complexp :real + :low (interval-low abs-bnd) + :high (interval-high abs-bnd)))))) #+propagate-float-type (defoptimizer (abs derive-type) ((num)) - (let ((type (continuation-type num))) - (cond ((numeric-type-p type) - (first (abs-derive-type-aux type))) - ((union-type-p type) - (make-union-type - (derive-merged-union-types - (abs-derive-type-aux (union-type-types type)))))))) + (one-arg-derive-type num #'abs-derive-type-aux)) #-propagate-float-type (defoptimizer (truncate derive-type) ((number divisor)) @@ -1310,6 +1265,7 @@ ;; are REAL so the result is a REAL. 'real))) + (defun truncate-derive-type-quot (number-type divisor-type) (let* ((rem-type (rem-result-type number-type divisor-type)) (number-interval (numeric-type->interval number-type)) @@ -1323,24 +1279,14 @@ (interval-low number-interval) (interval-high number-interval) (interval-low divisor-interval) - (interval-high divisor-interval))) - type lo hi) - (when (listp res) - (setf type (first res)) - (setf lo (second res)) - (setf hi (third res)) - (setf lo (if (or (equal lo ''*) (eq lo '*)) - nil lo)) - (setf hi (if (or (equal lo ''*) (eq hi '*)) - nil hi))) - (values lo hi type nil))) + (interval-high divisor-interval)))) + (specifier-type (if (listp res) res 'integer)))) (t (let ((quot (truncate-quotient-bound (interval-div number-interval divisor-interval)))) - (values (interval-low quot) - (interval-high quot) - 'integer nil)))))) + (specifier-type `(integer ,(or (interval-low quot) '*) + ,(or (interval-high quot) '*)))))))) (defun truncate-derive-type-rem (number-type divisor-type) (let* ((rem-type (rem-result-type number-type divisor-type)) @@ -1352,9 +1298,8 @@ (cond ((eq rem-type 'integer) ;; Since the remainder type is INTEGER, both args are ;; INTEGERs. - (values (interval-low rem) - (interval-high rem) - rem-type nil)) + (specifier-type `(,rem-type ,(or (interval-low rem) '*) + ,(or (interval-high rem) '*)))) (t (multiple-value-bind (class format) (ecase rem-type @@ -1372,61 +1317,69 @@ (setf rem (interval-func #'(lambda (x) (coerce x rem-type)) rem))) - (values (interval-low rem) - (interval-high rem) - class format)))))) + (make-numeric-type :class class + :format format + :low (interval-low rem) + :high (interval-high rem))))))) + +(defun truncate-derive-type-quot-aux (num div same-arg) + (declare (ignore same-arg)) + (if (and (numeric-type-real-p num) + (numeric-type-real-p div)) + (truncate-derive-type-quot num div) + *empty-type*)) + +(defun truncate-derive-type-rem-aux (num div same-arg) + (declare (ignore same-arg)) + (if (and (numeric-type-real-p num) + (numeric-type-real-p div)) + (truncate-derive-type-rem num div) + *empty-type*)) (defoptimizer (truncate derive-type) ((number divisor)) - (if (and (numeric-real-union-type-p (continuation-type number)) - (numeric-real-union-type-p (continuation-type divisor))) - (make-values-type - :required - `(,(derive-real-type number divisor - #'truncate-derive-type-quot) - ,(derive-real-type number divisor - #'truncate-derive-type-rem))) - *universal-type*)) + (make-values-type + :required + (list + (two-arg-derive-type number divisor #'truncate-derive-type-quot-aux) + (two-arg-derive-type number divisor #'truncate-derive-type-rem-aux)))) (defun ftruncate-derive-type-quot (number-type divisor-type) ;; The bounds are the same as for truncate. However, the first ;; result is a float of some type. We need to determine what that ;; type is. Basically it's the more contagious of the two types. - (multiple-value-bind (lo hi class format) - (truncate-derive-type-quot number-type divisor-type) - (declare (ignore class format)) - (let ((res-type (numeric-contagion number-type divisor-type))) - (values lo hi (numeric-type-class res-type) - (numeric-type-format res-type))))) + (let ((q-type (truncate-derive-type-quot number-type divisor-type)) + (res-type (numeric-contagion number-type divisor-type))) + (make-numeric-type :class 'float + :format (numeric-type-format res-type) + :low (numeric-type-low q-type) + :high (numeric-type-high q-type)))) + +(defun ftruncate-derive-type-quot-aux (n d same-arg) + (declare (ignore same-arg)) + (if (and (numeric-type-real-p n) + (numeric-type-real-p d)) + (ftruncate-derive-type-quot n d) + *empty-type*)) (defoptimizer (ftruncate derive-type) ((number divisor)) - (if (and (numeric-real-union-type-p (continuation-type number)) - (numeric-real-union-type-p (continuation-type divisor))) - (make-values-type - :required - `(,(derive-real-type number divisor - #'ftruncate-derive-type-quot) - ,(derive-real-type number divisor - #'truncate-derive-type-rem))) - *universal-type*)) - -;;; Optimizer for %unary-truncate. We only want the first result of -;;; truncate (the quotient part of truncate). -(defoptimizer (%unary-truncate derive-type) ((number)) - (let ((type (continuation-type number))) - (if (numeric-real-union-type-p type) - (derive-real-numeric-or-union-type type - (specifier-type '(integer 1 1)) - #'truncate-derive-type-quot) - *universal-type*))) + (make-values-type + :required + (list + (two-arg-derive-type number divisor #'ftruncate-derive-type-quot-aux) + (two-arg-derive-type number divisor #'truncate-derive-type-rem-aux)))) +(defun %unary-truncate-derive-type-aux (number) + (truncate-derive-type-quot number (specifier-type '(integer 1 1)))) +(defoptimizer (%unary-truncate derive-type) ((number)) + (one-arg-derive-type number #'%unary-truncate-derive-type-aux)) ;;; Define optimizers for floor and ceiling (macrolet ((frob-opt (name q-name r-name) - (let ((q-aux (intern (concatenate 'string (symbol-name q-name) "-AUX"))) - (r-aux (intern (concatenate 'string (symbol-name r-name) "-AUX")))) + (let ((q-aux (symbolicate q-name "-AUX")) + (r-aux (symbolicate r-name "-AUX"))) `(progn ;; Compute type of quotient (first) result (defun ,q-aux (number-type divisor-type) @@ -1436,16 +1389,14 @@ (numeric-type->interval divisor-type)) (quot (,q-name (interval-div number-interval divisor-interval)))) - (values (interval-low quot) - (interval-high quot) - 'integer nil))) + (specifier-type `(integer ,(or (interval-low quot) '*) + ,(or (interval-high quot) '*))))) ;; Compute type of remainder (defun ,r-aux (number-type divisor-type) (let* ((divisor-interval (numeric-type->interval divisor-type)) (rem (,r-name divisor-interval)) - (result-type (rem-result-type number-type - divisor-type))) + (result-type (rem-result-type number-type divisor-type))) (multiple-value-bind (class format) (ecase result-type (integer @@ -1458,27 +1409,35 @@ (values 'float nil)) (real (values nil nil))) - (when (member result-type - '(float single-float double-float)) + (when (member result-type '(float single-float double-float)) ;; Make sure the limits on the interval have ;; the right type. (setf rem (interval-func #'(lambda (x) (coerce x result-type)) rem))) - (values (interval-low rem) - (interval-high rem) - class format)))) + (make-numeric-type :class class + :format format + :low (interval-low rem) + :high (interval-high rem))))) ;; The optimizer itself (defoptimizer (,name derive-type) ((number divisor)) - (if (and (numeric-real-union-type-p (continuation-type number)) - (numeric-real-union-type-p (continuation-type divisor))) - (make-values-type - :required - `(,(derive-real-type number divisor - #',q-aux) - ,(derive-real-type number divisor - #',r-aux))) - *universal-type*)))))) + (flet ((derive-q (n d same-arg) + (declare (ignore same-arg)) + (if (and (numeric-type-real-p n) + (numeric-type-real-p d)) + (,q-aux n d) + *empty-type*)) + (derive-r (n d same-arg) + (declare (ignore same-arg)) + (if (and (numeric-type-real-p n) + (numeric-type-real-p d)) + (,r-aux n d) + *empty-type*))) + (make-values-type + :required + (list (two-arg-derive-type number divisor #'derive-q) + (two-arg-derive-type number divisor #'derive-r))))) + )))) (frob-opt floor floor-quotient-bound floor-rem-bound) (frob-opt ceiling ceiling-quotient-bound ceiling-rem-bound)) @@ -1486,13 +1445,8 @@ ;;; Define optimizers for ffloor and fceiling (macrolet ((frob-opt (name q-name r-name) - (let ((q-aux (intern (concatenate 'string - "F" - (symbol-name q-name) - "-AUX"))) - (r-aux (intern (concatenate 'string - (symbol-name r-name) - "-AUX")))) + (let ((q-aux (symbolicate "F" q-name "-AUX")) + (r-aux (symbolicate r-name "-AUX"))) `(progn ;; Compute type of quotient (first) result (defun ,q-aux (number-type divisor-type) @@ -1503,21 +1457,29 @@ (quot (,q-name (interval-div number-interval divisor-interval))) (res-type (numeric-contagion number-type divisor-type))) - (values (interval-low quot) - (interval-high quot) - (numeric-type-class res-type) - (numeric-type-format res-type)))) - + (make-numeric-type + :class (numeric-type-class res-type) + :format (numeric-type-format res-type) + :low (interval-low quot) + :high (interval-high quot)))) + (defoptimizer (,name derive-type) ((number divisor)) - (if (and (numeric-real-union-type-p (continuation-type number)) - (numeric-real-union-type-p (continuation-type divisor))) - (make-values-type - :required - `(,(derive-real-type number divisor - #',q-aux) - ,(derive-real-type number divisor - #',r-aux))) - *universal-type*)))))) + (flet ((derive-q (n d same-arg) + (declare (ignore same-arg)) + (if (and (numeric-type-real-p n) + (numeric-type-real-p d)) + (,q-aux n d) + *empty-type*)) + (derive-r (n d same-arg) + (declare (ignore same-arg)) + (if (and (numeric-type-real-p n) + (numeric-type-real-p d)) + (,r-aux n d) + *empty-type*))) + (make-values-type + :required + (list (two-arg-derive-type number divisor #'derive-q) + (two-arg-derive-type number divisor #'derive-r))))))))) (frob-opt ffloor floor-quotient-bound floor-rem-bound) (frob-opt fceiling ceiling-quotient-bound ceiling-rem-bound)) @@ -1532,10 +1494,9 @@ (hi (interval-high quot))) ;; Take the floor of the lower bound. The result is always a ;; closed lower bound. - (setf lo - (if lo - (floor (bound-value lo)) - nil)) + (setf lo (if lo + (floor (bound-value lo)) + nil)) ;; For the upper bound, we need to be careful (setf hi (cond ((consp hi) @@ -1557,14 +1518,16 @@ (defun floor-rem-bound (div) ;; The remainder depends only on the divisor. Try to get the ;; correct sign for the remainder if we can. - + (case (interval-range-info div) (+ ;; Divisor is always positive. (let ((rem (interval-abs div))) (setf (interval-low rem) 0) - (when (numberp (interval-high rem)) - ;; The remainder never contains the upper bound. + (when (and (numberp (interval-high rem)) + (not (zerop (interval-high rem)))) + ;; The remainder never contains the upper bound. However, + ;; watch out for the case where the high limit is zero! (setf (interval-high rem) (list (interval-high rem)))) rem)) (- @@ -1629,10 +1592,9 @@ (hi (interval-high quot))) ;; Take the ceiling of the upper bound. The result is always a ;; closed upper bound. - (setf hi - (if hi - (ceiling (bound-value hi)) - nil)) + (setf hi (if hi + (ceiling (bound-value hi)) + nil)) ;; For the lower bound, we need to be careful (setf lo (cond ((consp lo) @@ -1655,14 +1617,16 @@ (defun ceiling-rem-bound (div) ;; The remainder depends only on the divisor. Try to get the ;; correct sign for the remainder if we can. - + (case (interval-range-info div) (+ ;; Divisor is always positive. The remainder is negative. (let ((rem (interval-neg (interval-abs div)))) (setf (interval-high rem) 0) - (when (numberp (interval-low rem)) - ;; The remainder never contains the upper bound. + (when (and (numberp (interval-low rem)) + (not (zerop (interval-low rem)))) + ;; The remainder never contains the upper bound. However, + ;; watch out for the case when the upper bound is zero! (setf (interval-low rem) (list (interval-low rem)))) rem)) (- @@ -1764,11 +1728,9 @@ (- (case (interval-range-info div) (+ - (ceiling-rem-bound div) - ) + (ceiling-rem-bound div)) (- - (floor-rem-bound div) - ) + (floor-rem-bound div)) (otherwise (destructuring-bind (neg pos) (interval-split 0 div t t) @@ -1816,7 +1778,7 @@ ;; We've got a problem: guarenteed division by zero. (return-from integer-truncate-derive-type t)) (when (zerop divisor-min) - ;; We'll assume that they arn't going to divide by zero. + ;; We'll assume that they aren't going to divide by zero. (incf divisor-min)) (cond ((and number-sign divisor-sign) ;; We know the sign of both.