From e58d0e9b37910fbf802804f534accb159235d539 Mon Sep 17 00:00:00 2001 From: simonm Date: Thu, 18 Feb 1999 12:26:17 +0000 Subject: [PATCH] [project @ 1999-02-18 12:26:11 by simonm] Add two new operations to StgPrimFloat.c: __int_encodeFloat __int_encodeDouble for encoding floats/doubles from small integers. This avoids having to convert small integers to large ones before an encodeFloat operation, and fixes the two cases of slowdown in nofib after the small integer changes. Also: - remove encodeFloat and decodeFloat as primops - use foreign import for encode{Float,Double} and the various isNaN etc. ccalls in PrelNumExtra. --- ghc/compiler/absCSyn/Costs.lhs | 4 +-- ghc/compiler/prelude/PrimOp.lhs | 26 ++++------------ ghc/includes/PrimOps.h | 37 +++++----------------- ghc/lib/std/PrelGHC.hi-boot | 2 -- ghc/lib/std/PrelNumExtra.lhs | 65 +++++++++++++++++++++++---------------- ghc/rts/StgPrimFloat.c | 61 ++++++++++++++++++++++++++++++------ 6 files changed, 104 insertions(+), 91 deletions(-) diff --git a/ghc/compiler/absCSyn/Costs.lhs b/ghc/compiler/absCSyn/Costs.lhs index ac1735b..5296a1b 100644 --- a/ghc/compiler/absCSyn/Costs.lhs +++ b/ghc/compiler/absCSyn/Costs.lhs @@ -349,8 +349,8 @@ floatOps = , DoubleAsinOp , DoubleAcosOp , DoubleAtanOp , DoubleSinhOp , DoubleCoshOp , DoubleTanhOp , DoublePowerOp - , FloatEncodeOp , FloatDecodeOp - , DoubleEncodeOp , DoubleDecodeOp + , FloatDecodeOp + , DoubleDecodeOp ] gmpOps :: [PrimOp] diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index b7bb8bc..1b978d1 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -127,8 +127,8 @@ data PrimOp | IntegerToWord64Op | Word64ToIntegerOp -- ?? gcd, etc? - | FloatEncodeOp | FloatDecodeOp - | DoubleEncodeOp | DoubleDecodeOp + | FloatDecodeOp + | DoubleDecodeOp -- primitive ops for primitive arrays @@ -416,9 +416,7 @@ tagOf_PrimOp IntegerToInt64Op = ILIT(120) 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) @@ -690,9 +688,7 @@ allThePrimOps Int64ToIntegerOp, IntegerToWord64Op, Word64ToIntegerOp, - FloatEncodeOp, FloatDecodeOp, - DoubleEncodeOp, DoubleDecodeOp, NewArrayOp, NewByteArrayOp CharRep, @@ -1057,8 +1053,7 @@ primOpInfo Addr2IntOp = mkGenPrimOp SLIT("addr2Int#") [] [addrPrimTy] intPrimTy %* * %************************************************************************ -@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 @@ -1091,8 +1086,7 @@ primOpInfo FloatPowerOp = mkDyadic SLIT("powerFloat#") 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 @@ -1176,16 +1170,10 @@ primOpInfo IntegerToWord64Op = 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]) @@ -1971,7 +1959,6 @@ primOpNeedsWrapper FloatSinhOp = True primOpNeedsWrapper FloatCoshOp = True primOpNeedsWrapper FloatTanhOp = True primOpNeedsWrapper FloatPowerOp = True -primOpNeedsWrapper FloatEncodeOp = True primOpNeedsWrapper DoubleExpOp = True primOpNeedsWrapper DoubleLogOp = True @@ -1986,7 +1973,6 @@ primOpNeedsWrapper DoubleSinhOp = True primOpNeedsWrapper DoubleCoshOp = True primOpNeedsWrapper DoubleTanhOp = True primOpNeedsWrapper DoublePowerOp = True -primOpNeedsWrapper DoubleEncodeOp = True primOpNeedsWrapper MakeStableNameOp = True primOpNeedsWrapper DeRefStablePtrOp = True diff --git a/ghc/includes/PrimOps.h b/ghc/includes/PrimOps.h index 53072c3..26a873e 100644 --- a/ghc/includes/PrimOps.h +++ b/ghc/includes/PrimOps.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -596,36 +596,9 @@ EF_(newArrayzh_fast); /* 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 @@ -636,8 +609,12 @@ EF_(decodeDoublezh_fast); /* 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); diff --git a/ghc/lib/std/PrelGHC.hi-boot b/ghc/lib/std/PrelGHC.hi-boot index a4c5d30..49520a9 100644 --- a/ghc/lib/std/PrelGHC.hi-boot +++ b/ghc/lib/std/PrelGHC.hi-boot @@ -144,7 +144,6 @@ __export PrelGHC tanhFloatzh powerFloatzh decodeFloatzh - encodeFloatzh Doublezh zgzhzh @@ -176,7 +175,6 @@ __export PrelGHC tanhDoublezh ztztzhzh decodeDoublezh - encodeDoublezh cmpIntegerzh cmpIntegerIntzh diff --git a/ghc/lib/std/PrelNumExtra.lhs b/ghc/lib/std/PrelNumExtra.lhs index 291c745..48cda70 100644 --- a/ghc/lib/std/PrelNumExtra.lhs +++ b/ghc/lib/std/PrelNumExtra.lhs @@ -137,6 +137,16 @@ instance RealFrac Float where 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 @@ -146,9 +156,8 @@ instance RealFloat Float where = 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 @@ -158,15 +167,11 @@ instance RealFloat Float where 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} %********************************************************* @@ -289,6 +294,16 @@ instance RealFrac Double where 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 @@ -298,9 +313,8 @@ instance RealFloat Double where = 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 @@ -310,15 +324,12 @@ instance RealFloat Double where 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 @@ -592,9 +603,6 @@ instead of 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 @@ -624,6 +632,9 @@ fromRat x = x' 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 diff --git a/ghc/rts/StgPrimFloat.c b/ghc/rts/StgPrimFloat.c index 8c3bef6..2a73977 100644 --- a/ghc/rts/StgPrimFloat.c +++ b/ghc/rts/StgPrimFloat.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -44,18 +44,19 @@ #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 */ @@ -63,33 +64,73 @@ __encodeDouble (MP_INT *s, I_ e) /* result = s * 2^e */ 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 */ -- 1.7.10.4