[MLton-commit] r4672
Stephen Weeks
MLton@mlton.org
Tue, 4 Jul 2006 13:12:26 -0700
Went back to real primitives nextAfter{Down,Up} in place of nextAfter.
These primitives work nicely without requiring the platform to have
the C nextafter function (e.g. old Solaris). And, they have a very
simple implementation that meshes well with the SML code doing the
special-case checks for nan, inf, and zero. Someday, these C routines
might go away when we have a faster PackReal and PackWord. But the C
code is so simple it will be impressive if we can ever get MLton to
produce equivalently good code.
----------------------------------------------------------------------
U mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/basis-ffi.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/check-real.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-real.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.sml
U mlton/branches/on-20050822-x86_64-branch/bin/regression
A mlton/branches/on-20050822-x86_64-branch/regression/nextAfter.ok
A mlton/branches/on-20050822-x86_64-branch/regression/nextAfter.sml
U mlton/branches/on-20050822-x86_64-branch/runtime/basis/Real/class.c
U mlton/branches/on-20050822-x86_64-branch/runtime/basis/Real/nextAfter.c
U mlton/branches/on-20050822-x86_64-branch/runtime/gen/basis-ffi.def
U mlton/branches/on-20050822-x86_64-branch/runtime/platform/float-math.c
U mlton/branches/on-20050822-x86_64-branch/runtime/platform/float-math.h
----------------------------------------------------------------------
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/basis-ffi.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/basis-ffi.sml 2006-07-03 21:18:36 UTC (rev 4671)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/basis-ffi.sml 2006-07-04 20:12:21 UTC (rev 4672)
@@ -996,7 +996,8 @@
val muladd = _import "Real32_muladd" : Real32.t * Real32.t * Real32.t -> Real32.t;
val mulsub = _import "Real32_mulsub" : Real32.t * Real32.t * Real32.t -> Real32.t;
val neg = _import "Real32_neg" : Real32.t -> Real32.t;
-val nextAfter = _import "Real32_nextAfter" : Real32.t * Real32.t -> Real32.t;
+val nextAfterDown = _import "Real32_nextAfterDown" : Real32.t -> Real32.t;
+val nextAfterUp = _import "Real32_nextAfterUp" : Real32.t -> Real32.t;
val round = _import "Real32_round" : Real32.t -> Real32.t;
val signBit = _import "Real32_signBit" : Real32.t -> C_Int.t;
val store = _import "Real32_store" : (Real32.t) ref * Real32.t -> unit;
@@ -1056,7 +1057,8 @@
val muladd = _import "Real64_muladd" : Real64.t * Real64.t * Real64.t -> Real64.t;
val mulsub = _import "Real64_mulsub" : Real64.t * Real64.t * Real64.t -> Real64.t;
val neg = _import "Real64_neg" : Real64.t -> Real64.t;
-val nextAfter = _import "Real64_nextAfter" : Real64.t * Real64.t -> Real64.t;
+val nextAfterDown = _import "Real64_nextAfterDown" : Real64.t -> Real64.t;
+val nextAfterUp = _import "Real64_nextAfterUp" : Real64.t -> Real64.t;
val round = _import "Real64_round" : Real64.t -> Real64.t;
val signBit = _import "Real64_signBit" : Real64.t -> C_Int.t;
val store = _import "Real64_store" : (Real64.t) ref * Real64.t -> unit;
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/check-real.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/check-real.sml 2006-07-03 21:18:36 UTC (rev 4671)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/check-real.sml 2006-07-04 20:12:21 UTC (rev 4672)
@@ -49,7 +49,8 @@
val () = check (R1.*+, R2.muladd)
val () = check (R1.*-, R2.mulsub)
val () = check (R1.~, R2.neg)
- val () = check (R1.nextAfter, R2.nextAfter)
+ val () = check (R1.nextAfterDown, R2.nextAfterDown)
+ val () = check (R1.nextAfterUp, R2.nextAfterUp)
val () = check (R1.round, R2.round)
val () = check (R1.signBit, R2.signBit)
val () = check (R1.strto, R2.strto)
@@ -96,7 +97,8 @@
val () = check (R1.*+, R2.muladd)
val () = check (R1.*-, R2.mulsub)
val () = check (R1.~, R2.neg)
- val () = check (R1.nextAfter, R2.nextAfter)
+ val () = check (R1.nextAfterDown, R2.nextAfterDown)
+ val () = check (R1.nextAfterUp, R2.nextAfterUp)
val () = check (R1.round, R2.round)
val () = check (R1.signBit, R2.signBit)
val () = check (R1.strto, R2.strto)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-real.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-real.sml 2006-07-03 21:18:36 UTC (rev 4671)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/prim-real.sml 2006-07-04 20:12:21 UTC (rev 4672)
@@ -60,7 +60,8 @@
val minNormalPos: real
val minPos: real
val modf: real * real ref -> real
- val nextAfter: real * real -> real
+ val nextAfterDown: real -> real
+ val nextAfterUp: real -> real
val round: real -> real
val signBit: real -> C_Int.t
val strto: Primitive.NullString8.t -> real
@@ -141,7 +142,8 @@
val minNormalPos = #1 _symbol "Real32_minNormalPos": real GetSet.t; ()
val minPos = #1 _symbol "Real32_minPos": real GetSet.t; ()
val modf = _import "Real32_modf": real * real ref -> real;
- val nextAfter = _import "Real32_nextAfter": real * real -> real;
+ val nextAfterDown = _import "Real32_nextAfterDown": real -> real;
+ val nextAfterUp = _import "Real32_nextAfterUp": real -> real;
val round = _prim "Real32_round": real -> real;
val signBit = _import "Real32_signBit": real -> C_Int.t;
val strto = _import "Real32_strto": NullString8.t -> real;
@@ -223,7 +225,8 @@
val minNormalPos = #1 _symbol "Real64_minNormalPos": real GetSet.t; ()
val minPos = #1 _symbol "Real64_minPos": real GetSet.t; ()
val modf = _import "Real64_modf": real * real ref -> real;
- val nextAfter = _import "Real64_nextAfter": real * real -> real;
+ val nextAfterDown = _import "Real64_nextAfterDown": real -> real;
+ val nextAfterUp = _import "Real64_nextAfterUp": real -> real;
val round = _prim "Real64_round": real -> real;
val signBit = _import "Real64_signBit": real -> C_Int.t;
val strto = _import "Real64_strto": NullString8.t -> real;
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.sig 2006-07-03 21:18:36 UTC (rev 4671)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.sig 2006-07-04 20:12:21 UTC (rev 4672)
@@ -34,7 +34,8 @@
val class: real -> C_Int.t
val signBit: real -> C_Int.t
- val nextAfter: real * real -> real
+ val nextAfterDown: real -> real
+ val nextAfterUp: real -> real
val frexp: real * C_Int.int ref -> real
val ldexp: real * C_Int.int -> real
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.sml 2006-07-03 21:18:36 UTC (rev 4671)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.sml 2006-07-04 20:12:21 UTC (rev 4672)
@@ -208,24 +208,15 @@
(NAN, _) => nan
| (_, NAN) => nan
| (INF, _) => r
- | (ZERO, ZERO) => r
+ | (ZERO, ZERO) => t (* want "t", not "r", to get the sign right *)
| (ZERO, _) => if t > zero then minPos else ~minPos
| _ =>
- if r == t
- then r
+ if r == t then
+ r
+ else if (r > t) = (r > zero) then
+ R.nextAfterDown r
else
- let
- fun doit (r, t) =
- if r == maxFinite andalso t == posInf
- then posInf
- else if r > t
- then R.nextAfter (r, negInf)
- else R.nextAfter (r, posInf)
- in
- if r > zero
- then doit (r, t)
- else ~ (doit (~r, ~t))
- end
+ R.nextAfterUp r
fun toManExp x =
case class x of
Modified: mlton/branches/on-20050822-x86_64-branch/bin/regression
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/bin/regression 2006-07-03 21:18:36 UTC (rev 4671)
+++ mlton/branches/on-20050822-x86_64-branch/bin/regression 2006-07-04 20:12:21 UTC (rev 4672)
@@ -115,7 +115,7 @@
;;
esac
-for f in *.sml; do
+for f in real.sml; do
f=`basename "$f" .sml`
if [ "$skipTo" != "" ]; then
if [ "$skipTo" != "$f" ]; then
Added: mlton/branches/on-20050822-x86_64-branch/regression/nextAfter.ok
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/regression/nextAfter.ok 2006-07-03 21:18:36 UTC (rev 4671)
+++ mlton/branches/on-20050822-x86_64-branch/regression/nextAfter.ok 2006-07-04 20:12:21 UTC (rev 4672)
@@ -0,0 +1,42 @@
+nextAfter (~0.0, ~0.0) = ~0.0 OK
+nextAfter (~0.0, 0.0) = 0.0 OK
+nextAfter (0.0, ~0.0) = ~0.0 OK
+nextAfter (0.0, 0.0) = 0.0 OK
+nextAfter (~0.0, inf) = 0.1E~44 OK
+nextAfter (~0.0, ~inf) = ~0.1E~44 OK
+nextAfter (0.0, inf) = 0.1E~44 OK
+nextAfter (0.0, ~inf) = ~0.1E~44 OK
+nextAfter (0.1E~44, 0.0) = 0.0 OK
+nextAfter (0.1E~44, ~0.0) = 0.0 OK
+nextAfter (0.1E~44, ~inf) = 0.0 OK
+nextAfter (~0.1E~44, 0.0) = ~0.0 OK
+nextAfter (~0.1E~44, ~0.0) = ~0.0 OK
+nextAfter (~0.1E~44, inf) = ~0.0 OK
+nextAfter (0.1E~44, 0.1E~44) = 0.1E~44 OK
+nextAfter (~0.1E~44, ~0.1E~44) = ~0.1E~44 OK
+nextAfter (0.1E~44, inf) = 0.3E~44 OK
+nextAfter (~0.1E~44, ~inf) = ~0.3E~44 OK
+nextAfter (0.34028235E39, inf) = inf OK
+nextAfter (~0.34028235E39, ~inf) = ~inf OK
+nextAfter (0.11754942E~37, inf) = 0.11754944E~37 OK
+nextAfter (~0.0, ~0.0) = ~0.0 OK
+nextAfter (~0.0, 0.0) = 0.0 OK
+nextAfter (0.0, ~0.0) = ~0.0 OK
+nextAfter (0.0, 0.0) = 0.0 OK
+nextAfter (~0.0, inf) = 0.5E~323 OK
+nextAfter (~0.0, ~inf) = ~0.5E~323 OK
+nextAfter (0.0, inf) = 0.5E~323 OK
+nextAfter (0.0, ~inf) = ~0.5E~323 OK
+nextAfter (0.5E~323, 0.0) = 0.0 OK
+nextAfter (0.5E~323, ~0.0) = 0.0 OK
+nextAfter (0.5E~323, ~inf) = 0.0 OK
+nextAfter (~0.5E~323, 0.0) = ~0.0 OK
+nextAfter (~0.5E~323, ~0.0) = ~0.0 OK
+nextAfter (~0.5E~323, inf) = ~0.0 OK
+nextAfter (0.5E~323, 0.5E~323) = 0.5E~323 OK
+nextAfter (~0.5E~323, ~0.5E~323) = ~0.5E~323 OK
+nextAfter (0.5E~323, inf) = 0.1E~322 OK
+nextAfter (~0.5E~323, ~inf) = ~0.1E~322 OK
+nextAfter (0.17976931348623157E309, inf) = inf OK
+nextAfter (~0.17976931348623157E309, ~inf) = ~inf OK
+nextAfter (0.2225073858507201E~307, inf) = 0.22250738585072014E~307 OK
Added: mlton/branches/on-20050822-x86_64-branch/regression/nextAfter.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/regression/nextAfter.sml 2006-07-03 21:18:36 UTC (rev 4671)
+++ mlton/branches/on-20050822-x86_64-branch/regression/nextAfter.sml 2006-07-04 20:12:21 UTC (rev 4672)
@@ -0,0 +1,49 @@
+functor Test (R: REAL) =
+struct
+
+open R
+
+val posZero = minPos - minPos
+val negZero = ~posZero
+
+val rs =
+ [(negZero, negZero, negZero),
+ (negZero, posZero, posZero),
+ (posZero, negZero, negZero),
+ (posZero, posZero, posZero),
+ (negZero, posInf, minPos),
+ (negZero, negInf, ~minPos),
+ (posZero, posInf, minPos),
+ (posZero, negInf, ~minPos),
+ (minPos, posZero, posZero),
+ (minPos, negZero, posZero),
+ (minPos, negInf, posZero),
+ (~minPos, posZero, negZero),
+ (~minPos, negZero, negZero),
+ (~minPos, posInf, negZero),
+ (minPos, minPos, minPos),
+ (~minPos, ~minPos, ~minPos),
+ (minPos, posInf, fromInt 2 * minPos),
+ (~minPos, negInf, ~(fromInt 2 * minPos)),
+ (maxFinite, posInf, posInf),
+ (~maxFinite, negInf, negInf),
+ (nextAfter (minNormalPos, negInf), posInf, minNormalPos)]
+
+val () =
+ List.app
+ (fn (x, y, z) =>
+ let
+ val r2s = fmt StringCvt.EXACT
+ val z' = nextAfter (x, y)
+ in
+ print (concat ["nextAfter (", r2s x, ", ", r2s y, ") = ", r2s z', " ",
+ if == (z, z') then "OK" else concat ["<> ", r2s z],
+ "\n"])
+ end)
+ rs
+
+end
+
+structure Z = Test (Real32)
+structure Z = Test (Real64)
+
Modified: mlton/branches/on-20050822-x86_64-branch/runtime/basis/Real/class.c
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/basis/Real/class.c 2006-07-03 21:18:36 UTC (rev 4671)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/basis/Real/class.c 2006-07-04 20:12:21 UTC (rev 4672)
@@ -22,8 +22,8 @@
* d[1] bits 15-8 of mantissa
* d[2] bit 0 of exponent
* bits 22-16 of mantissa
- * d[7] sign bit
- * bits 7-2 of exponent
+ * d[3] sign bit
+ * bits 7-1 of exponent
*/
/* masks for word 0 */
Modified: mlton/branches/on-20050822-x86_64-branch/runtime/basis/Real/nextAfter.c
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/basis/Real/nextAfter.c 2006-07-03 21:18:36 UTC (rev 4671)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/basis/Real/nextAfter.c 2006-07-04 20:12:21 UTC (rev 4672)
@@ -1,10 +1,48 @@
#include "platform.h"
-/* nextafter is a macro, so we must have a C wrapper to work correctly. */
-Real32_t Real32_nextAfter (Real32_t x1, Real32_t x2) {
- return nextafterf (x1, x2);
+/* All of the Real{32,64}_nextAfter{Down,Up} functions work by converting the
+ * real to a word of equivalent size and doing an increment or decrement on the
+ * word. This works because the SML Basis Library code that calls these
+ * functions handles all the special cases (nans and infs). Also, because of
+ * the way IEEE floating point numbers are represented, word {de,in}crement
+ * automatically does the right thing at the boundary between normals and
+ * denormals. Also, convienently, maxFinite+1 = posInf.
+ */
+
+typedef union {
+ Real32_t r;
+ Word32_t w;
+} rw32;
+
+Real32_t Real32_nextAfterDown (Real32_t r) {
+ rw32 rw;
+ rw.r = r;
+ rw.w--;
+ return rw.r;
}
-Real64_t Real64_nextAfter (Real64_t x1, Real64_t x2) {
- return nextafter (x1, x2);
+Real32_t Real32_nextAfterUp (Real32_t r) {
+ rw32 rw;
+ rw.r = r;
+ rw.w++;
+ return rw.r;
}
+
+typedef union {
+ Real64_t r;
+ Word64_t w;
+} rw64;
+
+Real64_t Real64_nextAfterDown (Real64_t r) {
+ rw64 rw;
+ rw.r = r;
+ rw.w--;
+ return rw.r;
+}
+
+Real64_t Real64_nextAfterUp (Real64_t r) {
+ rw64 rw;
+ rw.r = r;
+ rw.w++;
+ return rw.r;
+}
Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gen/basis-ffi.def
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gen/basis-ffi.def 2006-07-03 21:18:36 UTC (rev 4671)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gen/basis-ffi.def 2006-07-04 20:12:21 UTC (rev 4672)
@@ -890,7 +890,8 @@
Real32.muladd = _import MLTON_CODEGEN_STATIC_INLINE : Real32.t * Real32.t * Real32.t -> Real32.t
Real32.mulsub = _import MLTON_CODEGEN_STATIC_INLINE : Real32.t * Real32.t * Real32.t -> Real32.t
Real32.neg = _import MLTON_CODEGEN_STATIC_INLINE : Real32.t -> Real32.t
-Real32.nextAfter = _import : Real32.t * Real32.t -> Real32.t
+Real32.nextAfterDown = _import : Real32.t -> Real32.t
+Real32.nextAfterUp = _import : Real32.t -> Real32.t
Real32.round = _import MLTON_CODEGEN_STATIC_INLINE : Real32.t -> Real32.t
Real32.signBit = _import : Real32.t -> C_Int.t
Real32.store = _import MLTON_CODEGEN_STATIC_INLINE : Real32.t ref * Real32.t -> unit
@@ -943,7 +944,8 @@
Real64.muladd = _import MLTON_CODEGEN_STATIC_INLINE : Real64.t * Real64.t * Real64.t -> Real64.t
Real64.mulsub = _import MLTON_CODEGEN_STATIC_INLINE : Real64.t * Real64.t * Real64.t -> Real64.t
Real64.neg = _import MLTON_CODEGEN_STATIC_INLINE : Real64.t -> Real64.t
-Real64.nextAfter = _import : Real64.t * Real64.t -> Real64.t
+Real64.nextAfterDown = _import : Real64.t -> Real64.t
+Real64.nextAfterUp = _import : Real64.t -> Real64.t
Real64.round = _import MLTON_CODEGEN_STATIC_INLINE : Real64.t -> Real64.t
Real64.signBit = _import : Real64.t -> C_Int.t
Real64.store = _import MLTON_CODEGEN_STATIC_INLINE : Real64.t ref * Real64.t -> unit
Modified: mlton/branches/on-20050822-x86_64-branch/runtime/platform/float-math.c
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/platform/float-math.c 2006-07-03 21:18:36 UTC (rev 4671)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/platform/float-math.c 2006-07-04 20:12:21 UTC (rev 4672)
@@ -24,7 +24,6 @@
return (float)(func((double)x, (double)y)); \
}
binaryReal(atan2)
-binaryReal(nextafter)
binaryReal(pow)
#undef binaryReal
Modified: mlton/branches/on-20050822-x86_64-branch/runtime/platform/float-math.h
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/platform/float-math.h 2006-07-03 21:18:36 UTC (rev 4671)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/platform/float-math.h 2006-07-04 20:12:21 UTC (rev 4672)
@@ -18,7 +18,6 @@
#define binaryReal(func) float func##f (float x, float y);
binaryReal(atan2)
-binaryReal(nextafter)
binaryReal(pow)
#undef binaryReal