diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp index 86b7e8a8cecd6e2d0cc5f7482b6231b53684e9a0..6104a7dcdd135b256d5c0aacf9b17341bb5ce5f1 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.54 1997/12/18 16:42:02 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.55 1997/12/18 19:01:00 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -280,9 +280,9 @@ :high new-hi))))) ;;; (defoptimizer (scale-single-float derive-type) ((f ex)) - (two-arg-derive-type f ex #'scale-float-derive-type-aux)) + (two-arg-derive-type f ex #'scale-float-derive-type-aux #'scale-single-float)) (defoptimizer (scale-double-float derive-type) ((f ex)) - (two-arg-derive-type f ex #'scale-float-derive-type-aux)) + (two-arg-derive-type f ex #'scale-float-derive-type-aux #'scale-double-float)) ;;; toy@rtp.ericsson.se: ;;; @@ -307,7 +307,7 @@ (specifier-type `(,',type ,(or lo '*) ,(or hi '*))))) (defoptimizer (,fun derive-type) ((num)) - (one-arg-derive-type num #',aux-name)))))) + (one-arg-derive-type num #',aux-name #',fun)))))) (frob %single-float single-float) (frob %double-float double-float)) ) ; end progn @@ -628,7 +628,8 @@ #'(lambda (arg) (elfun-derive-type-simple arg #',name ,cond - ,def-lo-bnd ,def-hi-bnd))))))) + ,def-lo-bnd ,def-hi-bnd)) + #',name))))) ;; These functions are easy because they are defined for the whole ;; real line. (frob exp (constantly t) @@ -688,12 +689,12 @@ ((consp lo) (list (coerce 0 f-type))) (t (coerce 0 f-type))) :high (bound-func #'sqrt hi))) - (float-or-complex-type arg)))) + (float-or-complex-type arg 0)))) (t (float-or-complex-type arg 0)))))) ;;; (defoptimizer (sqrt derive-type) ((num)) - (one-arg-derive-type num #'sqrt-derive-type-aux)) + (one-arg-derive-type num #'sqrt-derive-type-aux #'sqrt)) ;;; Acos is monotonic decreasing, so we need to swap the function @@ -725,7 +726,7 @@ (float-or-complex-type arg 0 pi)))))) ;;; (defoptimizer (acos derive-type) ((num)) - (one-arg-derive-type num #'acos-derive-type-aux)) + (one-arg-derive-type num #'acos-derive-type-aux #'acos)) ;;; Compute bounds for (expt x y). This should be easy since (expt x @@ -890,7 +891,7 @@ (float-or-complex-type (numeric-contagion x y))))))) (defoptimizer (expt derive-type) ((x y)) - (two-arg-derive-type x y #'expt-derive-type-aux)) + (two-arg-derive-type x y #'expt-derive-type-aux #'expt)) ;;; Note must assume that a type including 0.0 may also include -0.0 @@ -940,8 +941,8 @@ (defoptimizer (log derive-type) ((x &optional y)) (if y - (two-arg-derive-type x y #'log-derive-type-aux-2) - (one-arg-derive-type x #'log-derive-type-aux-1))) + (two-arg-derive-type x y #'log-derive-type-aux-2 #'log) + (one-arg-derive-type x #'log-derive-type-aux-1 #'log))) (defun atan-derive-type-aux-1 (y) @@ -967,9 +968,9 @@ (defoptimizer (atan derive-type) ((y &optional x)) (cond ((null x) - (one-arg-derive-type y #'atan-derive-type-aux-1)) + (one-arg-derive-type y #'atan-derive-type-aux-1 #'atan)) (t - (two-arg-derive-type y x #'atan-derive-type-aux-2)))) + (two-arg-derive-type y x #'atan-derive-type-aux-2 #'atan)))) (defun cosh-derive-type-aux (x) @@ -980,7 +981,7 @@ #'cosh (constantly t) 0 nil)) (defoptimizer (cosh derive-type) ((num)) - (one-arg-derive-type num #'cosh-derive-type-aux)) + (one-arg-derive-type num #'cosh-derive-type-aux #'cosh)) (defun phase-derive-type-aux (type) @@ -1031,7 +1032,7 @@ :high pi)))) (defoptimizer (phase derive-type) ((num)) - (one-arg-derive-type num #'phase-derive-type-aux)) + (one-arg-derive-type num #'phase-derive-type-aux #'phase)) ) ;end progn for propagate-fun-type @@ -1067,7 +1068,7 @@ :high (numeric-type-high type))))) (defoptimizer (realpart derive-type) ((num)) - (one-arg-derive-type num #'realpart-derive-type-aux)) + (one-arg-derive-type num #'realpart-derive-type-aux #'realpart)) (defun imagpart-derive-type-aux (type) (cond ((numeric-type-real-p type) @@ -1089,7 +1090,7 @@ :high (numeric-type-high type))))) (defoptimizer (imagpart derive-type) ((num)) - (one-arg-derive-type num #'imagpart-derive-type-aux)) + (one-arg-derive-type num #'imagpart-derive-type-aux #'imagpart)) (defun complex-derive-type-aux-1 (re-type) (if (numeric-type-p re-type) @@ -1133,8 +1134,8 @@ (defoptimizer (complex derive-type) ((re &optional im)) (if im - (two-arg-derive-type re im #'complex-derive-type-aux-2) - (one-arg-derive-type re #'complex-derive-type-aux-1))) + (two-arg-derive-type re im #'complex-derive-type-aux-2 #'complex) + (one-arg-derive-type re #'complex-derive-type-aux-1 #'complex))) ;;; Define some transforms for complex operations. We do this in lieu @@ -1224,10 +1225,10 @@ (float-or-complex-type arg -1 1)))))) (defoptimizer (sin derive-type) ((num)) - (one-arg-derive-type num #'sincos-derive-type-aux)) + (one-arg-derive-type num #'sincos-derive-type-aux #'sin)) (defoptimizer (cos derive-type) ((num)) - (one-arg-derive-type num #'sincos-derive-type-aux)) + (one-arg-derive-type num #'sincos-derive-type-aux #'cos)) (defun tan-derive-type-aux (arg) @@ -1244,7 +1245,7 @@ (float-or-complex-type arg)))))) (defoptimizer (tan derive-type) ((num)) - (one-arg-derive-type num #'tan-derive-type-aux)) + (one-arg-derive-type num #'tan-derive-type-aux #'tan)) ;;; conjugate always returns the same type as the input type (defoptimizer (conjugate derive-type) ((num)) @@ -1254,6 +1255,7 @@ (one-arg-derive-type num #'(lambda (arg) (c::specifier-type - `(complex ,(or (numeric-type-format arg) 'single-float)))))) + `(complex ,(or (numeric-type-format arg) 'single-float)))) + #'cis)) ) ; end progn diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp index cafc55bdedeb52500c9e849feeb2dd1f8264f9ad..5ae082e6a164e2a32d5e918eea72c298f2689492 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.66 1997/12/17 19:24:39 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.67 1997/12/18 19:00:55 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -812,21 +812,18 @@ (t (list arg)))) (convert-member-type (type) - ;; Run down the list of members and convert to the - ;; appropriate numeric-type. + ;; Run down the list of members and convert to a list of + ;; member types. (mapcar #'(lambda (element) (if (numberp element) - (let ((type (type-of element))) - (specifier-type `(,(if (subtypep type 'integer) - 'integer - type) ,element ,element))) + (specifier-type `(member ,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. + ;; single-element member-type's. (let ((new-args (flatten-list (mapcar #'(lambda (x) (if (member-type-p x) (convert-member-type x) @@ -844,19 +841,32 @@ ;;; ;;; 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. +;;; "atomic" continuation type like numeric-type or member-type +;;; (containing just one element). 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 '())) +;;; For the case of member types, we call FCN on the element of the +;;; member type to get the resulting member type result. +;;; +(defun one-arg-derive-type (arg derive-fcn fcn) + (let ((arg-list (prepare-arg-for-derive-type (continuation-type arg)))) (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))))) + (flet + ((deriver (x) + (etypecase x + (member-type + (with-float-traps-masked (:underflow :overflow :divide-by-zero) + + (specifier-type + `(member ,(funcall fcn (first (member-type-members x))))))) + (numeric-type + (funcall derive-fcn x))))) + ;; Run down the list of args and derive the type of each one and + ;; save all of the results in a list. + (let ((result (flatten-list (mapcar #'deriver arg-list)))) + (if (rest result) + (make-union-type result) + (first result))))))) ;;; TWO-ARG-DERIVE-TYPE ;;; @@ -867,27 +877,53 @@ ;;; 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))))) +(defun two-arg-derive-type (arg1 arg2 derive-fcn fcn) + (labels + ((maybe-convert-member-type (arg) + (etypecase arg + (numeric-type arg) + (member-type + (let* ((val (first (member-type-members arg))) + (val-type (type-of val))) + (specifier-type `(,(if (subtypep val-type 'integer) + 'integer + val-type) + ,val ,val)))))) + (deriver (x y same-arg) + (let* ((member-result-p (and (member-type-p x) (member-type-p y))) + (x (maybe-convert-member-type x)) + (y (maybe-convert-member-type y)) + (result + (if member-result-p + (with-float-traps-masked + (:underflow :overflow :divide-by-zero) + (funcall fcn + (numeric-type-low x) + (numeric-type-low y))) + (funcall derive-fcn x y same-arg)))) + (if (and member-result-p result) + (specifier-type `(member ,result)) + result)))) + (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 (deriver x x same-arg) result)) + ;; Try all pairwise combinations and gather the result + (dolist (x a1) + (dolist (y a2) + (push (or (deriver x y same-arg) + (numeric-contagion x y)) + result)))) + (setf result (flatten-list result)) + (if (rest result) + (make-union-type result) + (first result)))))) ) ; end progn @@ -978,7 +1014,7 @@ (defoptimizer (+ derive-type) ((x y)) - (two-arg-derive-type x y #'+-derive-type-aux)) + (two-arg-derive-type x y #'+-derive-type-aux #'+)) (defun --derive-type-aux (x y same-arg) (if (and (numeric-type-real-p x) @@ -1011,7 +1047,7 @@ (numeric-contagion x y))) (defoptimizer (- derive-type) ((x y)) - (two-arg-derive-type x y #'--derive-type-aux)) + (two-arg-derive-type x y #'--derive-type-aux #'-)) (defun *-derive-type-aux (x y same-arg) (if (and (numeric-type-real-p x) @@ -1044,7 +1080,7 @@ (numeric-contagion x y))) (defoptimizer (* derive-type) ((x y)) - (two-arg-derive-type x y #'*-derive-type-aux)) + (two-arg-derive-type x y #'*-derive-type-aux #'*)) (defun /-derive-type-aux (x y same-arg) (if (and (numeric-type-real-p x) @@ -1076,7 +1112,7 @@ (defoptimizer (/ derive-type) ((x y)) - (two-arg-derive-type x y #'/-derive-type-aux)) + (two-arg-derive-type x y #'/-derive-type-aux #'/)) ) ;end progn @@ -1152,7 +1188,8 @@ (if hi (negate-bound hi) nil)) (setf (numeric-type-high result) (if lo (negate-bound lo) nil)) - result))))) + result)) + #'-))) #-propagate-float-type (defoptimizer (abs derive-type) ((num)) @@ -1196,7 +1233,7 @@ :high (interval-high abs-bnd)))))) #+propagate-float-type (defoptimizer (abs derive-type) ((num)) - (one-arg-derive-type num #'abs-derive-type-aux)) + (one-arg-derive-type num #'abs-derive-type-aux #'abs)) #-propagate-float-type (defoptimizer (truncate derive-type) ((number divisor)) @@ -1340,8 +1377,8 @@ (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)))) + (two-arg-derive-type number divisor #'truncate-derive-type-quot-aux #'truncate) + (two-arg-derive-type number divisor #'truncate-derive-type-rem-aux #'rem)))) (defun ftruncate-derive-type-quot (number-type divisor-type) ;; The bounds are the same as for truncate. However, the first @@ -1365,15 +1402,17 @@ (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)))) + (two-arg-derive-type number divisor #'ftruncate-derive-type-quot-aux #'ftruncate) + (two-arg-derive-type number divisor #'truncate-derive-type-rem-aux #'rem)))) (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)) + (one-arg-derive-type number + #'%unary-truncate-derive-type-aux + #'%unary-truncate)) ;;; Define optimizers for floor and ceiling (macrolet @@ -1435,8 +1474,8 @@ *empty-type*))) (make-values-type :required - (list (two-arg-derive-type number divisor #'derive-q) - (two-arg-derive-type number divisor #'derive-r))))) + (list (two-arg-derive-type number divisor #'derive-q #',name) + (two-arg-derive-type number divisor #'derive-r #'mod))))) )))) (frob-opt floor floor-quotient-bound floor-rem-bound) @@ -1478,8 +1517,8 @@ *empty-type*))) (make-values-type :required - (list (two-arg-derive-type number divisor #'derive-q) - (two-arg-derive-type number divisor #'derive-r))))))))) + (list (two-arg-derive-type number divisor #'derive-q #',name) + (two-arg-derive-type number divisor #'derive-r #'mod))))))))) (frob-opt ffloor floor-quotient-bound floor-rem-bound) (frob-opt fceiling ceiling-quotient-bound ceiling-rem-bound))