From: William Harold Newman Date: Thu, 22 Mar 2001 13:51:36 +0000 (+0000) Subject: 0.6.11.24: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=c8af15e61b030c8d4b0e950bc9b7618530044618;p=sbcl.git 0.6.11.24: 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 --- diff --git a/BUGS b/BUGS index 30d25d5..6857912 100644 --- a/BUGS +++ b/BUGS @@ -118,15 +118,6 @@ WORKAROUND: (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)) diff --git a/NEWS b/NEWS index 3625151..f0ed713 100644 --- a/NEWS +++ b/NEWS @@ -685,8 +685,9 @@ changes in sbcl-0.6.12 relative to sbcl-0.6.11: * 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 diff --git a/base-target-features.lisp-expr b/base-target-features.lisp-expr index 85d3723..8ac06a0 100644 --- a/base-target-features.lisp-expr +++ b/base-target-features.lisp-expr @@ -147,13 +147,6 @@ ; :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. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 3746b0b..4b52c47 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -547,7 +547,7 @@ like *STACK-TOP-HINT*" ;; 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" @@ -557,14 +557,14 @@ like *STACK-TOP-HINT*" "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 @@ -774,7 +774,6 @@ retained, possibly temporariliy, because it might be used internally." ;; 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" diff --git a/src/code/cross-float.lisp b/src/code/cross-float.lisp index b6c4ff1..397e127 100644 --- a/src/code/cross-float.lisp +++ b/src/code/cross-float.lisp @@ -39,16 +39,18 @@ ;;; 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)) diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp index d242e8b..caadeaf 100644 --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -37,45 +37,43 @@ (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))) @@ -97,14 +95,13 @@ (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)) @@ -122,11 +119,9 @@ :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))))) @@ -167,14 +162,13 @@ |# ) +;;; 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)) diff --git a/src/code/float.lisp b/src/code/float.lisp index cd661ae..6e71f91 100644 --- a/src/code/float.lisp +++ b/src/code/float.lisp @@ -117,34 +117,33 @@ (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 @@ -644,9 +643,10 @@ (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) @@ -665,10 +665,10 @@ (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. diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index 6544f58..761940d 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -44,7 +44,7 @@ ;;; 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) @@ -59,7 +59,7 @@ (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) @@ -156,16 +156,16 @@ ;;; 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 @@ -187,10 +187,11 @@ (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." @@ -302,16 +303,18 @@ (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) @@ -403,7 +406,7 @@ (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." diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp index 9342340..4c67532 100644 --- a/src/code/late-extensions.lisp +++ b/src/code/late-extensions.lisp @@ -25,19 +25,6 @@ (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 diff --git a/src/code/loop.lisp b/src/code/loop.lisp index affebfb..ba7450e 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -240,11 +240,8 @@ constructed. 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) diff --git a/src/code/print.lisp b/src/code/print.lisp index 7164452..f038d4a 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -1437,9 +1437,8 @@ (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* diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index 87f72ec..2f3db4c 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -493,15 +493,13 @@ ;;;; 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) diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index 618ac95..f6c1427 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -221,9 +221,7 @@ (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. @@ -278,9 +276,10 @@ ;;; 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 @@ -304,12 +303,12 @@ (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)) @@ -327,52 +326,52 @@ (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) @@ -885,7 +884,7 @@ ;; 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))))))) @@ -1171,12 +1170,11 @@ (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 @@ -1220,39 +1218,42 @@ (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)) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 27fdf2e..78ffa84 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -270,17 +270,17 @@ ;;; -- 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) @@ -308,20 +308,20 @@ ;;; 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)))) @@ -343,10 +343,11 @@ ((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) @@ -357,9 +358,9 @@ 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)) @@ -392,13 +393,13 @@ (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) @@ -445,19 +446,21 @@ ;;;; 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))) @@ -478,17 +481,18 @@ (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))) @@ -756,10 +760,11 @@ (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, diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index a9c1533..19588d1 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -190,18 +190,17 @@ (%denominator ,n-num) 1))) -;;;; 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 @@ -225,11 +224,11 @@ (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 @@ -238,7 +237,7 @@ ;; 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!"))))) @@ -425,9 +424,9 @@ ;; 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 @@ -493,7 +492,7 @@ (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))) @@ -505,7 +504,7 @@ (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))))) @@ -546,10 +545,10 @@ (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 @@ -571,25 +570,25 @@ ;;; 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) @@ -746,7 +745,7 @@ (interval-abs x))) )) ; end PROGN's -;;;; 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 @@ -1253,7 +1252,7 @@ (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) @@ -1270,13 +1269,13 @@ (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)) diff --git a/tests/float.pure.lisp b/tests/float.pure.lisp new file mode 100644 index 0000000..9b87d63 --- /dev/null +++ b/tests/float.pure.lisp @@ -0,0 +1,28 @@ +;;;; 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)))) diff --git a/version.lisp-expr b/version.lisp-expr index 97bd941..bfc0f9f 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; 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"