[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2013-02-11-g17e3081
Raymond Toy
rtoy at common-lisp.net
Fri Feb 22 05:46:33 UTC 2013
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CMU Common Lisp".
The branch, master has been updated
via 17e30810393e36b3530b47420cd66b06dfb47332 (commit)
from 0ecc7f4cbf55f877f2d2fa65c31f2e6665cc68ba (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 17e30810393e36b3530b47420cd66b06dfb47332
Author: Raymond Toy <toy.raymond at gmail.com>
Date: Thu Feb 21 21:43:50 2013 -0800
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.
diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index 3a663a8..639ac8a 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 at rtp.ericsson.se:
;;;
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 8f5c134..7888eba 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)))
-----------------------------------------------------------------------
Summary of changes:
src/compiler/float-tran.lisp | 2 +-
src/compiler/srctran.lisp | 122 ++++++++++++++++++------------------------
2 files changed, 54 insertions(+), 70 deletions(-)
hooks/post-receive
--
CMU Common Lisp
More information about the cmucl-cvs
mailing list