[MLton-devel] cvs commit: cleanup of Real{32,64} implementation

Stephen Weeks sweeks@users.sourceforge.net
Sat, 26 Jul 2003 10:54:19 -0700


sweeks      03/07/26 10:54:19

  Modified:    basis-library/misc primitive.sml
               basis-library/real real.fun real.sig
               include  c-chunk.h
               runtime  Makefile
               runtime/basis/Real frexp.c
  Removed:     runtime/basis/Real copysign.c isFinite.c isNan.c isNormal.c
                        nextAfter.c pow.c round.c strtod.c trig.c
  Log:
  Eliminated a lot of C wrappers for Real.math functions.
  
  When implementing Real32 functions in terms of Real64 functions, moved
  the casts from the C runtime library code to the SML basis library
  code.
  
  Simplified the real functor to implement
  Real.{isFinite,isNan,isNormal} in terms of Real.class.  This should
  make us more portable andalso ensure that these functions behave well
  even on x86's with 80 bit floating point registers, because
  Real{32,64}.class is implemented by storing the float or double to
  memory and inspecting it there.

Revision  Changes    Path
1.68      +94 -78    mlton/basis-library/misc/primitive.sml

Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.67
retrieving revision 1.68
diff -u -r1.67 -r1.68
--- primitive.sml	25 Jul 2003 20:14:46 -0000	1.67
+++ primitive.sml	26 Jul 2003 17:54:18 -0000	1.68
@@ -731,73 +731,6 @@
 	       _import "Ptrace_ptrace4": int * pid * word * word ref -> int;
 	 end
 
-      structure Real32 =
-	 struct
-	    type real = Real32.real
-
-	    structure Math =
-	       struct
-		  type real = real
-		     
-		  val acos = _prim "Real32_Math_acos": real -> real;
-		  val asin = _prim "Real32_Math_asin": real -> real;
-		  val atan = _prim "Real32_Math_atan": real -> real;
-		  val atan2 = _prim "Real32_Math_atan2": real * real -> real;
-		  val cos = _prim "Real32_Math_cos": real -> real;
-		  val cosh = _import "Real32_Math_cosh": real -> real;
-		  val e = _import "Real32_Math_e": real;
-		  val exp = _prim "Real32_Math_exp": real -> real;
-		  val ln = _prim "Real32_Math_ln": real -> real;
-		  val log10 = _prim "Real32_Math_log10": real -> real;
-		  val pi = _import "Real32_Math_pi": real;
-		  val pow = _import "Real32_Math_pow": real * real -> real;
-		  val sin = _prim "Real32_Math_sin": real -> real;
-		  val sinh = _import "Real32_Math_sinh": real -> real;
-		  val sqrt = _prim "Real32_Math_sqrt": real -> real;
-		  val tan = _prim "Real32_Math_tan": real -> real;
-		  val tanh = _import "Real32_Math_tanh": real -> real;
-	       end
-
-	    val * = _prim "Real32_mul": real * real -> real;
-	    val *+ = _prim "Real32_muladd": real * real * real -> real;
-	    val *- = _prim "Real32_mulsub": real * real * real -> real;
-	    val + = _prim "Real32_add": real * real -> real;
-	    val - = _prim "Real32_sub": real * real -> real;
-	    val / = _prim "Real32_div": real * real -> real;
-	    val < = _prim "Real32_lt": real * real -> bool;
-	    val <= = _prim "Real32_le": real * real -> bool;
-	    val == = _prim "Real32_equal": real * real -> bool;
-	    val > = _prim "Real32_gt": real * real -> bool;
-	    val >= = _prim "Real32_ge": real * real -> bool;
-	    val ?= = _prim "Real32_qequal": real * real -> bool;
-	    val abs = _prim "Real32_abs": real -> real;
-	    val class = _import "Real32_class": real -> int;
-	    val copySign = _import "Real32_copysign": real * real -> real;
-	    val frexp = _import "Real32_frexp": real * int ref -> real;
-	    val gdtoa =
-	       _import "Real32_gdtoa": real * int * int * int ref -> cstring;
-	    val fromInt = _prim "Int32_toReal32": int -> real;
-	    val isFinite = _import "Real32_isFinite": real -> bool;
-	    val isNan = _import "Real32_isNan": real -> bool;
-	    val isNormal = _import "Real32_isNormal": real -> bool;
-	    val ldexp = _prim "Real32_ldexp": real * int -> real;
-	    val maxFinite = _import "Real32_maxFinite": real;
-	    val minNormalPos = _import "Real32_minNormalPos": real;
-	    val minPos = _import "Real32_minPos": real;
-	    val modf = _import "Real32_modf": real * real ref -> real;
-	    val nextAfter = _import "Real32_nextAfter": real * real -> real;
-	    val round = _prim "Real32_round": real -> real;
-	    val signBit = _import "Real32_signBit": real -> bool;
-	    val strto = _import "Real32_strto": nullString -> real;
-	    val toInt = _prim "Real32_toInt32": real -> int;
-	    val ~ = _prim "Real32_neg": real -> real;
-
-	    val fromLarge = _prim "Real64_toReal32": real64 -> real;
-	    val toLarge = _prim "Real32_toReal64": real -> real64;
-	    val precision : int = 23
-	    val radix : int = 2
-	 end
-      
       structure Real64 =
 	 struct
 	    type real = Real64.real
