Skip to content
Snippets Groups Projects
Commit 773badcd authored by pw's avatar pw
Browse files

initial post 1.3.7 merge

parent 824b7e1e
No related branches found
No related tags found
No related merge requests found
......@@ -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.24 1997/01/18 14:31:35 ram Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.25 1997/02/05 15:41:50 pw Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -237,6 +237,8 @@
(frob scale-single-float)
(frob scale-double-float))
;;; toy@rtp.ericsson.se:
;;;
;;; Defoptimizers for %single-float and %double-float. This makes the
;;; FLOAT function return the correct ranges if the input has some
;;; defined range. Quite useful if we want to convert some time of
......@@ -450,11 +452,27 @@
(deftransform name ((x y) '(double-float double-float)
rtype :eval-name t :when :both)
`(,prim x y))))
#+nil
(deftransform log ((x y) (float float) float)
'(/ (log x) (log y)))
;;; ANSI says log with base zero returns zero.
(deftransform log ((x y) (float float) float)
'(if (zerop y) y (/ (log x) (log y))))
;;; Return the float format of the result of an elementary function.
;;; If the format is NIL (which means type FLOAT), we return NIL. If
;;; the format is 'DOUBLE-FLOAT, we return that. For any other case,
;;; we return 'SINGLE-FLOAT.
(proclaim '(inline elfun-format numeric-type-real-p))
(defun elfun-float-format (format)
(if format
(if (eq format 'double-float)
'double-float
'single-float)))
#+propagate-fun-type
(progn
;;;; Optimizers for elementary functions
......@@ -487,18 +505,6 @@
(float 0 x)))
;;; Return the float format of the result of an elementary function.
;;; If the format is NIL (which means type FLOAT), we return NIL. If
;;; the format is 'DOUBLE-FLOAT, we return that. For any other case,
;;; we return 'SINGLE-FLOAT.
(proclaim '(inline elfun-format numeric-type-real-p))
(defun elfun-float-format (format)
(if format
(if (eq format 'double-float)
'double-float
'single-float)))
;;; The number is of type REAL.
(defun numeric-type-real-p (type)
......@@ -520,20 +526,40 @@
(defmacro elfun-derive-type (num cond limit-fun)
(let ((type (gensym))
(lo-lim (gensym))
(hi-lim (gensym)))
(hi-lim (gensym))
(fp-mode (gensym)))
`(let ((,type (continuation-type ,num)))
(when (numeric-type-real-p ,type)
(let ((lo (numeric-type-low ,type))
(hi (numeric-type-high ,type)))
(when ,cond
(multiple-value-bind (,lo-lim ,hi-lim)
(funcall ,limit-fun lo hi)
(make-numeric-type :class 'float
:format (elfun-float-format
(numeric-type-format ,type))
:complexp :real
:low ,lo-lim
:high ,hi-lim))))))))
(let ((,fp-mode (get-floating-point-modes)))
(unwind-protect
(progn
;; Disable all traps except for :invalid. We
;; want standard IEEE handling to return the
;; appropriate value which we will handle later.
;; However, for :invalid, there's probably
;; nothing we can do about it. We don't need to
;; do anything else because we don't check any
;; other flags and they get restored later.
(set-floating-point-modes :traps '(:invalid))
;; The call to the limit-fun has (most) traps
;; disabled. It can naively compute the result,
;; but it must call set-bound to make sure any
;; overflow is converted to NIL appropriately.
(multiple-value-bind (,lo-lim ,hi-lim)
(funcall ,limit-fun lo hi)
(make-numeric-type :class 'float
:format (elfun-float-format
(numeric-type-format ,type))
:complexp :real
:low ,lo-lim
:high ,hi-lim)))
;; Restore the floating-point modes
(apply #'set-floating-point-modes ,fp-mode)
))))))))
;;; Handle these monotonic increasing functions whose domain is
;;; possibly part of the real line
......@@ -732,24 +758,38 @@
(multiple-value-bind (lo hi)
(extract-bounds type)
(let* ((max-bnd (max-bound (bound-abs lo) (bound-abs hi)))
(min-bnd (min-bound (bound-abs lo) (bound-abs hi))))
(make-numeric-type
:class 'float
:format (elfun-float-format (numeric-type-format type))
:complexp :real
:low (if (and (bound-< lo 0) (bound-< 0 hi))
;; If zero is in the input domain, then the lower
;; bound is cosh(0). Otherwise it's the min of
;; the bounds.
1
(if (symbolp min-bnd)
nil
(set-bound (cosh (bound-value min-bnd))
(consp min-bnd))))
:high (if (symbolp max-bnd)
nil
(set-bound (cosh (bound-value max-bnd))
(consp max-bnd)))))))))
(min-bnd (min-bound (bound-abs lo) (bound-abs hi)))
(fp-modes (get-floating-point-modes)))
(unwind-protect
(progn
;; Disable all traps except for :invalid. We want
;; standard IEEE handling to return the appropriate
;; value which we will handle later. However, for
;; :invalid, there's probably nothing we can do about
;; it. We don't need to do anything else because we
;; don't check any other flags and they get restored
;; later.
(set-floating-point-modes :traps '(:invalid))
(make-numeric-type
:class 'float
:format (elfun-float-format (numeric-type-format type))
:complexp :real
:low (if (and (bound-< lo 0) (bound-< 0 hi))
;; If zero is in the input domain, then the lower
;; bound is cosh(0). Otherwise it's the min of
;; the bounds.
1
(if (symbolp min-bnd)
nil
(set-bound (cosh (bound-value min-bnd))
(consp min-bnd))))
:high (if (symbolp max-bnd)
nil
(set-bound (cosh (bound-value max-bnd))
(consp max-bnd)))))
;; Restore the floating-point modes
(apply #'set-floating-point-modes fp-modes)))))))
(defoptimizer (phase derive-type) ((num))
(let ((type (continuation-type num)))
......
......@@ -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/main.lisp,v 1.108 1997/01/18 14:31:32 ram Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.109 1997/02/05 15:41:53 pw Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -235,12 +235,20 @@
(maybe-mumble "Constraint ")
(constraint-propagate component))
(maybe-mumble "Type ")
(generate-type-checks component)
(unless (or (component-reoptimize component)
(component-reanalyze component)
(component-new-functions component)
(component-reanalyze-functions component))
(return))
;; Delay the generation of type checks until the type
;; constraints have had time to propagate, else the compiler can
;; confuse itself.
(unless (and (or (component-reoptimize component)
(component-reanalyze component)
(component-new-functions component)
(component-reanalyze-functions component))
(< loop-count (- *reoptimize-after-type-check-max* 2)))
(generate-type-checks component)
(unless (or (component-reoptimize component)
(component-reanalyze component)
(component-new-functions component)
(component-reanalyze-functions component))
(return)))
(when (>= loop-count *reoptimize-after-type-check-max*)
(maybe-mumble "[Reoptimize Limit]")
(event reoptimize-maxed-out)
......@@ -1541,23 +1549,23 @@
;;; exist.
;;;
(defun verify-source-files (stuff)
(unless stuff
(error "Can't compile with no source files."))
(mapcar #'(lambda (x)
(let ((x (pathname x)))
(if (probe-file x)
x
(let ((y (merge-pathnames x (make-pathname :type "lisp"))))
(if (probe-file y)
y
(let ((z (merge-pathnames
x
(make-pathname :type "dylan"))))
(if (probe-file z)
z
(truename y))))))))
(if (listp stuff) stuff (list stuff))))
(flet ((try-with-type (path type error-p)
(let ((new (merge-pathnames path (make-pathname :type type
:defaults path))))
(if (probe-file new)
new
(and error-p (truename new))))))
(unless stuff
(error "Can't compile with no source files."))
(mapcar #'(lambda (x)
(let ((x (pathname x)))
(cond ((logical-pathname-p x)
(try-with-type x "LISP" t))
((probe-file x) x)
((try-with-type x "lisp" nil))
((try-with-type x "dylan" nil))
((try-with-type x "lisp" t)))))
(if (listp stuff) stuff (list stuff)))))
;;; COMPILE-FROM-STREAM -- Public
;;;
......@@ -1712,22 +1720,23 @@
(error-severity nil)
(source (verify-source-files source))
(source-info (make-file-source-info source))
(default (pathname (first source)))
(diddle-case (logical-pathname-p (pathname default))))
(default (pathname (first source))))
(unwind-protect
(progn
(flet ((frob (file type)
(if (eq file t)
(make-pathname :type (lisp::maybe-diddle-case type diddle-case)
:defaults default)
(make-pathname :type type
:defaults
(if (logical-pathname-p default)
(translate-logical-pathname default)
default))
(pathname file))))
(when output-file
(setq output-file-name
(frob output-file
(if (eq *byte-compile* t)
(backend-byte-fasl-file-type *backend*)
(backend-fasl-file-type *backend*))))
(compile-file-pathname (first source)
:output-file output-file
:byte-compile *byte-compile*))
(setq fasl-file (open-fasl-file output-file-name
(namestring (first source))
(eq *byte-compile* t))))
......@@ -1794,7 +1803,6 @@
nil)
(not (null error-severity))
(if (member error-severity '(:warning :error)) t nil))))
;;;; COMPILE and UNCOMPILE:
......
......@@ -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.46 1997/01/18 14:31:30 ram Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.47 1997/02/05 15:41:57 pw Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -396,9 +396,12 @@
b))
(defun set-bound (val exclusive)
(if exclusive
`(,val)
val))
(if (and (floatp val)
(float-infinity-p val))
nil
(if exclusive
`(,val)
val)))
(defun bound-< (x y)
(cond ((eq x 'pos-inf)
......@@ -775,7 +778,7 @@
nil))))))))
;; ;; bugged below?? #-propagate-float-type)
#-propagate-float-type
(defoptimizer (truncate derive-type) ((number divisor))
(let ((number-type (continuation-type number))
(divisor-type (continuation-type divisor))
......@@ -797,34 +800,56 @@
#+propagate-float-type
(progn
#+nil
(defoptimizer (truncate derive-type) ((number divisor))
(let ((number-type (continuation-type number))
(divisor-type (continuation-type divisor))
(integer-type (specifier-type '(or integer real))))
(real-type (specifier-type '(or integer real))))
(if (and (numeric-type-p number-type)
(csubtypep number-type integer-type)
(csubtypep number-type real-type)
(numeric-type-p divisor-type)
(csubtypep divisor-type integer-type))
(csubtypep divisor-type real-type))
(let ((number-low (numeric-type-low number-type))
(number-high (numeric-type-high number-type))
(divisor-low (numeric-type-low divisor-type))
(divisor-high (numeric-type-high divisor-type)))
(setf number-low (if (consp number-low) (car number-low) number-low))
(setf number-high (if (consp number-high) (car number-high) number-high))
(setf divisor-low (if (consp divisor-low) (car divisor-low) divisor-low))
(setf divisor-high (if (consp divisor-high) (car divisor-high) divisor-high))
(if (csubtypep number-type (specifier-type 'integer))
(setf number-low (if (consp number-low)
(car number-low)
number-low))
(setf number-high (if (consp number-high)
(car number-high)
number-high))
(setf divisor-low (if (consp divisor-low)
(car divisor-low)
divisor-low))
(setf divisor-high (if (consp divisor-high)
(car divisor-high)
divisor-high))
(if (and (csubtypep number-type (specifier-type 'integer))
(csubtypep divisor-type (specifier-type 'integer)))
;; If both the number and the divisor are integers of
;; some type, then both results of truncate are
;; integers. Figure out the appropriate ranges of the
;; results.
(values-specifier-type
`(values ,(integer-truncate-derive-type number-low number-high
divisor-low divisor-high)
,(integer-rem-derive-type number-low number-high
divisor-low divisor-high)))
`(values
,(integer-truncate-derive-type number-low number-high
divisor-low divisor-high
divisor-type)
,(integer-rem-derive-type number-low number-high
divisor-low divisor-high)))
;; Otherwise, the first result of truncate is an integer
;; and the second result is a float of some type.
;; Figure out the ranges of the results and their
;; appropriate types.
(values-specifier-type
`(values ,(integer-truncate-derive-type number-low number-high
divisor-low divisor-high)
,(real-rem-derive-type number-low number-high
divisor-low divisor-high)))))
`(values
,(integer-truncate-derive-type number-low number-high
divisor-low divisor-high
divisor-type)
,(real-rem-derive-type number-low number-high
divisor-low divisor-high
number-type
divisor-type)))))
*universal-type*)))
(defoptimizer (%unary-truncate derive-type) ((number))
......@@ -832,12 +857,19 @@
(if (and (numeric-type-p number-type)
(csubtypep number-type (specifier-type 'real)))
(let ((number-low (numeric-type-low number-type))
(number-high (numeric-type-high number-type)))
(setf number-low (if (consp number-low) (car number-low) number-low))
(setf number-high (if (consp number-high) (car number-high) number-high))
(values-specifier-type
`(values ,(integer-truncate-derive-type number-low number-high 1 1)
,(real-rem-derive-type number-low number-high 1 1))))
(number-high (numeric-type-high number-type))
(divisor (make-numeric-type
:class 'integer
:low 1
:high 1)))
(setf number-low (if (consp number-low)
(car number-low)
number-low))
(setf number-high (if (consp number-high)
(car number-high)
number-high))
(specifier-type `,(integer-truncate-derive-type
number-low number-high 1 1 divisor)))
*universal-type*)))
)
......@@ -924,7 +956,7 @@
;; The number we are dividing is unbounded, so we can't tell
;; anything about the result.
'integer)))))
(defun integer-rem-derive-type
(number-low number-high divisor-low divisor-high)
(if (and divisor-low divisor-high)
......@@ -957,101 +989,152 @@
#+propagate-float-type
(progn
(defun integer-truncate-derive-type
(number-low number-high divisor-low divisor-high)
(number-low number-high divisor-low divisor-high divisor-type)
;; The result cannot be larger in magnitude than the number, but the sign
;; might change. If we can determine the sign of either the number or
;; the divisor, we can eliminate some of the cases.
(multiple-value-bind
(number-sign number-min number-max)
(numeric-range-info number-low number-high)
(macrolet ((maybe* (form)
;; return result of form or * if overflow occurs
`(handler-case ,form
(arithmetic-error () '*))))
(multiple-value-bind
(divisor-sign divisor-min divisor-max)
(numeric-range-info divisor-low divisor-high)
(when (and divisor-max (zerop divisor-max))
;; 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.
(if (integerp divisor-min)
(incf divisor-min)
(incf divisor-min (if (typep divisor-min 'single-float)
least-positive-normalized-single-float
least-positive-normalized-double-float))))
(cond ((and number-sign divisor-sign)
;; We know the sign of both.
(if (eq number-sign divisor-sign)
;; Same sign, so the result will be positive.
`(integer ,(if divisor-max
(truncate number-min divisor-max)
0)
,(if number-max
(truncate number-max divisor-min)
'*))
;; Different signs, the result will be negative.
`(integer ,(if number-max
(- (truncate number-max divisor-min))
'*)
,(if divisor-max
(- (truncate number-min divisor-max))
0))))
((eq divisor-sign '+)
;; The divisor is positive. Therefore, the number will just
;; become closer to zero.
`(integer ,(if number-low
(truncate number-low divisor-min)
'*)
,(if number-high
(truncate number-high divisor-min)
'*)))
((eq divisor-sign '-)
;; The divisor is negative. Therefore, the absolute value of
;; the number will become closer to zero, but the sign will also
;; change.
`(integer ,(if number-high
(- (truncate number-high divisor-min))
'*)
,(if number-low
(- (truncate number-low divisor-min))
'*)))
;; The divisor could be either positive or negative.
(number-max
;; The number we are dividing has a bound. Divide that by the
;; smallest posible divisor.
(let ((bound (truncate number-max divisor-min)))
`(integer ,(- bound) ,bound)))
(t
;; The number we are dividing is unbounded, so we can't tell
;; anything about the result.
'integer)))))
(number-sign number-min number-max)
(numeric-range-info number-low number-high)
(multiple-value-bind
(divisor-sign divisor-min divisor-max)
(numeric-range-info divisor-low divisor-high)
(when (and divisor-max (zerop divisor-max))
;; 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 aren't going to divide by zero. Set
;; divisor min to be the smallest positive number of the
;; appropriate type. (Does this really make sense for floats?
;; Let's go with it for now.)
(setf divisor-min
(cond ((csubtypep divisor-type (specifier-type 'integer))
1)
((csubtypep divisor-type (specifier-type 'double-float))
least-positive-normalized-double-float)
((csubtypep divisor-type (specifier-type 'real))
least-positive-normalized-single-float)
(t
(cerror "Return INTEGER as result of truncate"
"This should not have happened!")
(return-from integer-truncate-derive-type t)))))
(cond ((and number-sign divisor-sign)
;; We know the sign of both.
(if (eq number-sign divisor-sign)
;; Same sign, so the result will be positive.
`(integer
,(if divisor-max
(maybe* (truncate number-min divisor-max))
0)
,(if number-max
(maybe* (truncate number-max divisor-min))
'*))
;; Different signs, the result will be negative.
`(integer
,(if number-max
(maybe* (- (truncate number-max divisor-min)))
'*)
,(if divisor-max
(maybe* (- (truncate number-min divisor-max)))
0))))
((eq divisor-sign '+)
;; The divisor is positive. Therefore, the number will just
;; become closer to zero.
`(integer
,(if number-low
(maybe* (truncate number-low divisor-min))
'*)
,(if number-high
(maybe* (truncate number-high divisor-min))
'*)))
((eq divisor-sign '-)
;; The divisor is negative. Therefore, the absolute value of
;; the number will become closer to zero, but the sign will also
;; change.
`(integer
,(if number-high
(maybe* (- (truncate number-high divisor-min)))
'*)
,(if number-low
(maybe* (- (truncate number-low divisor-min)))
'*)))
;; The divisor could be either positive or negative.
(number-max
;; The number we are dividing has a bound. Divide that by the
;; smallest posible divisor.
(let ((bound (maybe* (truncate number-max divisor-min))))
(if (numberp bound)
`(integer ,(- bound) ,bound)
`integer)))
(t
;; The number we are dividing is unbounded, so we can't tell
;; anything about the result.
'integer))))))
;;; This probably needs a lot of reworking to make sure everything is
;;; covered.
(defun real-rem-derive-type
(number-low number-high divisor-low divisor-high)
(if (and divisor-low divisor-high)
;; We know the range of the divisor, and the remainder must be smaller
;; than the divisor. We can tell the sign of the remainer if we know
;; the sign of the number.
(let ((divisor-max (float (max (abs divisor-low) (abs divisor-high)))))
`(float ,(if (or (null number-low)
(minusp number-low))
(- divisor-max)
0.0)
,(if (or (null number-high)
(plusp number-high))
divisor-max
0.0)))
;; The divisor is potentially either very positive or very negative.
;; Therefore, the remainer is unbounded, but we might be able to tell
;; something about the sign from the number.
`(float ,(if (and number-low (not (minusp number-low)))
;; The number we are dividing is positive. Therefore,
;; the remainder must be positive.
0.0
'*)
,(if (and number-high (not (plusp number-high)))
;; The number we are dividing is negative. Therefore,
;; the remainder must be negative.
0.0
'*))))
(number-low number-high divisor-low divisor-high number-type divisor-type)
;; First figure out what the type of the result should be.
(let* ((result-type
(cond ((csubtypep number-type (specifier-type 'integer))
;; If NUMBER is an integer, the result must be the
;; type of the divisor. A numeric-type-format of nil
;; means either REAL or COMPLEX, but we know at this
;; point the numbers are not complex.
(or (numeric-type-format divisor-type)
'real))
((csubtypep divisor-type (specifier-type 'integer))
;; The divisor is an integer, so the result must be
;; the type of the number.
(or (numeric-type-format number-type)
'real))
(t
;; Hmm, neither are integers, so we take the largest format
(or (float-format-max (numeric-type-format number-type)
(numeric-type-format divisor-type))
'real)))))
;; Without the following sexp, RESULT-TYPE can sometimes be NIL!
;; How can that be? The above code looks like it always returns
;; something besides nil!
(unless result-type
(setf result-type 'real)
(cerror "Use REAL as result type" "Shouldn't happen! Result type was NIL"))
(if (and divisor-low divisor-high)
;; We know the range of the divisor, and the remainder must be smaller
;; than the divisor. We can tell the sign of the remainer if we know
;; the sign of the number.
(let ((divisor-max (float (max (abs divisor-low) (abs divisor-high)))))
`(,result-type ,(coerce (if (or (null number-low)
(minusp number-low))
(- divisor-max)
0.0)
result-type)
,(coerce (if (or (null number-high)
(plusp number-high))
divisor-max
0.0)
result-type)))
;; The divisor is potentially either very positive or very negative.
;; Therefore, the remainer is unbounded, but we might be able to tell
;; something about the sign from the number.
`(,result-type ,(if (and number-low
(not (minusp number-low)))
;; The number we are dividing is positive.
;; Therefore, the remainder must be
;; positive.
(coerce 0.0 result-type)
'*)
,(if (and number-high (not (plusp number-high)))
;; The number we are dividing is negative.
;; Therefore, the remainder must be
;; negative.
(coerce 0.0 result-type)
'*)))))
)
(defoptimizer (random derive-type) ((bound &optional state))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment