, DoubleAsinOp , DoubleAcosOp , DoubleAtanOp
, DoubleSinhOp , DoubleCoshOp , DoubleTanhOp
, DoublePowerOp
- , FloatEncodeOp , FloatDecodeOp
- , DoubleEncodeOp , DoubleDecodeOp
+ , FloatDecodeOp
+ , DoubleDecodeOp
]
gmpOps :: [PrimOp]
| IntegerToWord64Op | Word64ToIntegerOp
-- ?? gcd, etc?
- | FloatEncodeOp | FloatDecodeOp
- | DoubleEncodeOp | DoubleDecodeOp
+ | FloatDecodeOp
+ | DoubleDecodeOp
-- primitive ops for primitive arrays
tagOf_PrimOp Int64ToIntegerOp = ILIT(121)
tagOf_PrimOp IntegerToWord64Op = ILIT(122)
tagOf_PrimOp Word64ToIntegerOp = ILIT(123)
-tagOf_PrimOp FloatEncodeOp = ILIT(124)
tagOf_PrimOp FloatDecodeOp = ILIT(125)
-tagOf_PrimOp DoubleEncodeOp = ILIT(126)
tagOf_PrimOp DoubleDecodeOp = ILIT(127)
tagOf_PrimOp NewArrayOp = ILIT(128)
Int64ToIntegerOp,
IntegerToWord64Op,
Word64ToIntegerOp,
- FloatEncodeOp,
FloatDecodeOp,
- DoubleEncodeOp,
DoubleDecodeOp,
NewArrayOp,
NewByteArrayOp CharRep,
%* *
%************************************************************************
-@encodeFloat#@ and @decodeFloat#@ are given w/ Integer-stuff (it's
-similar).
+@decodeFloat#@ is given w/ Integer-stuff (it's similar).
\begin{code}
primOpInfo FloatAddOp = mkDyadic SLIT("plusFloat#") floatPrimTy
%* *
%************************************************************************
-@encodeDouble#@ and @decodeDouble#@ are given w/ Integer-stuff (it's
-similar).
+@decodeDouble#@ is given w/ Integer-stuff (it's similar).
\begin{code}
primOpInfo DoubleAddOp = mkDyadic SLIT("+##") doublePrimTy
= mkGenPrimOp SLIT("integerToWord64#") [] one_Integer_ty word64PrimTy
\end{code}
-Encoding and decoding of floating-point numbers is sorta
-Integer-related.
+Decoding of floating-point numbers is sorta Integer-related. Encoding
+is done with plain ccalls now (see PrelNumExtra.lhs).
\begin{code}
-primOpInfo FloatEncodeOp
- = mkGenPrimOp SLIT("encodeFloat#") [] an_Integer_and_Int_tys floatPrimTy
-
-primOpInfo DoubleEncodeOp
- = mkGenPrimOp SLIT("encodeDouble#") [] an_Integer_and_Int_tys doublePrimTy
-
primOpInfo FloatDecodeOp
= mkGenPrimOp SLIT("decodeFloat#") [] [floatPrimTy]
(unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy])
primOpNeedsWrapper FloatCoshOp = True
primOpNeedsWrapper FloatTanhOp = True
primOpNeedsWrapper FloatPowerOp = True
-primOpNeedsWrapper FloatEncodeOp = True
primOpNeedsWrapper DoubleExpOp = True
primOpNeedsWrapper DoubleLogOp = True
primOpNeedsWrapper DoubleCoshOp = True
primOpNeedsWrapper DoubleTanhOp = True
primOpNeedsWrapper DoublePowerOp = True
-primOpNeedsWrapper DoubleEncodeOp = True
primOpNeedsWrapper MakeStableNameOp = True
primOpNeedsWrapper DeRefStablePtrOp = True
/* -----------------------------------------------------------------------------
- * $Id: PrimOps.h,v 1.19 1999/02/17 15:57:30 simonm Exp $
+ * $Id: PrimOps.h,v 1.20 1999/02/18 12:26:11 simonm Exp $
*
* (c) The GHC Team, 1998-1999
*
/* We only support IEEE floating point format */
#include "ieee-flpt.h"
-#if FLOATS_AS_DOUBLES /* i.e. 64-bit machines */
-#define encodeFloatzh(r, sa,da, expon) encodeDoublezh(r, sa,da, expon)
-#else
-#define encodeFloatzh(r, sa,da, expon) \
-{ MP_INT arg; \
- /* Does not allocate memory */ \
- \
- arg._mp_size = sa; \
- arg._mp_alloc = ((StgArrWords *)da)->words; \
- arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
- \
- r = RET_PRIM_STGCALL2(StgFloat, __encodeFloat,&arg,(expon)); \
-}
-#endif /* FLOATS_AS_DOUBLES */
-
-#define encodeDoublezh(r, sa,da, expon) \
-{ MP_INT arg; \
- /* Does not allocate memory */ \
- \
- arg._mp_size = sa; \
- arg._mp_alloc = ((StgArrWords *)da)->words; \
- arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
- \
- r = RET_PRIM_STGCALL2(StgDouble, __encodeDouble,&arg,(expon)); \
-}
-
/* The decode operations are out-of-line because they need to allocate
* a byte array.
*/
-
#ifdef FLOATS_AS_DOUBLES
#define decodeFloatzh_fast decodeDoublezh_fast
#else
/* grimy low-level support functions defined in StgPrimFloat.c */
-extern StgDouble __encodeDouble (MP_INT *s, I_ e);
-extern StgFloat __encodeFloat (MP_INT *s, I_ e);
+extern StgDouble __encodeDouble (I_ size, StgByteArray arr, I_ e);
+extern StgDouble __int_encodeDouble (I_ j, I_ e);
+#ifndef FLOATS_AS_DOUBLES
+extern StgFloat __encodeFloat (I_ size, StgByteArray arr, I_ e);
+extern StgFloat __int_encodeFloat (I_ j, I_ e);
+#endif
extern void __decodeDouble (MP_INT *man, I_ *_exp, StgDouble dbl);
extern void __decodeFloat (MP_INT *man, I_ *_exp, StgFloat flt);
extern StgInt isDoubleNaN(StgDouble d);
tanhFloatzh
powerFloatzh
decodeFloatzh
- encodeFloatzh
Doublezh
zgzhzh
tanhDoublezh
ztztzhzh
decodeDoublezh
- encodeDoublezh
cmpIntegerzh
cmpIntegerIntzh
floor x = case properFraction x of
(n,r) -> if r < 0.0 then n - 1 else n
+foreign import ccall "__encodeFloat" unsafe
+ encodeFloat# :: Int# -> ByteArray# -> Int -> Float
+foreign import ccall "__int_encodeFloat" unsafe
+ int_encodeFloat# :: Int# -> Int -> Float
+
+foreign import ccall "isFloatNaN" unsafe isFloatNaN :: Float -> Int
+foreign import ccall "isFloatInfinite" unsafe isFloatInfinite :: Float -> Int
+foreign import ccall "isFloatDenormalized" unsafe isFloatDenormalized :: Float -> Int
+foreign import ccall "isFloatNegativeZero" unsafe isFloatNegativeZero :: Float -> Int
+
instance RealFloat Float where
floatRadix _ = FLT_RADIX -- from float.h
floatDigits _ = FLT_MANT_DIG -- ditto
= case decodeFloat# f# of
(# exp#, s#, d# #) -> (J# s# d#, I# exp#)
- encodeFloat i@(S# _) j = encodeFloat (toBig i) j
- encodeFloat (J# s# d#) (I# e#)
- = case encodeFloat# s# d# e# of { flt# -> F# flt# }
+ encodeFloat (S# i) j = int_encodeFloat# i j
+ encodeFloat (J# s# d#) e = encodeFloat# s# d# e
exponent x = case decodeFloat x of
(m,n) -> if m == 0 then 0 else n + floatDigits x
scaleFloat k x = case decodeFloat x of
(m,n) -> encodeFloat m (n+k)
- isNaN x =
- (0::Int) /= unsafePerformIO (_ccall_ isFloatNaN x) {- a _pure_function! -}
- isInfinite x =
- (0::Int) /= unsafePerformIO (_ccall_ isFloatInfinite x) {- ditto! -}
- isDenormalized x =
- (0::Int) /= unsafePerformIO (_ccall_ isFloatDenormalized x) -- ..
- isNegativeZero x =
- (0::Int) /= unsafePerformIO (_ccall_ isFloatNegativeZero x) -- ...
- isIEEE _ = True
+ isNaN x = 0 /= isFloatNaN x
+ isInfinite x = 0 /= isFloatInfinite x
+ isDenormalized x = 0 /= isFloatDenormalized x
+ isNegativeZero x = 0 /= isFloatNegativeZero x
+ isIEEE _ = True
\end{code}
%*********************************************************
floor x = case properFraction x of
(n,r) -> if r < 0.0 then n - 1 else n
+foreign import ccall "__encodeDouble" unsafe
+ encodeDouble# :: Int# -> ByteArray# -> Int -> Double
+foreign import ccall "__int_encodeDouble" unsafe
+ int_encodeDouble# :: Int# -> Int -> Double
+
+foreign import ccall "isDoubleNaN" unsafe isDoubleNaN :: Double -> Int
+foreign import ccall "isDoubleInfinite" unsafe isDoubleInfinite :: Double -> Int
+foreign import ccall "isDoubleDenormalized" unsafe isDoubleDenormalized :: Double -> Int
+foreign import ccall "isDoubleNegativeZero" unsafe isDoubleNegativeZero :: Double -> Int
+
instance RealFloat Double where
floatRadix _ = FLT_RADIX -- from float.h
floatDigits _ = DBL_MANT_DIG -- ditto
= case decodeDouble# x# of
(# exp#, s#, d# #) -> (J# s# d#, I# exp#)
- encodeFloat i@(S# _) j = encodeFloat (toBig i) j
- encodeFloat (J# s# d#) (I# e#)
- = case encodeDouble# s# d# e# of { dbl# -> D# dbl# }
+ encodeFloat (S# i) j = int_encodeDouble# i j
+ encodeFloat (J# s# d#) e = encodeDouble# s# d# e
exponent x = case decodeFloat x of
(m,n) -> if m == 0 then 0 else n + floatDigits x
scaleFloat k x = case decodeFloat x of
(m,n) -> encodeFloat m (n+k)
- isNaN x =
- (0::Int) /= unsafePerformIO (_ccall_ isDoubleNaN x) {- a _pure_function! -}
- isInfinite x =
- (0::Int) /= unsafePerformIO (_ccall_ isDoubleInfinite x) {- ditto -}
- isDenormalized x =
- (0::Int) /= unsafePerformIO (_ccall_ isDoubleDenormalized x) -- ..
- isNegativeZero x =
- (0::Int) /= unsafePerformIO (_ccall_ isDoubleNegativeZero x) -- ...
- isIEEE _ = True
+
+ isNaN x = 0 /= isDoubleNaN x
+ isInfinite x = 0 /= isDoubleInfinite x
+ isDenormalized x = 0 /= isDoubleDenormalized x
+ isNegativeZero x = 0 /= isDoubleNegativeZero x
+ isIEEE _ = True
instance Show Double where
showsPrec x = showSigned showFloat x
Lennart's code follows, and it works...
\begin{pseudocode}
-{-# SPECIALISE fromRat ::
- Rational -> Double,
- Rational -> Float #-}
fromRat :: (RealFloat a) => Rational -> a
fromRat x = x'
where x' = f e
Now, here's Lennart's code.
\begin{code}
+{-# SPECIALISE fromRat ::
+ Rational -> Double,
+ Rational -> Float #-}
fromRat :: (RealFloat a) => Rational -> a
fromRat x
| x == 0 = encodeFloat 0 0 -- Handle exceptional cases
/* -----------------------------------------------------------------------------
- * $Id: StgPrimFloat.c,v 1.3 1999/02/05 16:02:59 simonm Exp $
+ * $Id: StgPrimFloat.c,v 1.4 1999/02/18 12:26:12 simonm Exp $
*
* (c) The GHC Team, 1998-1999
*
#define __abs(a) (( (a) >= 0 ) ? (a) : (-(a)))
StgDouble
-__encodeDouble (MP_INT *s, I_ e) /* result = s * 2^e */
+__encodeDouble (I_ size, StgByteArray ba, I_ e) /* result = s * 2^e */
{
StgDouble r;
+ W_ *arr = (W_ *)ba;
I_ i;
/* Convert MP_INT to a double; knows a lot about internal rep! */
- i = __abs(s->_mp_size)-1;
+ i = __abs(size)-1;
if (i < 0) {
r = 0.0;
} else {
- for (r = s->_mp_d[i], i--; i >= 0; i--)
- r = r * GMP_BASE + s->_mp_d[i];
+ for (r = arr[i], i--; i >= 0; i--)
+ r = r * GMP_BASE + arr[i];
}
/* Now raise to the exponent */
r = ldexp(r, e);
/* sign is encoded in the size */
- if (s->_mp_size < 0)
+ if (size < 0)
r = -r;
return r;
}
+/* Special version for small Integers */
+StgDouble
+__int_encodeDouble (I_ j, I_ e)
+{
+ StgDouble r;
+
+ r = (StgDouble)__abs(j);
+
+ /* Now raise to the exponent */
+ if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
+ r = ldexp(r, e);
+
+ /* sign is encoded in the size */
+ if (j < 0)
+ r = -r;
+
+ return r;
+}
+
#if ! FLOATS_AS_DOUBLES
StgFloat
-__encodeFloat (MP_INT *s, I_ e) /* result = s * 2^e */
+__encodeFloat (I_ size, StgByteArray ba, I_ e) /* result = s * 2^e */
{
StgFloat r;
+ W_ *arr = (W_ *)ba;
I_ i;
/* Convert MP_INT to a float; knows a lot about internal rep! */
- for(r = 0.0, i = __abs(s->_mp_size)-1; i >= 0; i--)
- r = (r * GMP_BASE) + s->_mp_d[i];
+ for(r = 0.0, i = __abs(size); i >= 0; i--)
+ r = (r * GMP_BASE) + arr[i];
/* Now raise to the exponent */
if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
r = ldexp(r, e);
/* sign is encoded in the size */
- if (s->_mp_size < 0)
+ if (size < 0)
r = -r;
return r;
}
+
+/* Special version for small Integers */
+StgFloat
+__int_encodeFloat (I_ j, I_ e)
+{
+ StgFloat r;
+
+ r = (StgFloat)__abs(j);
+
+ /* Now raise to the exponent */
+ if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */
+ r = ldexp(r, e);
+
+ /* sign is encoded in the size */
+ if (j < 0)
+ r = -r;
+
+ return r;
+}
+
#endif /* FLOATS_AS_DOUBLES */
/* This only supports IEEE floating point */
projects / ghc-hetmet.git / commitdiff