diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp index 91ecdf4bcbabfed2d55f4aeab01a4f6eebdc3a0f..b8a933782f052a8aba707895e5d7ea16d31d90ae 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.60 1998/01/24 14:49:23 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.61 1998/02/05 16:55:16 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1244,7 +1244,8 @@ #+propagate-fun-type (progn -(defun sincos-derive-type-aux (arg) +(defun trig-derive-type-aux (arg domain fcn + &optional def-lo def-hi (increasingp t)) (etypecase arg (numeric-type (cond ((eq (numeric-type-complexp arg) :complex) @@ -1253,34 +1254,65 @@ :complexp :complex)) ((numeric-type-real-p arg) (let ((float-type (or (numeric-type-format arg) 'float))) + ;; If the argument is a subset of the "principal" domain + ;; of the function, we can compute the bounds because + ;; the function is monotonic. We can't do this in + ;; general for these periodic functions because we can't + ;; (and don't want to) do the argument reduction in + ;; exactly the same way as the functions themselves do + ;; it. + (if (csubtypep arg domain) + (let ((lo (bound-func fcn (numeric-type-low arg))) + (hi (bound-func fcn (numeric-type-high arg)))) + (unless increasingp + (rotatef lo hi)) (specifier-type `(,float-type - ,(coerce -1 float-type) - ,(coerce 1 float-type))))) + ,(or lo *) + ,(or hi *)))) + (specifier-type `(,float-type + ,(if def-lo + (coerce def-lo float-type) + '*) + ,(if def-hi + (coerce def-hi float-type) + '*)))))) (t - (float-or-complex-type arg -1 1)))))) + (float-or-complex-type arg def-lo def-hi)))))) (defoptimizer (sin derive-type) ((num)) - (one-arg-derive-type num #'sincos-derive-type-aux #'sin)) + (one-arg-derive-type + num + #'(lambda (arg) + ;; Derive the bounds if the arg is in [-pi/2, pi/2] + (trig-derive-type-aux + arg + (specifier-type `(float ,#.(- (/ pi 2)) ,#.(/ pi 2))) + #'sin + -1 1)) + #'sin)) (defoptimizer (cos derive-type) ((num)) - (one-arg-derive-type num #'sincos-derive-type-aux #'cos)) - - -(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)) - ((numeric-type-real-p arg) - (let ((float-type (or (numeric-type-format arg) 'float))) - (specifier-type float-type))) - (t - (float-or-complex-type arg)))))) + (one-arg-derive-type + num + #'(lambda (arg) + ;; Derive the bounds if the arg is in [0, pi] + (trig-derive-type-aux arg + (specifier-type `(float 0d0 ,pi)) + #'cos + -1 1 + nil)) + #'cos)) (defoptimizer (tan derive-type) ((num)) - (one-arg-derive-type num #'tan-derive-type-aux #'tan)) + (one-arg-derive-type + num + #'(lambda (arg) + ;; Derive the bounds if the arg is in [-pi/2, pi/2] + (trig-derive-type-aux arg + (specifier-type `(float ,#.(- (/ pi 2)) ,#.(/ pi 2))) + #'tan + nil nil)) + #'tan)) ;;; conjugate always returns the same type as the input type (defoptimizer (conjugate derive-type) ((num))