restored floating point infinity support..
..Grep for SB-INFINITIES matches in SBCL and fix them.
..Remove DEFMACRO INFINITE and its calls.
..added a few floating point infinity test cases
(during macroexpansion of IN-PACKAGE,
during macroexpansion of DEFFOO)
-13:
- Floating point infinities are screwed up. [When I was converting CMU CL
- to SBCL, I was looking for complexity to delete, and I thought it was safe
- to just delete support for floating point infinities. It wasn't: they're
- generated by the floating point hardware even when we remove support
- for them in software. Also we claim the :IEEE-FLOATING-POINT feature,
- and I think that means we should support infinities.-- WHN] Support
- for them should be restored.
-
14:
The ANSI syntax for non-STANDARD method combination types in CLOS is
(DEFGENERIC FOO (X) (:METHOD-COMBINATION PROGN))
* many patches ported from CMU CL by Martin Atzmueller, with
half a dozen bug fixes in pretty-printing and the debugger, and
half a dozen others elsewhere
-* improved support for intersection types, fixing bug 12 (E.g., now
- (SUBTYPEP 'KEYWORD 'SYMBOL)=>T,T.)
+* improved support for type intersection and union, fixing bug 12
+ (e.g., now (SUBTYPEP 'KEYWORD 'SYMBOL)=>T,T) and some other
+ smaller bugs as well
?? The :PROPAGATE-FLOAT-TYPE and :PROPAGATE-FUN-TYPE features
are now supported, and enabled by default. Thus, the compiler can
handle many floating point and complex operations much less
; :mp
; :mp-i486
- ;; KLUDGE: used to suppress stale code related to floating point infinities.
- ;; I intend to delete this code completely some day, since it was a pain
- ;; for me to try to work with and since all benefits it provides are
- ;; non-portable. Until I actually pull the trigger, though, I've left
- ;; various stale code in place protected with #!-SB-INFINITIES.
- ; :sb-infinities
-
;; This affects the definition of a lot of things in bignum.lisp. It
;; doesn't seem to be documented anywhere what systems it might apply to.
;; It doesn't seem to be needed for X86 systems anyway.
;; weak pointers and finalization
"FINALIZE" "CANCEL-FINALIZATION"
- ;; FIXME: "WEAK-POINTER-P" here once it moves from %KERNEL
+ ;; FIXME: "WEAK-POINTER-P" here once it moves from SB!KERNEL
"HASH-TABLE-WEAK-P" "MAKE-WEAK-POINTER"
"WEAK-POINTER" "WEAK-POINTER-VALUE"
"FLOAT-NAN-P" "FLOAT-TRAPPING-NAN-P"
"FLOATING-POINT-INVALID"
"FLOAT-INFINITY-P"
- #!+sb-infinities "SHORT-FLOAT-NEGATIVE-INFINITY"
- #!+sb-infinities "SHORT-FLOAT-POSITIVE-INFINITY"
- #!+sb-infinities "SINGLE-FLOAT-NEGATIVE-INFINITY"
- #!+sb-infinities "SINGLE-FLOAT-POSITIVE-INFINITY"
- #!+sb-infinities "DOUBLE-FLOAT-NEGATIVE-INFINITY"
- #!+sb-infinities "DOUBLE-FLOAT-POSITIVE-INFINITY"
- #!+sb-infinities "LONG-FLOAT-NEGATIVE-INFINITY"
- #!+sb-infinities "LONG-FLOAT-POSITIVE-INFINITY"
+ "SHORT-FLOAT-NEGATIVE-INFINITY"
+ "SHORT-FLOAT-POSITIVE-INFINITY"
+ "SINGLE-FLOAT-NEGATIVE-INFINITY"
+ "SINGLE-FLOAT-POSITIVE-INFINITY"
+ "DOUBLE-FLOAT-NEGATIVE-INFINITY"
+ "DOUBLE-FLOAT-POSITIVE-INFINITY"
+ "LONG-FLOAT-NEGATIVE-INFINITY"
+ "LONG-FLOAT-POSITIVE-INFINITY"
;; hacks to work around system limitations
"*INTEXP-MAXIMUM-EXPONENT*" ; since we crash hard when
;; misc. utilities used internally
"LEGAL-FUNCTION-NAME-P"
"FUNCTION-NAME-BLOCK-NAME"
- #!-sb-infinities "INFINITE"
"LISTEN-SKIP-WHITESPACE"
"PACKAGE-INTERNAL-SYMBOL-COUNT" "PACKAGE-EXTERNAL-SYMBOL-COUNT"
"PROPER-LIST-OF-LENGTH-P"
;;; portable implementations of SINGLE-FLOAT-BITS,
;;; DOUBLE-FLOAT-LOW-BITS, and DOUBLE-FLOAT-HIGH-BITS
;;;
-;;; KLUDGE: These will fail if the target's floating point isn't IEEE, and so
-;;; I'd be more comfortable if there were an assertion "target's floating point
-;;; is IEEE" in the code, but I can't see how to express that.
+;;; KLUDGE: These will fail if the target's floating point isn't IEEE,
+;;; and so I'd be more comfortable if there were an assertion
+;;; "target's floating point is IEEE" in the code, but I can't see how
+;;; to express that.
;;;
-;;; KLUDGE: It's sort of weird that these functions return signed 32-bit values
-;;; instead of unsigned 32-bit values. This is the way that the CMU CL
-;;; machine-dependent functions behaved, and I've copied that behavior, but it
-;;; seems to me that it'd be more idiomatic to return unsigned 32-bit values.
-;;; Maybe someday the machine-dependent functions could be tweaked to return
-;;; unsigned 32-bit values?
+;;; KLUDGE: It's sort of weird that these functions return signed
+;;; 32-bit values instead of unsigned 32-bit values. This is the way
+;;; that the CMU CL machine-dependent functions behaved, and I've
+;;; copied that behavior, but it seems to me that it'd be more
+;;; idiomatic to return unsigned 32-bit values. Maybe someday the
+;;; machine-dependent functions could be tweaked to return unsigned
+;;; 32-bit values?
(defun single-float-bits (x)
(declare (type single-float x))
(assert (= (float-radix x) 2))
(or (cdr (assoc x *float-trap-alist*))
(error "unknown float trap kind: ~S" x)))
names)))
-); Eval-When (Compile Load Eval)
+) ; EVAL-WHEN
;;; interpreter stubs
(defun floating-point-modes () (floating-point-modes))
(defun (setf floating-point-modes) (new) (setf (floating-point-modes) new))
+;;; This function sets options controlling the floating-point
+;;; hardware. If a keyword is not supplied, then the current value is
+;;; preserved. Possible keywords:
+;;; :TRAPS
+;;; A list of the exception conditions that should cause traps.
+;;; Possible exceptions are :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID,
+;;; :DIVIDE-BY-ZERO, and on the X86 :DENORMALIZED-OPERAND. Initially
+;;; all traps except :INEXACT are enabled.
+;;;
+;;;:ROUNDING-MODE
+;;; The rounding mode to use when the result is not exact. Possible
+;;; values are :NEAREST, :POSITIVE-INFINITY, :NEGATIVE-INFINITY and
+;;; :ZERO. Initially, the rounding mode is :NEAREST.
+;;;
+;;;:CURRENT-EXCEPTIONS
+;;;:ACCRUED-EXCEPTIONS
+;;; These arguments allow setting of the exception flags. The main
+;;; use is setting the accrued exceptions to NIL to clear them.
+;;;
+;;;:FAST-MODE
+;;; Set the hardware's \"fast mode\" flag, if any. When set, IEEE
+;;; conformance or debuggability may be impaired. Some machines may not
+;;; have this feature, in which case the value is always NIL.
+;;;
+;;; GET-FLOATING-POINT-MODES may be used to find the floating point modes
+;;; currently in effect.
(defun set-floating-point-modes (&key (traps nil traps-p)
(rounding-mode nil round-p)
(current-exceptions nil current-x-p)
(accrued-exceptions nil accrued-x-p)
(fast-mode nil fast-mode-p))
- #!+sb-doc
- "This function sets options controlling the floating-point hardware. If a
- keyword is not supplied, then the current value is preserved. Possible
- keywords:
-
- :TRAPS
- A list of the exception conditions that should cause traps. Possible
- exceptions are :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID,
- :DIVIDE-BY-ZERO, and on the X86 :DENORMALIZED-OPERAND. Initially
- all traps except :INEXACT are enabled.
-
- :ROUNDING-MODE
- The rounding mode to use when the result is not exact. Possible values
- are :NEAREST, :POSITIVE-INFINITY, :NEGATIVE-INFINITY and :ZERO.
- Initially, the rounding mode is :NEAREST.
-
- :CURRENT-EXCEPTIONS
- :ACCRUED-EXCEPTIONS
- These arguments allow setting of the exception flags. The main use is
- setting the accrued exceptions to NIL to clear them.
-
- :FAST-MODE
- Set the hardware's \"fast mode\" flag, if any. When set, IEEE
- conformance or debuggability may be impaired. Some machines may not
- have this feature, in which case the value is always NIL.
-
- GET-FLOATING-POINT-MODES may be used to find the floating point modes
- currently in effect."
(let ((modes (floating-point-modes)))
(when traps-p
(setf (ldb float-traps-byte modes) (float-trap-mask traps)))
(values))
+;;; This function returns a list representing the state of the floating
+;;; point modes. The list is in the same format as the &KEY arguments to
+;;; SET-FLOATING-POINT-MODES, i.e.
+;;; (apply #'set-floating-point-modes (get-floating-point-modes))
+;;; sets the floating point modes to their current values (and thus is a
+;;; no-op).
(defun get-floating-point-modes ()
- #!+sb-doc
- "This function returns a list representing the state of the floating
- point modes. The list is in the same format as the &KEY arguments to
- SET-FLOATING-POINT-MODES, i.e.
- (apply #'set-floating-point-modes (get-floating-point-modes))
-
- sets the floating point modes to their current values (and thus is a no-op)."
(flet ((exc-keys (bits)
(macrolet ((frob ()
`(collect ((res))
:accrued-exceptions ,(exc-keys (ldb float-sticky-bits modes))
:fast-mode ,(logtest float-fast-bit modes)))))
+;;; Return true if any of the named traps are currently trapped, false
+;;; otherwise.
(defmacro current-float-trap (&rest traps)
- #!+sb-doc
- "Current-Float-Trap Trap-Name*
- Return true if any of the named traps are currently trapped, false
- otherwise."
`(not (zerop (logand ,(dpb (float-trap-mask traps) float-traps-byte 0)
(floating-point-modes)))))
|#
)
+;;; Execute BODY with the floating point exceptions listed in TRAPS
+;;; masked (disabled). TRAPS should be a list of possible exceptions
+;;; which includes :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and
+;;; :DIVIDE-BY-ZERO and on the X86 :DENORMALIZED-OPERAND. The
+;;; respective accrued exceptions are cleared at the start of the body
+;;; to support their testing within, and restored on exit.
(defmacro with-float-traps-masked (traps &body body)
- #!+sb-doc
- "Execute BODY with the floating point exceptions listed in TRAPS
- masked (disabled). TRAPS should be a list of possible exceptions
- which includes :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and
- :DIVIDE-BY-ZERO and on the X86 :DENORMALIZED-OPERAND. The respective
- accrued exceptions are cleared at the start of the body to support
- their testing within, and restored on exit."
(let ((traps (dpb (float-trap-mask traps) float-traps-byte 0))
(exceptions (dpb (float-trap-mask traps) float-sticky-bits 0))
(trap-mask (dpb (lognot (float-trap-mask traps))
(long-from-bits 1 sb!vm:long-float-normal-exponent-max
(ldb (byte sb!vm:long-float-digits 0) -1)))
-#!+sb-infinities
+;;; We don't want to do these DEFCONSTANTs at cross-compilation time,
+;;; because the cross-compilation host might not support floating
+;;; point infinities.
+(eval-when (:load-toplevel :execute)
(defconstant single-float-positive-infinity
(single-from-bits 0 (1+ sb!vm:single-float-normal-exponent-max) 0))
-#!+sb-infinities
(defconstant short-float-positive-infinity single-float-positive-infinity)
-#!+sb-infinities
(defconstant single-float-negative-infinity
(single-from-bits 1 (1+ sb!vm:single-float-normal-exponent-max) 0))
-#!+sb-infinities
(defconstant short-float-negative-infinity single-float-negative-infinity)
-#!+sb-infinities
(defconstant double-float-positive-infinity
(double-from-bits 0 (1+ sb!vm:double-float-normal-exponent-max) 0))
-#!+(and sb-infinities (not long-float))
+#!+(not long-float)
(defconstant long-float-positive-infinity double-float-positive-infinity)
-#!+(and sb-infinities long-float x86)
+#!+(and long-float x86)
(defconstant long-float-positive-infinity
(long-from-bits 0 (1+ sb!vm:long-float-normal-exponent-max)
(ash sb!vm:long-float-hidden-bit 32)))
-#!+sb-infinities
(defconstant double-float-negative-infinity
(double-from-bits 1 (1+ sb!vm:double-float-normal-exponent-max) 0))
-#!+(and sb-infinities (not long-float))
+#!+(not long-float)
(defconstant long-float-negative-infinity double-float-negative-infinity)
-#!+(and sb-infinities long-float x86)
+#!+(and long-float x86)
(defconstant long-float-negative-infinity
(long-from-bits 1 (1+ sb!vm:long-float-normal-exponent-max)
(ash sb!vm:long-float-hidden-bit 32)))
+) ; EVAL-WHEN
(defconstant single-float-epsilon
(single-from-bits 0 (- sb!vm:single-float-bias
(single-float (single-from-bits sign new-exp sig))
(double-float (double-from-bits sign new-exp sig))))))))
-;;; Called when scaling a float overflows, or the original float was a NaN
-;;; or infinity. If overflow errors are trapped, then error, otherwise return
-;;; the appropriate infinity. If a NaN, signal or not as appropriate.
+;;; Called when scaling a float overflows, or the original float was a
+;;; NaN or infinity. If overflow errors are trapped, then error,
+;;; otherwise return the appropriate infinity. If a NaN, signal or not
+;;; as appropriate.
(defun scale-float-maybe-overflow (x exp)
(cond
((float-infinity-p x)
(when (sb!vm:current-float-trap :inexact)
(error 'floating-point-inexact :operation 'scale-float
:operands (list x exp)))
- (infinite (* (float-sign x)
- (etypecase x
- (single-float single-float-positive-infinity)
- (double-float double-float-positive-infinity)))))))
+ (* (float-sign x)
+ (etypecase x
+ (single-float single-float-positive-infinity)
+ (double-float double-float-positive-infinity))))))
;;; Scale a single or double float, calling the correct over/underflow
;;; functions.
;;; Please refer to the Unix man pages for details about these routines.
-;;; Trigonometric.
+;;; trigonometric
#!-x86 (def-math-rtn "sin" 1)
#!-x86 (def-math-rtn "cos" 1)
#!-x86 (def-math-rtn "tan" 1)
(def-math-rtn "acosh" 1)
(def-math-rtn "atanh" 1)
-;;; Exponential and Logarithmic.
+;;; exponential and logarithmic
#!-x86 (def-math-rtn "exp" 1)
#!-x86 (def-math-rtn "log" 1)
#!-x86 (def-math-rtn "log10" 1)
;;; INTEXP -- Handle the rational base, integer power case.
-;;; FIXME: As long as the
-;;; system dies on stack overflow or memory exhaustion, it seems reasonable
-;;; to have this, but its default should be NIL, and when it's NIL,
-;;; anything should be accepted.
+;;; FIXME: As long as the system dies on stack overflow or memory
+;;; exhaustion, it seems reasonable to have this, but its default
+;;; should be NIL, and when it's NIL, anything should be accepted.
(defparameter *intexp-maximum-exponent* 10000)
-;;; This function precisely calculates base raised to an integral power. It
-;;; separates the cases by the sign of power, for efficiency reasons, as powers
-;;; can be calculated more efficiently if power is a positive integer. Values
-;;; of power are calculated as positive integers, and inverted if negative.
+;;; This function precisely calculates base raised to an integral
+;;; power. It separates the cases by the sign of power, for efficiency
+;;; reasons, as powers can be calculated more efficiently if power is
+;;; a positive integer. Values of power are calculated as positive
+;;; integers, and inverted if negative.
(defun intexp (base power)
(when (> (abs power) *intexp-maximum-exponent*)
;; FIXME: should be ordinary error, not CERROR. (Once we set the
(setq power nextn)))))
;;; If an integer power of a rational, use INTEXP above. Otherwise, do
-;;; floating point stuff. If both args are real, we try %POW right off,
-;;; assuming it will return 0 if the result may be complex. If so, we call
-;;; COMPLEX-POW which directly computes the complex result. We also separate
-;;; the complex-real and real-complex cases from the general complex case.
+;;; floating point stuff. If both args are real, we try %POW right
+;;; off, assuming it will return 0 if the result may be complex. If
+;;; so, we call COMPLEX-POW which directly computes the complex
+;;; result. We also separate the complex-real and real-complex cases
+;;; from the general complex case.
(defun expt (base power)
#!+sb-doc
"Returns BASE raised to the POWER."
(let ((pow (sb!kernel::%pow abs-x y)))
(declare (double-float pow))
(case yisint
- (1 ; Odd
+ (1 ; odd
(coerce (* -1d0 pow) rtype))
- (2 ; Even
+ (2 ; even
(coerce pow rtype))
- (t ; Non-integer
+ (t ; non-integer
(let ((y*pi (* y pi)))
(declare (double-float y*pi))
(complex
- (coerce (* pow (%cos y*pi)) rtype)
- (coerce (* pow (%sin y*pi)) rtype)))))))))))))
+ (coerce (* pow (%cos y*pi))
+ rtype)
+ (coerce (* pow (%sin y*pi))
+ rtype)))))))))))))
(declare (inline real-expt))
(number-dispatch ((base number) (power number))
(((foreach fixnum (or bignum ratio) (complex rational)) integer)
(defun phase (number)
#!+sb-doc
- "Returns the angle part of the polar representation of a complex number.
+ "Return the angle part of the polar representation of a complex number.
For complex numbers, this is (atan (imagpart number) (realpart number)).
For non-complex positive numbers, this is 0. For non-complex negative
numbers this is PI."
(error "unknown operator in feature expression: ~S." x)))
(not (null (memq x *features*)))))
-;;; KLUDGE: This is a wrapper around stale code for working with floating point
-;;; infinities. I believe that I will eventually eliminate floating point
-;;; infinities from the code, since they're a pain to cross-compile, since they
-;;; significantly increase the number of conditions which need to be tested in
-;;; numeric functions, and since the benefits which they provide (which are
-;;; admittedly significant) are unfortunately not portable. I haven't actually
-;;; done the dirty deed yet, though, and until then, I've wrapped various
-;;; infinity-returning forms in this macro. -- WHN 1999
-(defmacro infinite (x)
- (declare (ignorable x))
- #!-sb-infinities '(error 'floating-point-overflow)
- #!+sb-infinities x)
-
;;; Given a list of keyword substitutions `(,OLD ,NEW), and a
;;; &KEY-argument-list-style list of alternating keywords and
;;; arbitrary values, return a new &KEY-argument-list-style list with
infinity-data)
(defvar *loop-minimax-type-infinities-alist*
- ;; Note: In the portable loop.lisp, this had various
- ;; conditional-on-*FEATURES* cases to support machines which had true
- ;; floating infinity. Now that we're limited to CMU CL, this is irrelevant.
- ;; FIXME: Or is it? What if we ever support infinity? Perhaps we should
- ;; put in something conditional on SB-INFINITY or something?
+ ;; FIXME: Now that SBCL supports floating point infinities again, we
+ ;; should have floating point infinities here, as cmucl-2.4.8 did.
'((fixnum most-positive-fixnum most-negative-fixnum)))
(defun make-loop-minimax (answer-variable type)
(long-float #\L))
plusp exp))))
-;;; Write out an infinity using #. notation, or flame out if
-;;; *print-readably* is true and *read-eval* is false.
-#!+sb-infinities
+;;; Write out an infinity using #. notation, or flame out if
+;;; *PRINT-READABLY* is true and *READ-EVAL* is false.
(defun output-float-infinity (x stream)
(declare (type float x) (type stream stream))
(cond (*read-eval*
\f
;;;; number dumping
-;;; Dump a ratio
-
+;;; Dump a ratio.
(defun dump-ratio (x file)
(sub-dump-object (numerator x) file)
(sub-dump-object (denominator x) file)
(dump-fop 'sb!impl::fop-ratio file))
;;; Dump an integer.
-
(defun dump-integer (n file)
(typecase n
((signed-byte 8)
(two-arg-derive-type f ex #'scale-float-derive-type-aux
#'scale-double-float t))
-;;; toy@rtp.ericsson.se:
-;;;
-;;; Defoptimizers for %single-float and %double-float. This makes the
+;;; 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 type of
;;; bounded integer into a float.
;;; float (such as 0).
(macrolet ((frob (op)
`(deftransform ,op ((x y) (float rational) * :when :both)
+ "open-code FLOAT to RATIONAL comparison"
(unless (constant-continuation-p y)
(give-up-ir1-transform
- "can't open-code float to rational comparison"))
+ "The RATIONAL value isn't known at compile time."))
(let ((val (continuation-value y)))
(unless (eql (rational (float val)) val)
(give-up-ir1-transform
(destructuring-bind (name type) stuff
(let ((type (specifier-type type)))
(setf (function-info-derive-type (function-info-or-lose name))
- #'(lambda (call)
- (declare (type combination call))
- (when (csubtypep (continuation-type
- (first (combination-args call)))
- type)
- (specifier-type 'float)))))))
+ (lambda (call)
+ (declare (type combination call))
+ (when (csubtypep (continuation-type
+ (first (combination-args call)))
+ type)
+ (specifier-type 'float)))))))
#!-propagate-fun-type
(defoptimizer (log derive-type) ((x &optional y))
(movable foldable flushable))
(defknown (%sin %cos %tanh %sin-quick %cos-quick)
- (double-float) (double-float -1.0d0 1.0d0)
- (movable foldable flushable))
+ (double-float) (double-float -1.0d0 1.0d0)
+ (movable foldable flushable))
(defknown (%asin %atan)
- (double-float) (double-float #.(- (/ pi 2)) #.(/ pi 2))
- (movable foldable flushable))
+ (double-float) (double-float #.(- (/ pi 2)) #.(/ pi 2))
+ (movable foldable flushable))
(defknown (%acos)
- (double-float) (double-float 0.0d0 #.pi)
- (movable foldable flushable))
+ (double-float) (double-float 0.0d0 #.pi)
+ (movable foldable flushable))
(defknown (%cosh)
- (double-float) (double-float 1.0d0)
- (movable foldable flushable))
+ (double-float) (double-float 1.0d0)
+ (movable foldable flushable))
(defknown (%acosh %exp %sqrt)
- (double-float) (double-float 0.0d0)
- (movable foldable flushable))
+ (double-float) (double-float 0.0d0)
+ (movable foldable flushable))
(defknown %expm1
- (double-float) (double-float -1d0)
- (movable foldable flushable))
+ (double-float) (double-float -1d0)
+ (movable foldable flushable))
(defknown (%hypot)
- (double-float double-float) (double-float 0d0)
+ (double-float double-float) (double-float 0d0)
(movable foldable flushable))
(defknown (%pow)
- (double-float double-float) double-float
+ (double-float double-float) double-float
(movable foldable flushable))
(defknown (%atan2)
- (double-float double-float) (double-float #.(- pi) #.pi)
+ (double-float double-float) (double-float #.(- pi) #.pi)
(movable foldable flushable))
(defknown (%scalb)
- (double-float double-float) double-float
+ (double-float double-float) double-float
(movable foldable flushable))
(defknown (%scalbn)
- (double-float (signed-byte 32)) double-float
- (movable foldable flushable))
+ (double-float (signed-byte 32)) double-float
+ (movable foldable flushable))
(defknown (%log1p)
- (double-float) double-float
- (movable foldable flushable))
+ (double-float) double-float
+ (movable foldable flushable))
(dolist (stuff '((exp %exp *)
(log %log float)
;; But a positive real to any power is well-defined.
(merged-interval-expt x y))
(t
- ;; A real to some power. The result could be a real
+ ;; a real to some power. The result could be a real
;; or a complex.
(float-or-complex-float-type (numeric-contagion x y)))))))
(frob single-float)
(frob double-float))
-;;; Here are simple optimizers for sin, cos, and tan. They do not
+;;; Here are simple optimizers for SIN, COS, and TAN. They do not
;;; produce a minimal range for the result; the result is the widest
;;; possible answer. This gets around the problem of doing range
;;; reduction correctly but still provides useful results when the
;;; inputs are union types.
-
#!+propagate-fun-type
(progn
(defun trig-derive-type-aux (arg domain fcn
(defoptimizer (sin derive-type) ((num))
(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))
+ (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
- #'(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))
+ (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
- #'(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))
+ (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.
+;;;
+;;; FIXME: ANSI allows any subtype of REAL for the components of COMPLEX.
+;;; So what if the input type is (COMPLEX (SINGLE-FLOAT 0 1))?
(defoptimizer (conjugate derive-type) ((num))
(continuation-type num))
;;; -- With a combination, we call Propagate-Function-Change whenever
;;; the function changes, and call IR1-Optimize-Combination if any
;;; argument changes.
-;;; -- With an Exit, we derive the node's type from the Value's type. We don't
-;;; propagate Cont's assertion to the Value, since if we did, this would
-;;; move the checking of Cont's assertion to the exit. This wouldn't work
-;;; with Catch and UWP, where the Exit node is just a placeholder for the
-;;; actual unknown exit.
+;;; -- With an Exit, we derive the node's type from the Value's type.
+;;; We don't propagate Cont's assertion to the Value, since if we
+;;; did, this would move the checking of Cont's assertion to the
+;;; exit. This wouldn't work with Catch and UWP, where the Exit
+;;; node is just a placeholder for the actual unknown exit.
;;;
-;;; Note that we clear the node & block reoptimize flags *before* doing the
-;;; optimization. This ensures that the node or block will be reoptimized if
-;;; necessary. We leave the NODE-OPTIMIZE flag set going into
-;;; IR1-OPTIMIZE-RETURN, since IR1-OPTIMIZE-RETURN wants to clear the flag
-;;; itself.
+;;; Note that we clear the node & block reoptimize flags *before*
+;;; doing the optimization. This ensures that the node or block will
+;;; be reoptimized if necessary. We leave the NODE-OPTIMIZE flag set
+;;; going into IR1-OPTIMIZE-RETURN, since IR1-OPTIMIZE-RETURN wants to
+;;; clear the flag itself.
(defun ir1-optimize-block (block)
(declare (type cblock block))
(setf (block-reoptimize block) nil)
;;; We cannot combine with a successor block if:
;;; 1. The successor has more than one predecessor.
-;;; 2. The last node's Cont is also used somewhere else.
+;;; 2. The last node's CONT is also used somewhere else.
;;; 3. The successor is the current block (infinite loop).
-;;; 4. The next block has a different cleanup, and thus we may want to insert
-;;; cleanup code between the two blocks at some point.
+;;; 4. The next block has a different cleanup, and thus we may want to
+;;; insert cleanup code between the two blocks at some point.
;;; 5. The next block has a different home lambda, and thus the control
;;; transfer is a non-local exit.
;;;
;;; If we succeed, we return true, otherwise false.
;;;
-;;; Joining is easy when the successor's Start continuation is the same from
-;;; our Last's Cont. If they differ, then we can still join when the last
-;;; continuation has no next and the next continuation has no uses. In this
-;;; case, we replace the next continuation with the last before joining the
-;;; blocks.
+;;; Joining is easy when the successor's Start continuation is the
+;;; same from our Last's Cont. If they differ, then we can still join
+;;; when the last continuation has no next and the next continuation
+;;; has no uses. In this case, we replace the next continuation with
+;;; the last before joining the blocks.
(defun join-successor-if-possible (block)
(declare (type cblock block))
(let ((next (first (block-succ block))))
((and (null (block-start-uses next))
(eq (continuation-kind last-cont) :inside-block))
(let ((next-node (continuation-next next-cont)))
- ;; If next-cont does have a dest, it must be unreachable,
- ;; since there are no uses. DELETE-CONTINUATION will mark the
- ;; dest block as delete-p [and also this block, unless it is
- ;; no longer backward reachable from the dest block.]
+ ;; If next-cont does have a dest, it must be
+ ;; unreachable, since there are no uses.
+ ;; DELETE-CONTINUATION will mark the dest block as
+ ;; delete-p [and also this block, unless it is no
+ ;; longer backward reachable from the dest block.]
(delete-continuation next-cont)
(setf (node-prev next-node) last-cont)
(setf (continuation-next last-cont) next-node)
nil))))))
;;; Join together two blocks which have the same ending/starting
-;;; continuation. The code in Block2 is moved into Block1 and Block2 is
-;;; deleted from the DFO. We combine the optimize flags for the two blocks so
-;;; that any indicated optimization gets done.
+;;; continuation. The code in Block2 is moved into Block1 and Block2
+;;; is deleted from the DFO. We combine the optimize flags for the two
+;;; blocks so that any indicated optimization gets done.
(defun join-blocks (block1 block2)
(declare (type cblock block1 block2))
(let* ((last (block-last block2))
(values))
-;;; Delete any nodes in Block whose value is unused and have no
+;;; Delete any nodes in BLOCK whose value is unused and have no
;;; side-effects. We can delete sets of lexical variables when the set
;;; variable has no references.
;;;
-;;; [### For now, don't delete potentially flushable calls when they have the
-;;; Call attribute. Someday we should look at the funcitonal args to determine
-;;; if they have any side-effects.]
+;;; [### For now, don't delete potentially flushable calls when they
+;;; have the CALL attribute. Someday we should look at the funcitonal
+;;; args to determine if they have any side-effects.]
(defun flush-dead-code (block)
(declare (type cblock block))
(do-nodes-backwards (node cont block)
\f
;;;; local call return type propagation
-;;; This function is called on RETURN nodes that have their REOPTIMIZE flag
-;;; set. It iterates over the uses of the RESULT, looking for interesting
-;;; stuff to update the TAIL-SET. If a use isn't a local call, then we union
-;;; its type together with the types of other such uses. We assign to the
-;;; RETURN-RESULT-TYPE the intersection of this type with the RESULT's asserted
-;;; type. We can make this intersection now (potentially before type checking)
-;;; because this assertion on the result will eventually be checked (if
+;;; This function is called on RETURN nodes that have their REOPTIMIZE
+;;; flag set. It iterates over the uses of the RESULT, looking for
+;;; interesting stuff to update the TAIL-SET. If a use isn't a local
+;;; call, then we union its type together with the types of other such
+;;; uses. We assign to the RETURN-RESULT-TYPE the intersection of this
+;;; type with the RESULT's asserted type. We can make this
+;;; intersection now (potentially before type checking) because this
+;;; assertion on the result will eventually be checked (if
;;; appropriate.)
;;;
-;;; We call MAYBE-CONVERT-TAIL-LOCAL-CALL on each local non-MV combination,
-;;; which may change the succesor of the call to be the called function, and if
-;;; so, checks if the call can become an assignment. If we convert to an
-;;; assignment, we abort, since the RETURN has been deleted.
+;;; We call MAYBE-CONVERT-TAIL-LOCAL-CALL on each local non-MV
+;;; combination, which may change the succesor of the call to be the
+;;; called function, and if so, checks if the call can become an
+;;; assignment. If we convert to an assignment, we abort, since the
+;;; RETURN has been deleted.
(defun find-result-type (node)
(declare (type creturn node))
(let ((result (return-result node)))
(setf (return-result-type node) int))))
(values))
-;;; Do stuff to realize that something has changed about the value delivered
-;;; to a return node. Since we consider the return values of all functions in
-;;; the tail set to be equivalent, this amounts to bringing the entire tail set
-;;; up to date. We iterate over the returns for all the functions in the tail
-;;; set, reanalyzing them all (not treating Node specially.)
+;;; Do stuff to realize that something has changed about the value
+;;; delivered to a return node. Since we consider the return values of
+;;; all functions in the tail set to be equivalent, this amounts to
+;;; bringing the entire tail set up to date. We iterate over the
+;;; returns for all the functions in the tail set, reanalyzing them
+;;; all (not treating Node specially.)
;;;
-;;; When we are done, we check whether the new type is different from the old
-;;; TAIL-SET-TYPE. If so, we set the type and also reoptimize all the
-;;; continuations for references to functions in the tail set. This will cause
-;;; IR1-OPTIMIZE-COMBINATION to derive the new type as the results of the
-;;; calls.
+;;; When we are done, we check whether the new type is different from
+;;; the old TAIL-SET-TYPE. If so, we set the type and also reoptimize
+;;; all the continuations for references to functions in the tail set.
+;;; This will cause IR1-OPTIMIZE-COMBINATION to derive the new type as
+;;; the results of the calls.
(defun ir1-optimize-return (node)
(declare (type creturn node))
(let* ((tails (lambda-tail-set (return-lambda node)))
(add-continuation-use call (make-continuation))
t))))
-;;; Called both by IR1 conversion and IR1 optimization when they have
-;;; verified the type signature for the call, and are wondering if
-;;; something should be done to special-case the call. If Call is a
-;;; call to a global function, then see whether it defined or known:
+;;; This is called both by IR1 conversion and IR1 optimization when
+;;; they have verified the type signature for the call, and are
+;;; wondering if something should be done to special-case the call. If
+;;; Call is a call to a global function, then see whether it defined
+;;; or known:
;;; -- If a DEFINED-FUNCTION should be inline expanded, then convert the
;;; expansion and change the call to call it. Expansion is enabled if
;;; :INLINE or if space=0. If the FUNCTIONAL slot is true, we never expand,
(%denominator ,n-num)
1)))
\f
-;;;; Interval arithmetic for computing bounds
-;;;; (toy@rtp.ericsson.se)
+;;;; interval arithmetic for computing bounds
;;;;
;;;; This is a set of routines for operating on intervals. It
;;;; implements a simple interval arithmetic package. Although SBCL
-;;;; has an interval type in numeric-type, we choose to use our own
+;;;; has an interval type in NUMERIC-TYPE, we choose to use our own
;;;; for two reasons:
;;;;
-;;;; 1. This package is simpler than numeric-type
+;;;; 1. This package is simpler than NUMERIC-TYPE.
;;;;
;;;; 2. It makes debugging much easier because you can just strip
-;;;; out these routines and test them independently of SBCL. (a
+;;;; out these routines and test them independently of SBCL. (This is a
;;;; big win!)
;;;;
;;;; One disadvantage is a probable increase in consing because we
(labels ((normalize-bound (val)
(cond ((and (floatp val)
(float-infinity-p val))
- ;; Handle infinities
+ ;; Handle infinities.
nil)
((or (numberp val)
(eq val nil))
- ;; Handle any closed bounds
+ ;; Handle any closed bounds.
val)
((listp val)
;; We have an open bound. Normalize the numeric
;; bound is really unbounded, so drop the openness.
(let ((new-val (normalize-bound (first val))))
(when new-val
- ;; Bound exists, so keep it open still
+ ;; The bound exists, so keep it open still.
(list new-val))))
(t
(error "Unknown bound type in make-interval!")))))
;; Interval with no bounds
t))))
-;;; Determine if two intervals X and Y intersect. Return T if so. If
-;;; CLOSED-INTERVALS-P is T, the treat the intervals as if they were
-;;; closed. Otherwise the intervals are treated as they are.
+;;; Determine whether two intervals X and Y intersect. Return T if so.
+;;; If CLOSED-INTERVALS-P is T, the treat the intervals as if they
+;;; were closed. Otherwise the intervals are treated as they are.
;;;
;;; Thus if X = [0, 1) and Y = (1, 2), then they do not intersect
;;; because no element in X is in Y. However, if CLOSED-INTERVALS-P
(interval-closure int))
(let ((lo (interval-low int))
(hi (interval-high int)))
- ;; Check for endpoints
+ ;; Check for endpoints.
(cond ((and lo (= (bound-value p) (bound-value lo)))
(not (and (consp p) (numberp lo))))
((and hi (= (bound-value p) (bound-value hi)))
(test-number p int)
(not (interval-bounded-p int 'below))))
(test-upper-bound (p int)
- ;; P is an upper bound of an interval
+ ;; P is an upper bound of an interval.
(if p
(test-number p int)
(not (interval-bounded-p int 'above)))))
(cond ((and x1 x2)
;; Both bounds are finite. Select the right one.
(cond ((funcall min-op x1-val x2-val)
- ;; x1 definitely better
+ ;; x1 is definitely better.
x1)
((funcall max-op x1-val x2-val)
- ;; x2 definitely better
+ ;; x2 is definitely better.
x2)
(t
;; Bounds are equal. Select either
;;; true interval arithmetic here, but it's complicated because we
;;; have float and integer types and bounds can be open or closed.
-;;; The negative of an interval
+;;; the negative of an interval
(defun interval-neg (x)
(declare (type interval x))
(make-interval :low (bound-func #'- (interval-high x))
:high (bound-func #'- (interval-low x))))
-;;; Add two intervals
+;;; Add two intervals.
(defun interval-add (x y)
(declare (type interval x y))
(make-interval :low (bound-binop + (interval-low x) (interval-low y))
:high (bound-binop + (interval-high x) (interval-high y))))
-;;; Subtract two intervals
+;;; Subtract two intervals.
(defun interval-sub (x y)
(declare (type interval x y))
(make-interval :low (bound-binop - (interval-low x) (interval-high y))
:high (bound-binop - (interval-high x) (interval-low y))))
-;;; Multiply two intervals
+;;; Multiply two intervals.
(defun interval-mul (x y)
(declare (type interval x y))
(flet ((bound-mul (x y)
(interval-abs x)))
)) ; end PROGN's
\f
-;;;; numeric derive-type methods
+;;;; numeric DERIVE-TYPE methods
;;; a utility for defining derive-type methods of integer operations. If
;;; the types of both X and Y are integer types, then we compute a new
(if (and (numeric-type-real-p x)
(numeric-type-real-p y))
(let ((result
- ;; (- x x) is always 0.
+ ;; (- X X) is always 0.
(if same-arg
(make-interval :low 0 :high 0)
(interval-sub (numeric-type->interval x)
(make-numeric-type
:class (if (and (eq (numeric-type-class x) 'integer)
(eq (numeric-type-class y) 'integer))
- ;; The difference of integers is always an integer
+ ;; The difference of integers is always an integer.
'integer
(numeric-type-class result-type))
:format (numeric-type-format result-type)
:low (interval-low result)
:high (interval-high result)))
- ;; General contagion
+ ;; general contagion
(numeric-contagion x y)))
(defoptimizer (- derive-type) ((x y))
--- /dev/null
+;;;; floating-point-related tests with no side effects
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(cl:in-package :cl-user)
+
+(let ((+ifni single-float-positive-infinity)
+ (-ifni single-float-negative-infinity))
+ (assert (= (* +ifni 1) +ifni))
+ (assert (= (* +ifni -0.1) -ifni))
+ (assert (= (+ +ifni -0.1) +ifni))
+ (assert (= (- +ifni -0.1) +ifni))
+ (assert (= (sqrt +ifni) +ifni))
+ (assert (= (* -ifni -14) +ifni))
+ (assert (= (/ -ifni 0.1) -ifni))
+ (assert (= (/ -ifni 100/3) -ifni))
+ (assert (< -ifni +ifni))
+ (assert (not (< +ifni 100)))
+ (assert (not (< +ifni -ifni))))
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.11.23"
+"0.6.11.24"
projects / sbcl.git / commitdiff