@@ -811,18 +744,18 @@
 		  val atan = _prim "Real64_Math_atan": real -> real;
 		  val atan2 = _prim "Real64_Math_atan2": real * real -> real;
 		  val cos = _prim "Real64_Math_cos": real -> real;
-		  val cosh = _import "Real64_Math_cosh": real -> real;
+		  val cosh = _import "cosh": real -> real;
 		  val e = _import "Real64_Math_e": real;
 		  val exp = _prim "Real64_Math_exp": real -> real;
 		  val ln = _prim "Real64_Math_ln": real -> real;
 		  val log10 = _prim "Real64_Math_log10": real -> real;
 		  val pi = _import "Real64_Math_pi": real;
-		  val pow = _import "Real64_Math_pow": real * real -> real;
+		  val pow = _import "pow": real * real -> real;
 		  val sin = _prim "Real64_Math_sin": real -> real;
-		  val sinh = _import "Real64_Math_sinh": real -> real;
+		  val sinh = _import "sinh": real -> real;
 		  val sqrt = _prim "Real64_Math_sqrt": real -> real;
 		  val tan = _prim "Real64_Math_tan": real -> real;
-		  val tanh = _import "Real64_Math_tanh": real -> real;
+		  val tanh = _import "tanh": real -> real;
 	       end
 
 	    val * = _prim "Real64_mul": real * real -> real;
@@ -839,21 +772,24 @@
 	    val ?= = _prim "Real64_qequal": real * real -> bool;
 	    val abs = _prim "Real64_abs": real -> real;
 	    val class = _import "Real64_class": real -> int;
-	    val copySign = _import "Real64_copysign": real * real -> real;
+	    val copySign = _import "copysign": real * real -> real;
 	    val frexp = _import "Real64_frexp": real * int ref -> real;
 	    val gdtoa =
 	       _import "Real64_gdtoa": real * int * int * int ref -> cstring;
 	    val fromInt = _prim "Int32_toReal64": int -> real;
-	    val isFinite = _import "Real64_isFinite": real -> bool;
-	    val isNan = _import "Real64_isNan": real -> bool;
-	    val isNormal = _import "Real64_isNormal": real -> bool;
-	    val ldexp = _prim "Real64_ldexp": real * int -> real;
+	    val ldexp =
+	       if Native.native
+		  then _prim "Real64_ldexp": real * int -> real;
+	       else _import "ldexp": real * int -> real;
 	    val maxFinite = _import "Real64_maxFinite": real;
 	    val minNormalPos = _import "Real64_minNormalPos": real;
 	    val minPos = _import "Real64_minPos": real;
 	    val modf = _import "Real64_modf": real * real ref -> real;
-	    val nextAfter = _import "Real64_nextAfter": real * real -> real;
-	    val round = _prim "Real64_round": real -> real;
+	    val nextAfter = _import "nextAfter": real * real -> real;
+	    val round =
+	       if Native.native
+		  then _prim "Real64_round": real -> real;
+	       else _import "rint": real -> real;
 	    val signBit = _import "Real64_signBit": real -> bool;
 	    val strto = _import "Real64_strto": nullString -> real;
 	    val toInt = _prim "Real64_toInt32": real -> int;
