From 17e30810393e36b3530b47420cd66b06dfb47332 Mon Sep 17 00:00:00 2001 From: Raymond Toy <toy.raymond@gmail.com> Date: Thu, 21 Feb 2013 21:43:50 -0800 Subject: [PATCH] Clean up one- and two-arg-derive-type. srctran.lisp:: * The optional convert-type arg is always true, so remove it and update the local functions to convert always. * Clean up some comments as well. float-tran.lisp:: * Fix up one place where we were supplying a value for the optional convert-type arg. --- src/compiler/float-tran.lisp | 2 +- src/compiler/srctran.lisp | 122 +++++++++++++++-------------------- 2 files changed, 54 insertions(+), 70 deletions(-) diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index 3a663a834..639ac8a4e 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -553,7 +553,7 @@ ;;; (defoptimizer (scale-float derive-type) ((f ex)) (two-arg-derive-type f ex #'scale-float-derive-type-aux - #'scale-float t)) + #'scale-float)) ;;; toy@rtp.ericsson.se: ;;; diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 8f5c134b4..7888eba74 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -1189,11 +1189,9 @@ ;;; compute the result otherwise the member type is first converted to a ;;; numeric type and the derive-fcn is call. ;;; -(defun one-arg-derive-type (arg derive-fcn member-fcn - &optional (convert-type t)) +(defun one-arg-derive-type (arg derive-fcn member-fcn) (declare (type function derive-fcn) - (type (or null function) member-fcn) - ) + (type (or null function) member-fcn)) (let ((arg-list (prepare-arg-for-derive-type (continuation-type arg)))) (when arg-list (flet ((deriver (x) @@ -1203,18 +1201,14 @@ (with-float-traps-masked (:underflow :overflow :divide-by-zero) (specifier-type `(eql ,(funcall member-fcn - (first (member-type-members x)))))) + (first (member-type-members x)))))) ;; Otherwise convert to a numeric type. (let ((result-type-list (funcall derive-fcn (convert-member-type x)))) - (if convert-type - (convert-back-numeric-type-list result-type-list) - result-type-list)))) + (convert-back-numeric-type-list result-type-list)))) (numeric-type - (if convert-type - (convert-back-numeric-type-list - (funcall derive-fcn (convert-numeric-type x))) - (funcall derive-fcn x))) + (convert-back-numeric-type-list + (funcall derive-fcn (convert-numeric-type x)))) (t *universal-type*)))) ;; Run down the list of args and derive the type of each one, saving @@ -1238,63 +1232,53 @@ ;;; (* x x), which should always be positive. If we didn't do this, we ;;; wouldn't be able to tell. ;;; -;;; Without the negative-zero-is-not-zero feature, numeric types are first -;;; converted to the negative-zero-is-not-zero conventions as expected by the -;;; deriver function. -;;; -;;; For the case of two member types, the result may be derived by calling the -;;; given function FCN but if a NaN is generated then an unbounded type is -;;; returned. Alternatively a tighter, less conservative, type can often be -;;; returned by converting to numeric types and calling the deriver function, -;;; which is the default behavior without the conservative-float-type feature. -;;; -(defun two-arg-derive-type (arg1 arg2 derive-fcn fcn - &optional (convert-type t)) - (labels ((maybe-convert-numeric-type (type) - (if convert-type (convert-numeric-type type) type)) - (maybe-convert-back-type-list (type) - (if convert-type (convert-back-numeric-type-list type) type)) - (deriver (x y same-arg) - (cond ((and (member-type-p x) (member-type-p y)) - (let* ((x (first (member-type-members x))) - (y (first (member-type-members y))) - (result (with-float-traps-masked - (:underflow :overflow :divide-by-zero - :invalid) - (funcall fcn x y)))) - (cond ((null result)) - ((and (floatp result) (float-nan-p result)) - (make-numeric-type :class 'float - :format (type-of result) - :complexp :real)) - (t - (specifier-type `(eql ,result)))))) - ((and (member-type-p x) (numeric-type-p y)) - (let* ((x (convert-member-type x)) - (y (maybe-convert-numeric-type y)) - (result (funcall derive-fcn x y same-arg))) - (maybe-convert-back-type-list result))) - ((and (numeric-type-p x) (member-type-p y)) - (let* ((x (maybe-convert-numeric-type x)) - (y (convert-member-type y)) - (result (funcall derive-fcn x y same-arg))) - (maybe-convert-back-type-list result))) - ((and (numeric-type-p x) (numeric-type-p y)) - (let* ((x (maybe-convert-numeric-type x)) - (y (maybe-convert-numeric-type y)) - (result (funcall derive-fcn x y same-arg))) - (maybe-convert-back-type-list result))) - (t - *universal-type*))) - (non-const-same-leaf-ref-p (x y) - ;; Just like same-leaf-ref-p, but we don't care if the - ;; value of the leaf is constant or not. - (declare (type continuation x y)) - (let ((x-use (continuation-use x)) - (y-use (continuation-use y))) - (and (ref-p x-use) - (ref-p y-use) - (eq (ref-leaf x-use) (ref-leaf y-use)))))) +;;; Numeric types are first converted to the negative-zero-is-not-zero +;;; conventions as expected by the deriver function. See +;;; CONVERT-NUMERIC-TYPE for the negative-zero-is-not-zero convention. +;;; +(defun two-arg-derive-type (arg1 arg2 derive-fcn fcn) + (flet + ((deriver (x y same-arg) + (cond ((and (member-type-p x) (member-type-p y)) + (let* ((x (first (member-type-members x))) + (y (first (member-type-members y))) + (result (with-float-traps-masked + (:underflow :overflow :divide-by-zero + :invalid) + (funcall fcn x y)))) + (cond ((null result)) + ((and (floatp result) (float-nan-p result)) + (make-numeric-type :class 'float + :format (type-of result) + :complexp :real)) + (t + (specifier-type `(eql ,result)))))) + ((and (member-type-p x) (numeric-type-p y)) + (let* ((x (convert-member-type x)) + (y (convert-numeric-type y)) + (result (funcall derive-fcn x y same-arg))) + (convert-back-numeric-type-list result))) + ((and (numeric-type-p x) (member-type-p y)) + (let* ((x (convert-numeric-type x)) + (y (convert-member-type y)) + (result (funcall derive-fcn x y same-arg))) + (convert-back-numeric-type-list result))) + ((and (numeric-type-p x) (numeric-type-p y)) + (let* ((x (convert-numeric-type x)) + (y (convert-numeric-type y)) + (result (funcall derive-fcn x y same-arg))) + (convert-back-numeric-type-list result))) + (t + *universal-type*))) + (non-const-same-leaf-ref-p (x y) + ;; Just like same-leaf-ref-p, but we don't care if the + ;; value of the leaf is constant or not. + (declare (type continuation x y)) + (let ((x-use (continuation-use x)) + (y-use (continuation-use y))) + (and (ref-p x-use) + (ref-p y-use) + (eq (ref-leaf x-use) (ref-leaf y-use)))))) (let ((same-arg (non-const-same-leaf-ref-p arg1 arg2)) (a1 (prepare-arg-for-derive-type (continuation-type arg1))) -- GitLab