@@ -865,6 +801,86 @@
 	    val radix : int = 2
 	 end
       
+      structure Real32 =
+	 struct
+	    type real = Real32.real
+
+	    val precision : int = 23
+	    val radix : int = 2
+
+	    val fromLarge = _prim "Real64_toReal32": real64 -> real;
+	    val toLarge = _prim "Real32_toReal64": real -> real64;
+
+	    fun unary (f: Real64.real -> Real64.real) (r: real): real =
+	       fromLarge (f (toLarge r))
+
+	    fun binary (f: Real64.real * Real64.real -> Real64.real)
+	       (r: real, r': real): real =
+	       fromLarge (f (toLarge r, toLarge r'))
+	       
+	    structure Math =
+	       struct
+		  type real = real
+		     
+		  val acos = _prim "Real32_Math_acos": real -> real;
+		  val asin = _prim "Real32_Math_asin": real -> real;
+		  val atan = _prim "Real32_Math_atan": real -> real;
+		  val atan2 = _prim "Real32_Math_atan2": real * real -> real;
+		  val cos = _prim "Real32_Math_cos": real -> real;
+		  val cosh = unary Real64.Math.cosh
+		  val e = _import "Real32_Math_e": real;
+		  val exp = _prim "Real32_Math_exp": real -> real;
+		  val ln = _prim "Real32_Math_ln": real -> real;
+		  val log10 = _prim "Real32_Math_log10": real -> real;
+		  val pi = _import "Real32_Math_pi": real;
+		  val pow = binary Real64.Math.pow
+		  val sin = _prim "Real32_Math_sin": real -> real;
+		  val sinh = unary Real64.Math.sinh
+		  val sqrt = _prim "Real32_Math_sqrt": real -> real;
+		  val tan = _prim "Real32_Math_tan": real -> real;
+		  val tanh = unary Real64.Math.tanh
+	       end
+
+	    val * = _prim "Real32_mul": real * real -> real;
+	    val *+ = _prim "Real32_muladd": real * real * real -> real;
+	    val *- = _prim "Real32_mulsub": real * real * real -> real;
+	    val + = _prim "Real32_add": real * real -> real;
+	    val - = _prim "Real32_sub": real * real -> real;
+	    val / = _prim "Real32_div": real * real -> real;
+	    val < = _prim "Real32_lt": real * real -> bool;
+	    val <= = _prim "Real32_le": real * real -> bool;
+	    val == = _prim "Real32_equal": real * real -> bool;
+	    val > = _prim "Real32_gt": real * real -> bool;
+	    val >= = _prim "Real32_ge": real * real -> bool;
+	    val ?= = _prim "Real32_qequal": real * real -> bool;
+	    val abs = _prim "Real32_abs": real -> real;
+	    val class = _import "Real32_class": real -> int;
+	    val copySign = _import "copysignf": real * real -> real;
+	    fun frexp (r: real, ir: int ref): real =
+	       fromLarge (Real64.frexp (toLarge r, ir))
+	    val gdtoa =
+	       _import "Real32_gdtoa": real * int * int * int ref -> cstring;
+	    val fromInt = _prim "Int32_toReal32": int -> real;
+	    val ldexp =
+	       if Native.native
+		  then _prim "Real32_ldexp": real * int -> real;
+	       else fn (r, i) => fromLarge (Real64.ldexp (toLarge (r, i)))
+	    val maxFinite = _import "Real32_maxFinite": real;
+	    val minNormalPos = _import "Real32_minNormalPos": real;
+	    val minPos = _import "Real32_minPos": real;
+	    val modf = _import "Real32_modf": real * real ref -> real;
+	    val nextAfter = _import "nextAfterf": real * real -> real;
+	    val round =
+	       if Native.native
+		  then _prim "Real32_round": real -> real;
+	       else _import "rintf": real -> real;
+	    val signBit = _import "Real32_signBit": real -> bool;
+	    val strto = _import "Real32_strto": nullString -> real;
+	    val toInt = _prim "Real32_toInt32": real -> int;
+	    val ~ = _prim "Real32_neg": real -> real;
+	 end
+
+
       structure Ref =
 	 struct
 	    val deref = fn x => _prim "Ref_deref": 'a ref -> 'a; x



1.2       +28 -20    mlton/basis-library/real/real.fun

Index: real.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/real/real.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- real.fun	25 Jul 2003 20:14:46 -0000	1.1
+++ real.fun	26 Jul 2003 17:54:18 -0000	1.2
@@ -18,9 +18,6 @@
 	 val abs = abs
 	 val copySign = copySign
 	 val fromInt = fromInt
-	 val isFinite = isFinite
-	 val isNan = isNan
-	 val isNormal = isNormal
 	 val maxFinite = maxFinite
 	 val minNormalPos = minNormalPos
 	 val minPos = minPos
@@ -39,11 +36,6 @@
 	 val signBit = signBit
 	 val ~ = ~
       end
-
-      val op ?= =
-	 if Primitive.MLton.native
-	    then op ?=
-	 else fn (r, r') => isNan r orelse isNan r' orelse r == r'
 	 
       val radix: int = Prim.radix
 
@@ -94,6 +86,33 @@
 	       else (acos, asin, ln, log10)
 	 end
 
+
+         (* See runtime/basis/Real.c for the integers returned by class. *)
+      fun class x =
+	 case Prim.class x of
+	    0 => NAN
+	  | 1 => NAN
+	  | 2 => INF
+	  | 3 => ZERO
+	  | 4 => NORMAL
+	  | 5 => SUBNORMAL
+	  | _ => raise Fail "Real_class returned bogus integer"
+
+      fun isFinite r =
+	 case class r of
+	    INF => false
+	  | NAN => false
+	  | _ => true
+	       
+      fun isNan r = class r = NAN
+
+      fun isNormal r = class r = NORMAL
+
+      val op ?= =
+	 if Primitive.MLton.native
+	    then op ?=
+	 else fn (r, r') => isNan r orelse isNan r' orelse r == r'
+
       val op != = not o op ==
 
       fun min (x, y) = if x < y orelse isNan y then x else y
@@ -129,18 +148,7 @@
       end
    
       fun unordered (x, y) = isNan x orelse isNan y
-
-      (* See runtime/basis/Real.c for the integers returned by class. *)
-      fun class x =
-	 case Prim.class x of
-	    0 => NAN (* QUIET *)
-	  | 1 => NAN (* SIGNALLING *)
-	  | 2 => INF
-	  | 3 => ZERO
-	  | 4 => NORMAL
-	  | 5 => SUBNORMAL
-	  | _ => raise Fail "Primitive.Real.class returned bogus integer"
-
+	 
       val toManExp =
 	 let
 	    val r: int ref = ref 0



1.9       +6 -10     mlton/basis-library/real/real.sig

Index: real.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/real/real.sig,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- real.sig	25 Jul 2003 20:14:46 -0000	1.8
+++ real.sig	26 Jul 2003 17:54:18 -0000	1.9
@@ -34,27 +34,23 @@
       val abs: real -> real
       val class: real -> int
       val copySign: real * real -> real
-      val frexp: real * int ref -> real;
-      val gdtoa: real * int * int * int ref -> Primitive.cstring;
+      val frexp: real * int ref -> real
+      val gdtoa: real * int * int * int ref -> Primitive.cstring
       val fromInt: int -> real
-      val isFinite: real -> bool
-      val isNan: real -> bool
-      val isNormal: real -> bool
+      val fromLarge: IEEEReal.rounding_mode -> LargeReal.real -> real
       val ldexp: real * int -> real
       val maxFinite: real
       val minNormalPos: real
       val minPos: real
       val modf: real * real ref -> real
       val nextAfter: real * real -> real
+      val precision: int
+      val radix: int
       val round: real -> real
       val signBit: real -> bool
       val strto: nullString -> real
       val toInt: real -> int
-	 
-      val fromLarge: IEEEReal.rounding_mode -> LargeReal.real -> real
-      val toLarge: real -> LargeReal.real
-      val precision: int
-      val radix: int
+      val toLarge: real -> LargeReal.real	 
   end
 
 signature REAL_GLOBAL =



1.11      +0 -8      mlton/include/c-chunk.h

Index: c-chunk.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/c-chunk.h,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- c-chunk.h	25 Jul 2003 20:14:46 -0000	1.10
+++ c-chunk.h	26 Jul 2003 17:54:19 -0000	1.11
@@ -501,20 +501,12 @@
 binaryReal(le, <=)
 binaryReal(lt, <)
 
-Real64 ldexp (Real64 x, Int i);
-static inline Real64 Real64_ldexp (Real64 x, Int i) {
-	return ldexp (x, i);
-}
-static inline Real32 Real32_ldexp (Real32 x, Int i) {
-	return (Real32)(Real64_ldexp ((Real64)x, i));
-}
 #define Real32_muladd(x, y, z) ((x) * (y) + (z))
 #define Real32_mulsub(x, y, z) ((x) * (y) - (z))
 #define Real64_muladd(x, y, z) ((x) * (y) + (z))
 #define Real64_mulsub(x, y, z) ((x) * (y) - (z))
 #define Real32_neg(x) (-(x))
 #define Real64_neg(x) (-(x))
-Real64 Real64_round (Real64 x);
 #define Real32_toInt(x) ((Int)(x))
 #define Real64_toInt(x) ((Int)(x))
 



1.70      +0 -16     mlton/runtime/Makefile

Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Makefile,v
retrieving revision 1.69
retrieving revision 1.70
diff -u -r1.69 -r1.70
--- Makefile	25 Jul 2003 20:14:47 -0000	1.69
+++ Makefile	26 Jul 2003 17:54:19 -0000	1.70
@@ -78,20 +78,12 @@
 	basis/Ptrace/ptrace2.o			\
 	basis/Ptrace/ptrace4.o			\
 	basis/Real/class.o			\
-	basis/Real/copysign.o			\
 	basis/Real/frexp.o			\
 	basis/Real/gdtoa.o			\
-	basis/Real/isFinite.o			\
-	basis/Real/isNan.o			\
-	basis/Real/isNormal.o			\
 	basis/Real/modf.o			\
-	basis/Real/nextAfter.o			\
-	basis/Real/pow.o			\
 	basis/Real/real.o			\
-	basis/Real/round.o			\
 	basis/Real/signBit.o			\
 	basis/Real/strto.o			\
-	basis/Real/trig.o			\
 	basis/Stdio.o				\
 	basis/Thread.o				\
 	basis/Time.o				\
@@ -250,20 +242,12 @@
 	basis/Ptrace/ptrace2-gdb.o		\
 	basis/Ptrace/ptrace4-gdb.o		\
 	basis/Real/class-gdb.o			\
-	basis/Real/copysign-gdb.o		\
 	basis/Real/frexp-gdb.o			\
 	basis/Real/gdtoa-gdb.o			\
-	basis/Real/isFinite-gdb.o		\
-	basis/Real/isNan-gdb.o			\
-	basis/Real/isNormal-gdb.o		\
 	basis/Real/modf-gdb.o			\
-	basis/Real/nextAfter-gdb.o		\
-	basis/Real/pow-gdb.o			\
 	basis/Real/real-gdb.o			\
-	basis/Real/round-gdb.o			\
 	basis/Real/signBit-gdb.o		\
 	basis/Real/strto-gdb.o			\
-	basis/Real/trig-gdb.o			\
 	basis/Stdio-gdb.o			\
 	basis/Thread-gdb.o			\
 	basis/Time-gdb.o			\



1.2       +1 -9      mlton/runtime/basis/Real/frexp.c

Index: frexp.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real/frexp.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- frexp.c	25 Jul 2003 20:14:48 -0000	1.1
+++ frexp.c	26 Jul 2003 17:54:19 -0000	1.2
@@ -1,15 +1,7 @@
 #include <math.h>
 #include "mlton-basis.h"
 
-double frexp(double x, int* exp);
-
-Real32 Real32_frexp(Real32 x, Int *exp) {
-	int exp_;
-        Real32 res;
-	res = (Real32)(frexp((Real64) x, &exp_));
-	*exp = exp_;
-	return res;
-}
+double frexp (double x, int* exp);
 
 Real64 Real64_frexp(Real64 x, Int *exp) {
 	int exp_;





-------------------------------------------------------
This SF.Net email sponsored by: Free pre-built ASP.NET sites including
Data Reports, E-commerce, Portals, and Forums are available now.
Download today and enter to win an XBOX or Visual Studio .NET.
http://aspnet.click-url.com/go/psa00100003ave/direct;at.aspnet_072303_01/01
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel