diff options
| -rw-r--r-- | libraries/integer-gmp/GHC/Integer.lhs | 17 | ||||
| -rw-r--r-- | libraries/integer-gmp/GHC/Integer/Internals.hs | 176 | ||||
| -rw-r--r-- | libraries/integer-gmp/cbits/alloc.c | 105 | ||||
| -rw-r--r-- | libraries/integer-gmp/cbits/cbits.c | 13 | ||||
| -rw-r--r-- | libraries/integer-gmp/cbits/float.c | 66 | ||||
| -rw-r--r-- | libraries/integer-gmp/cbits/gmp-wrappers.cmm | 549 | ||||
| -rw-r--r-- | libraries/integer-gmp/integer.cabal | 7 |
7 files changed, 921 insertions, 12 deletions
diff --git a/libraries/integer-gmp/GHC/Integer.lhs b/libraries/integer-gmp/GHC/Integer.lhs index 4bb0ece0e8..07f890565e 100644 --- a/libraries/integer-gmp/GHC/Integer.lhs +++ b/libraries/integer-gmp/GHC/Integer.lhs @@ -51,14 +51,19 @@ import GHC.Prim ( -- Operations on Int# that we use for operations on S# quotInt#, remInt#, negateInt#, (==#), (/=#), (<=#), (>=#), (<#), (>#), (*#), (-#), (+#), - mulIntMayOflo#, addIntC#, subIntC#, gcdInt#, + mulIntMayOflo#, addIntC#, subIntC#, and#, or#, xor#, indexIntArray#, - -- GMP-related primitives in the RTS + ) + +import GHC.Integer.Internals ( + Integer(..), + + -- GMP-related primitives cmpInteger#, cmpIntegerInt#, plusInteger#, minusInteger#, timesInteger#, quotRemInteger#, quotInteger#, remInteger#, divModInteger#, - gcdInteger#, gcdIntegerInt#, divExactInteger#, + gcdInteger#, gcdIntegerInt#, gcdInt#, divExactInteger#, decodeDouble#, int2Integer#, integer2Int#, word2Integer#, integer2Word#, andInteger#, orInteger#, xorInteger#, complementInteger#, @@ -67,8 +72,6 @@ import GHC.Prim ( #endif ) -import GHC.Integer.Internals (Integer(..)) - #if WORD_SIZE_IN_BITS < 64 import GHC.IntWord64 ( Int64#, Word64#, @@ -460,12 +463,12 @@ floatFromInteger :: Integer -> Float# floatFromInteger (S# i#) = int2Float# i# floatFromInteger (J# s# d#) = encodeFloat# s# d# 0# -foreign import ccall unsafe "__encodeFloat" +foreign import ccall unsafe "integer_cbits_encodeFloat" encodeFloat# :: Int# -> ByteArray# -> Int# -> Float# foreign import ccall unsafe "__int_encodeFloat" int_encodeFloat# :: Int# -> Int# -> Float# -foreign import ccall unsafe "__encodeDouble" +foreign import ccall unsafe "integer_cbits_encodeDouble" encodeDouble# :: Int# -> ByteArray# -> Int# -> Double# foreign import ccall unsafe "__int_encodeDouble" int_encodeDouble# :: Int# -> Int# -> Double# diff --git a/libraries/integer-gmp/GHC/Integer/Internals.hs b/libraries/integer-gmp/GHC/Integer/Internals.hs index f1ffbf9ee0..e0e87be6b2 100644 --- a/libraries/integer-gmp/GHC/Integer/Internals.hs +++ b/libraries/integer-gmp/GHC/Integer/Internals.hs @@ -1,9 +1,58 @@ +{-# LANGUAGE ForeignFunctionInterface, GHCForeignImportPrim, + MagicHash, UnboxedTuples, UnliftedFFITypes #-} {-# OPTIONS_GHC -XNoImplicitPrelude #-} {-# OPTIONS_HADDOCK hide #-} -module GHC.Integer.Internals (Integer(..)) where +#include "MachDeps.h" +module GHC.Integer.Internals ( + Integer(..), -import GHC.Prim (Int#, ByteArray#) + cmpInteger#, + cmpIntegerInt#, + + plusInteger#, + minusInteger#, + timesInteger#, + + quotRemInteger#, + quotInteger#, + remInteger#, + divModInteger#, + divExactInteger#, + + gcdInteger#, + gcdIntegerInt#, + gcdInt#, + + decodeDouble#, + + int2Integer#, + integer2Int#, + + word2Integer#, + integer2Word#, + + andInteger#, + orInteger#, + xorInteger#, + complementInteger#, + +#if WORD_SIZE_IN_BITS < 64 + int64ToInteger#, + word64ToInteger#, +#endif + +#ifndef WORD_SIZE_IN_BITS +#error WORD_SIZE_IN_BITS not defined!!! +#endif + + ) where + +import GHC.Prim (Int#, Word#, Double#, ByteArray#) + +#if WORD_SIZE_IN_BITS < 64 +import GHC.Prim (Int64#, Word64#) +#endif -- Double isn't available yet, and we shouldn't be using defaults anyway: default () @@ -19,3 +68,126 @@ data Integer foreign type dotnet "BigInteger" BigInteger #endif + +-- | Returns -1,0,1 according as first argument is less than, equal to, or greater than second argument. +-- +foreign import prim "integer_cmm_cmpIntegerzh" cmpInteger# + :: Int# -> ByteArray# -> Int# -> ByteArray# -> Int# + +-- | Returns -1,0,1 according as first argument is less than, equal to, or greater than second argument, which +-- is an ordinary Int\#. +foreign import prim "integer_cmm_cmpIntegerIntzh" cmpIntegerInt# + :: Int# -> ByteArray# -> Int# -> Int# + +-- | +-- +foreign import prim "integer_cmm_plusIntegerzh" plusInteger# + :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#, ByteArray# #) + +-- | +-- +foreign import prim "integer_cmm_minusIntegerzh" minusInteger# + :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#, ByteArray# #) + +-- | +-- +foreign import prim "integer_cmm_timesIntegerzh" timesInteger# + :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#, ByteArray# #) + +-- | Compute div and mod simultaneously, where div rounds towards negative +-- infinity and\ @(q,r) = divModInteger#(x,y)@ implies +-- @plusInteger# (timesInteger# q y) r = x@. +-- +foreign import prim "integer_cmm_quotRemIntegerzh" quotRemInteger# + :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#, ByteArray#, Int#, ByteArray# #) + +-- | Rounds towards zero. +-- +foreign import prim "integer_cmm_quotIntegerzh" quotInteger# + :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#, ByteArray# #) + +-- | Satisfies \texttt{plusInteger\# (timesInteger\# (quotInteger\# x y) y) (remInteger\# x y) == x}. +-- +foreign import prim "integer_cmm_remIntegerzh" remInteger# + :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#, ByteArray# #) + +-- | Compute div and mod simultaneously, where div rounds towards negative infinity +-- and\texttt{(q,r) = divModInteger\#(x,y)} implies \texttt{plusInteger\# (timesInteger\# q y) r = x}. +-- +foreign import prim "integer_cmm_divModIntegerzh" divModInteger# + :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#, ByteArray#, Int#, ByteArray# #) + +-- | Divisor is guaranteed to be a factor of dividend. +-- +foreign import prim "integer_cmm_divExactIntegerzh" divExactInteger# + :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#, ByteArray# #) + +-- | Greatest common divisor. +-- +foreign import prim "integer_cmm_gcdIntegerzh" gcdInteger# + :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#, ByteArray# #) + +-- | Greatest common divisor, where second argument is an ordinary {\tt Int\#}. +-- +foreign import prim "integer_cmm_gcdIntegerIntzh" gcdIntegerInt# + :: Int# -> ByteArray# -> Int# -> Int# + +-- | +-- +foreign import prim "integer_cmm_gcdIntzh" gcdInt# + :: Int# -> Int# -> Int# + +-- | Convert to arbitrary-precision integer. +-- First {\tt Int\#} in result is the exponent; second {\tt Int\#} and {\tt ByteArray\#} +-- represent an {\tt Integer\#} holding the mantissa. +-- +foreign import prim "integer_cmm_decodeDoublezh" decodeDouble# + :: Double# -> (# Int#, Int#, ByteArray# #) + +-- | +-- +foreign import prim "integer_cmm_int2Integerzh" int2Integer# + :: Int# -> (# Int#, ByteArray# #) + +-- | +-- +foreign import prim "integer_cmm_integer2Intzh" integer2Int# + :: Int# -> ByteArray# -> Int# + +-- | +-- +foreign import prim "integer_cmm_word2Integerzh" word2Integer# + :: Word# -> (# Int#, ByteArray# #) + +-- | +-- +foreign import prim "integer_cmm_integer2Wordzh" integer2Word# + :: Int# -> ByteArray# -> Word# + +-- | +-- +foreign import prim "integer_cmm_andIntegerzh" andInteger# + :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#, ByteArray# #) + +-- | +-- +foreign import prim "integer_cmm_orIntegerzh" orInteger# + :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#, ByteArray# #) + +-- | +-- +foreign import prim "integer_cmm_xorIntegerzh" xorInteger# + :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#, ByteArray# #) + +-- | +-- +foreign import prim "integer_cmm_complementIntegerzh" complementInteger# + :: Int# -> ByteArray# -> (# Int#, ByteArray# #) + +#if WORD_SIZE_IN_BITS < 64 +foreign import prim "integer_cmm_int64ToIntegerzh" int64ToInteger# + :: Int64# -> (# Int#, ByteArray# #) + +foreign import prim "integer_cmm_word64ToIntegerzh" word64ToInteger# + :: Word64# -> (# Int#, ByteArray# #) +#endif diff --git a/libraries/integer-gmp/cbits/alloc.c b/libraries/integer-gmp/cbits/alloc.c new file mode 100644 index 0000000000..27713865eb --- /dev/null +++ b/libraries/integer-gmp/cbits/alloc.c @@ -0,0 +1,105 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team, 1998-2008 + * + * ---------------------------------------------------------------------------*/ + +/* TODO: do we need PosixSource.h ? it lives in rts/ not public includes/ */ +/* #include "PosixSource.h" */ +#include "Rts.h" + +#include "gmp.h" + +static void * stgAllocForGMP (size_t size_in_bytes); +static void * stgReallocForGMP (void *ptr, size_t old_size, size_t new_size); +static void stgDeallocForGMP (void *ptr STG_UNUSED, size_t size STG_UNUSED); + +static void initAllocForGMP( void ) __attribute__((constructor)); + +/* ----------------------------------------------------------------------------- + Tell GMP to use our custom heap allocation functions. + + Our allocation strategy is to use GHC heap allocations rather than malloc + and co. The heap objects we use are ByteArray#s which of course have their + usual header word or two. But gmp doesn't know about ghc heap objects and + header words. So our allocator has to make a ByteArray# and return a pointer + to its interior! When the gmp function returns we recieve that interior + pointer. Then we look back a couple words to get the propper ByteArray# + pointer (which then gets returned as a ByteArray# and thus get tracked + properly by the GC). + + WARNING!! WARNING!! WARNING!! + + It is absolutely vital that this initialisation function be called before + any of the gmp functions are called. We'd still be looking back a couple + words for the ByteArray# header, but if we were accidentally using malloc + then it'd all go wrong because of course there would be no ByteArray# + header, just malloc's own internal book keeping info. To make things worse + we would not notice immediately, it'd only be when the GC comes round to + inspect things... BANG! + + > Program received signal SIGSEGV, Segmentation fault. + > [Switching to Thread 0x7f5a9ebc76f0 (LWP 17838)] + > evacuate1 (p=0x7f5a99acd2e0) at rts/sm/Evac.c:375 + > 375 switch (info->type) { + + -------------------------------------------------------------------------- */ + +static void initAllocForGMP( void ) +{ + mp_set_memory_functions(stgAllocForGMP, stgReallocForGMP, stgDeallocForGMP); +} + + +/* ----------------------------------------------------------------------------- + Allocation functions for GMP. + + These all use the allocate() interface - we can't have any garbage + collection going on during a gmp operation, so we use allocate() + which always succeeds. The gmp operations which might need to + allocate will ask the storage manager (via doYouWantToGC()) whether + a garbage collection is required, in case we get into a loop doing + only allocate() style allocation. + -------------------------------------------------------------------------- */ + +static void * +stgAllocForGMP (size_t size_in_bytes) +{ + StgArrWords* arr; + nat data_size_in_words, total_size_in_words; + + /* round up to a whole number of words */ + data_size_in_words = (size_in_bytes + sizeof(W_) + 1) / sizeof(W_); + total_size_in_words = sizeofW(StgArrWords) + data_size_in_words; + + /* allocate and fill it in. */ + arr = (StgArrWords *)allocateLocal(rts_unsafeGetMyCapability(), total_size_in_words); + SET_ARR_HDR(arr, &stg_ARR_WORDS_info, CCCS, data_size_in_words); + + /* and return a ptr to the goods inside the array */ + return arr->payload; +} + +static void * +stgReallocForGMP (void *ptr, size_t old_size, size_t new_size) +{ + size_t min_size; + void *new_stuff_ptr = stgAllocForGMP(new_size); + nat i = 0; + char *p = (char *) ptr; + char *q = (char *) new_stuff_ptr; + + min_size = old_size < new_size ? old_size : new_size; + /* TODO: use memcpy */ + for (; i < min_size; i++, p++, q++) { + *q = *p; + } + + return(new_stuff_ptr); +} + +static void +stgDeallocForGMP (void *ptr STG_UNUSED, size_t size STG_UNUSED) +{ + /* easy for us: the garbage collector does the dealloc'n */ +} diff --git a/libraries/integer-gmp/cbits/cbits.c b/libraries/integer-gmp/cbits/cbits.c new file mode 100644 index 0000000000..4b9fd01480 --- /dev/null +++ b/libraries/integer-gmp/cbits/cbits.c @@ -0,0 +1,13 @@ + +/* We combine the two C files here. + * + * There is actually a good reason for this, really! + * The alloc file contains a __attribute__((constructor)) function. We must + * have this function in the same .o file as other stuff that actually gets + * used otherwise the static linker doesn't bother to pull in the .o file + * containing the constructor function. While we could just stick them in + * the same .c file that'd be a bit annoying. So we combine them here. + * */ + +#include "alloc.c" +#include "float.c" diff --git a/libraries/integer-gmp/cbits/float.c b/libraries/integer-gmp/cbits/float.c index efe2755f91..ec82346455 100644 --- a/libraries/integer-gmp/cbits/float.c +++ b/libraries/integer-gmp/cbits/float.c @@ -62,7 +62,7 @@ #define __abs(a) (( (a) >= 0 ) ? (a) : (-(a))) StgDouble -__encodeDouble (I_ size, StgByteArray ba, I_ e) /* result = s * 2^e */ +integer_cbits_encodeDouble (I_ size, StgByteArray ba, I_ e) /* result = s * 2^e */ { StgDouble r; const mp_limb_t *const arr = (const mp_limb_t *)ba; @@ -84,7 +84,7 @@ __encodeDouble (I_ size, StgByteArray ba, I_ e) /* result = s * 2^e */ } StgFloat -__encodeFloat (I_ size, StgByteArray ba, I_ e) /* result = s * 2^e */ +integer_cbits_encodeFloat (I_ size, StgByteArray ba, I_ e) /* result = s * 2^e */ { StgFloat r; const mp_limb_t *arr = (const mp_limb_t *)ba; @@ -104,3 +104,65 @@ __encodeFloat (I_ size, StgByteArray ba, I_ e) /* result = s * 2^e */ return r; } + +/* This only supports IEEE floating point */ + +void +integer_cbits_decodeDouble (MP_INT *man, I_ *exp, StgDouble dbl) +{ + /* Do some bit fiddling on IEEE */ + unsigned int low, high; /* assuming 32 bit ints */ + int sign, iexp; + union { double d; unsigned int i[2]; } u; /* assuming 32 bit ints, 64 bit double */ + + ASSERT(sizeof(unsigned int ) == 4 ); + ASSERT(sizeof(dbl ) == SIZEOF_DOUBLE); + ASSERT(sizeof(man->_mp_d[0]) == SIZEOF_LIMB_T); + ASSERT(DNBIGIT*SIZEOF_LIMB_T >= SIZEOF_DOUBLE); + + u.d = dbl; /* grab chunks of the double */ + low = u.i[L]; + high = u.i[H]; + + /* we know the MP_INT* passed in has size zero, so we realloc + no matter what. + */ + man->_mp_alloc = DNBIGIT; + + if (low == 0 && (high & ~DMSBIT) == 0) { + man->_mp_size = 0; + *exp = 0L; + } else { + man->_mp_size = DNBIGIT; + iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP; + sign = high; + + high &= DHIGHBIT-1; + if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */ + high |= DHIGHBIT; + else { + iexp++; + /* A denorm, normalize the mantissa */ + while (! (high & DHIGHBIT)) { + high <<= 1; + if (low & DMSBIT) + high++; + low <<= 1; + iexp--; + } + } + *exp = (I_) iexp; +#if DNBIGIT == 2 + man->_mp_d[0] = (mp_limb_t)low; + man->_mp_d[1] = (mp_limb_t)high; +#else +#if DNBIGIT == 1 + man->_mp_d[0] = ((mp_limb_t)high) << 32 | (mp_limb_t)low; +#else +#error Cannot cope with DNBIGIT +#endif +#endif + if (sign < 0) + man->_mp_size = -man->_mp_size; + } +} diff --git a/libraries/integer-gmp/cbits/gmp-wrappers.cmm b/libraries/integer-gmp/cbits/gmp-wrappers.cmm new file mode 100644 index 0000000000..fd1e9c49d0 --- /dev/null +++ b/libraries/integer-gmp/cbits/gmp-wrappers.cmm @@ -0,0 +1,549 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team, 1998-2004 + * + * Out-of-line primitive operations + * + * This file contains the implementations of all the primitive + * operations ("primops") which are not expanded inline. See + * ghc/compiler/prelude/primops.txt.pp for a list of all the primops; + * this file contains code for most of those with the attribute + * out_of_line=True. + * + * Entry convention: the entry convention for a primop is that all the + * args are in Stg registers (R1, R2, etc.). This is to make writing + * the primops easier. (see compiler/codeGen/CgCallConv.hs). + * + * Return convention: results from a primop are generally returned + * using the ordinary unboxed tuple return convention. The C-- parser + * implements the RET_xxxx() macros to perform unboxed-tuple returns + * based on the prevailing return convention. + * + * This file is written in a subset of C--, extended with various + * features specific to GHC. It is compiled by GHC directly. For the + * syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y. + * + * ---------------------------------------------------------------------------*/ + +#include "Cmm.h" +#include "DerivedConstants.h" + +#ifdef __PIC__ +#ifndef mingw32_HOST_OS +import __gmpz_init; +import __gmpz_add; +import __gmpz_sub; +import __gmpz_mul; +import __gmpz_gcd; +import __gmpn_gcd_1; +import __gmpn_cmp; +import __gmpz_tdiv_q; +import __gmpz_tdiv_r; +import __gmpz_tdiv_qr; +import __gmpz_fdiv_qr; +import __gmpz_divexact; +import __gmpz_and; +import __gmpz_xor; +import __gmpz_ior; +import __gmpz_com; +#endif +#endif + +/* ----------------------------------------------------------------------------- + Arbitrary-precision Integer operations. + + There are some assumptions in this code that mp_limb_t == W_. This is + the case for all the platforms that GHC supports, currently. + -------------------------------------------------------------------------- */ + +integer_cmm_int2Integerzh +{ + /* arguments: R1 = Int# */ + + W_ val, s, p; /* to avoid aliasing */ + + val = R1; + ALLOC_PRIM( SIZEOF_StgArrWords + WDS(1), NO_PTRS, integer_cmm_int2Integerzh ); + + p = Hp - SIZEOF_StgArrWords; + SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]); + StgArrWords_words(p) = 1; + + /* mpz_set_si is inlined here, makes things simpler */ + if (%lt(val,0)) { + s = -1; + Hp(0) = -val; + } else { + if (%gt(val,0)) { + s = 1; + Hp(0) = val; + } else { + s = 0; + } + } + + /* returns (# size :: Int#, + data :: ByteArray# + #) + */ + RET_NP(s,p); +} + +integer_cmm_word2Integerzh +{ + /* arguments: R1 = Word# */ + + W_ val, s, p; /* to avoid aliasing */ + + val = R1; + + ALLOC_PRIM( SIZEOF_StgArrWords + WDS(1), NO_PTRS, integer_cmm_word2Integerzh); + + p = Hp - SIZEOF_StgArrWords; + SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]); + StgArrWords_words(p) = 1; + + if (val != 0) { + s = 1; + W_[Hp] = val; + } else { + s = 0; + } + + /* returns (# size :: Int#, + data :: ByteArray# #) + */ + RET_NP(s,p); +} + + +/* + * 'long long' primops for converting to/from Integers. + */ + +#ifdef SUPPORT_LONG_LONGS + +integer_cmm_int64ToIntegerzh +{ + /* arguments: L1 = Int64# */ + + L_ val; + W_ hi, lo, s, neg, words_needed, p; + + val = L1; + neg = 0; + + hi = TO_W_(val >> 32); + lo = TO_W_(val); + + if ( hi == 0 || (hi == 0xFFFFFFFF && lo != 0) ) { + // minimum is one word + words_needed = 1; + } else { + words_needed = 2; + } + + ALLOC_PRIM( SIZEOF_StgArrWords + WDS(words_needed), + NO_PTRS, integer_cmm_int64ToIntegerzh ); + + p = Hp - SIZEOF_StgArrWords - WDS(words_needed) + WDS(1); + SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]); + StgArrWords_words(p) = words_needed; + + if ( %lt(hi,0) ) { + neg = 1; + lo = -lo; + if(lo == 0) { + hi = -hi; + } else { + hi = -hi - 1; + } + } + + if ( words_needed == 2 ) { + s = 2; + Hp(-1) = lo; + Hp(0) = hi; + } else { + if ( lo != 0 ) { + s = 1; + Hp(0) = lo; + } else /* val==0 */ { + s = 0; + } + } + if ( neg != 0 ) { + s = -s; + } + + /* returns (# size :: Int#, + data :: ByteArray# #) + */ + RET_NP(s,p); +} +integer_cmm_word64ToIntegerzh +{ + /* arguments: L1 = Word64# */ + + L_ val; + W_ hi, lo, s, words_needed, p; + + val = L1; + hi = TO_W_(val >> 32); + lo = TO_W_(val); + + if ( hi != 0 ) { + words_needed = 2; + } else { + words_needed = 1; + } + + ALLOC_PRIM( SIZEOF_StgArrWords + WDS(words_needed), + NO_PTRS, integer_cmm_word64ToIntegerzh ); + + p = Hp - SIZEOF_StgArrWords - WDS(words_needed) + WDS(1); + SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]); + StgArrWords_words(p) = words_needed; + + if ( hi != 0 ) { + s = 2; + Hp(-1) = lo; + Hp(0) = hi; + } else { + if ( lo != 0 ) { + s = 1; + Hp(0) = lo; + } else /* val==0 */ { + s = 0; + } + } + + /* returns (# size :: Int#, + data :: ByteArray# #) + */ + RET_NP(s,p); +} + +#endif /* SUPPORT_LONG_LONGS */ + +#define GMP_TAKE2_RET1(name,mp_fun) \ +name \ +{ \ + CInt s1, s2; \ + W_ d1, d2; \ + W_ mp_tmp1; \ + W_ mp_tmp2; \ + W_ mp_result1; \ + W_ mp_result2; \ + \ + /* call doYouWantToGC() */ \ + MAYBE_GC(R2_PTR & R4_PTR, name); \ + \ + STK_CHK_GEN( 4 * SIZEOF_MP_INT, R2_PTR & R4_PTR, name ); \ + \ + s1 = W_TO_INT(R1); \ + d1 = R2; \ + s2 = W_TO_INT(R3); \ + d2 = R4; \ + \ + mp_tmp1 = Sp - 1 * SIZEOF_MP_INT; \ + mp_tmp2 = Sp - 2 * SIZEOF_MP_INT; \ + mp_result1 = Sp - 3 * SIZEOF_MP_INT; \ + mp_result2 = Sp - 4 * SIZEOF_MP_INT; \ + MP_INT__mp_alloc(mp_tmp1) = W_TO_INT(StgArrWords_words(d1)); \ + MP_INT__mp_size(mp_tmp1) = (s1); \ + MP_INT__mp_d(mp_tmp1) = BYTE_ARR_CTS(d1); \ + MP_INT__mp_alloc(mp_tmp2) = W_TO_INT(StgArrWords_words(d2)); \ + MP_INT__mp_size(mp_tmp2) = (s2); \ + MP_INT__mp_d(mp_tmp2) = BYTE_ARR_CTS(d2); \ + \ + foreign "C" __gmpz_init(mp_result1 "ptr") []; \ + \ + /* Perform the operation */ \ + foreign "C" mp_fun(mp_result1 "ptr",mp_tmp1 "ptr",mp_tmp2 "ptr") []; \ + \ + RET_NP(TO_W_(MP_INT__mp_size(mp_result1)), \ + MP_INT__mp_d(mp_result1) - SIZEOF_StgArrWords); \ +} + +#define GMP_TAKE1_RET1(name,mp_fun) \ +name \ +{ \ + CInt s1; \ + W_ d1; \ + W_ mp_tmp1; \ + W_ mp_result1; \ + \ + /* call doYouWantToGC() */ \ + MAYBE_GC(R2_PTR, name); \ + \ + STK_CHK_GEN( 2 * SIZEOF_MP_INT, R2_PTR, name ); \ + \ + d1 = R2; \ + s1 = W_TO_INT(R1); \ + \ + mp_tmp1 = Sp - 1 * SIZEOF_MP_INT; \ + mp_result1 = Sp - 2 * SIZEOF_MP_INT; \ + MP_INT__mp_alloc(mp_tmp1) = W_TO_INT(StgArrWords_words(d1)); \ + MP_INT__mp_size(mp_tmp1) = (s1); \ + MP_INT__mp_d(mp_tmp1) = BYTE_ARR_CTS(d1); \ + \ + foreign "C" __gmpz_init(mp_result1 "ptr") []; \ + \ + /* Perform the operation */ \ + foreign "C" mp_fun(mp_result1 "ptr",mp_tmp1 "ptr") []; \ + \ + RET_NP(TO_W_(MP_INT__mp_size(mp_result1)), \ + MP_INT__mp_d(mp_result1) - SIZEOF_StgArrWords); \ +} + +#define GMP_TAKE2_RET2(name,mp_fun) \ +name \ +{ \ + CInt s1, s2; \ + W_ d1, d2; \ + W_ mp_tmp1; \ + W_ mp_tmp2; \ + W_ mp_result1; \ + W_ mp_result2; \ + \ + /* call doYouWantToGC() */ \ + MAYBE_GC(R2_PTR & R4_PTR, name); \ + \ + STK_CHK_GEN( 4 * SIZEOF_MP_INT, R2_PTR & R4_PTR, name ); \ + \ + s1 = W_TO_INT(R1); \ + d1 = R2; \ + s2 = W_TO_INT(R3); \ + d2 = R4; \ + \ + mp_tmp1 = Sp - 1 * SIZEOF_MP_INT; \ + mp_tmp2 = Sp - 2 * SIZEOF_MP_INT; \ + mp_result1 = Sp - 3 * SIZEOF_MP_INT; \ + mp_result2 = Sp - 4 * SIZEOF_MP_INT; \ + MP_INT__mp_alloc(mp_tmp1) = W_TO_INT(StgArrWords_words(d1)); \ + MP_INT__mp_size(mp_tmp1) = (s1); \ + MP_INT__mp_d(mp_tmp1) = BYTE_ARR_CTS(d1); \ + MP_INT__mp_alloc(mp_tmp2) = W_TO_INT(StgArrWords_words(d2)); \ + MP_INT__mp_size(mp_tmp2) = (s2); \ + MP_INT__mp_d(mp_tmp2) = BYTE_ARR_CTS(d2); \ + \ + foreign "C" __gmpz_init(mp_result1 "ptr") []; \ + foreign "C" __gmpz_init(mp_result2 "ptr") []; \ + \ + /* Perform the operation */ \ + foreign "C" mp_fun(mp_result1 "ptr",mp_result2 "ptr",mp_tmp1 "ptr",mp_tmp2 "ptr") []; \ + \ + RET_NPNP(TO_W_(MP_INT__mp_size(mp_result1)), \ + MP_INT__mp_d(mp_result1) - SIZEOF_StgArrWords, \ + TO_W_(MP_INT__mp_size(mp_result2)), \ + MP_INT__mp_d(mp_result2) - SIZEOF_StgArrWords); \ +} + +GMP_TAKE2_RET1(integer_cmm_plusIntegerzh, __gmpz_add) +GMP_TAKE2_RET1(integer_cmm_minusIntegerzh, __gmpz_sub) +GMP_TAKE2_RET1(integer_cmm_timesIntegerzh, __gmpz_mul) +GMP_TAKE2_RET1(integer_cmm_gcdIntegerzh, __gmpz_gcd) +GMP_TAKE2_RET1(integer_cmm_quotIntegerzh, __gmpz_tdiv_q) +GMP_TAKE2_RET1(integer_cmm_remIntegerzh, __gmpz_tdiv_r) +GMP_TAKE2_RET1(integer_cmm_divExactIntegerzh, __gmpz_divexact) +GMP_TAKE2_RET1(integer_cmm_andIntegerzh, __gmpz_and) +GMP_TAKE2_RET1(integer_cmm_orIntegerzh, __gmpz_ior) +GMP_TAKE2_RET1(integer_cmm_xorIntegerzh, __gmpz_xor) +GMP_TAKE1_RET1(integer_cmm_complementIntegerzh, __gmpz_com) + +GMP_TAKE2_RET2(integer_cmm_quotRemIntegerzh, __gmpz_tdiv_qr) +GMP_TAKE2_RET2(integer_cmm_divModIntegerzh, __gmpz_fdiv_qr) + +integer_cmm_gcdIntzh +{ + /* R1 = the first Int#; R2 = the second Int# */ + W_ r; + W_ mp_tmp_w; + + STK_CHK_GEN( 1 * SIZEOF_MP_INT, NO_PTRS, integer_cmm_gcdIntzh ); + + mp_tmp_w = Sp - 1 * SIZEOF_MP_INT; + + W_[mp_tmp_w] = R1; + (r) = foreign "C" __gmpn_gcd_1(mp_tmp_w "ptr", 1, R2) []; + + R1 = r; + /* Result parked in R1, return via info-pointer at TOS */ + jump %ENTRY_CODE(Sp(0)); +} + + +integer_cmm_gcdIntegerIntzh +{ + /* R1 = s1; R2 = d1; R3 = the int */ + W_ s1; + (s1) = foreign "C" __gmpn_gcd_1( BYTE_ARR_CTS(R2) "ptr", R1, R3) []; + R1 = s1; + + /* Result parked in R1, return via info-pointer at TOS */ + jump %ENTRY_CODE(Sp(0)); +} + + +integer_cmm_cmpIntegerIntzh +{ + /* R1 = s1; R2 = d1; R3 = the int */ + W_ usize, vsize, v_digit, u_digit; + + usize = R1; + vsize = 0; + v_digit = R3; + + // paraphrased from __gmpz_cmp_si() in the GMP sources + if (%gt(v_digit,0)) { + vsize = 1; + } else { + if (%lt(v_digit,0)) { + vsize = -1; + v_digit = -v_digit; + } + } + + if (usize != vsize) { + R1 = usize - vsize; + jump %ENTRY_CODE(Sp(0)); + } + + if (usize == 0) { + R1 = 0; + jump %ENTRY_CODE(Sp(0)); + } + + u_digit = W_[BYTE_ARR_CTS(R2)]; + + if (u_digit == v_digit) { + R1 = 0; + jump %ENTRY_CODE(Sp(0)); + } + + if (%gtu(u_digit,v_digit)) { // NB. unsigned: these are mp_limb_t's + R1 = usize; + } else { + R1 = -usize; + } + + jump %ENTRY_CODE(Sp(0)); +} + +integer_cmm_cmpIntegerzh +{ + /* R1 = s1; R2 = d1; R3 = s2; R4 = d2 */ + W_ usize, vsize, size, up, vp; + CInt cmp; + + // paraphrased from __gmpz_cmp() in the GMP sources + usize = R1; + vsize = R3; + + if (usize != vsize) { + R1 = usize - vsize; + jump %ENTRY_CODE(Sp(0)); + } + + if (usize == 0) { + R1 = 0; + jump %ENTRY_CODE(Sp(0)); + } + + if (%lt(usize,0)) { // NB. not <, which is unsigned + size = -usize; + } else { + size = usize; + } + + up = BYTE_ARR_CTS(R2); + vp = BYTE_ARR_CTS(R4); + + (cmp) = foreign "C" __gmpn_cmp(up "ptr", vp "ptr", size) []; + + if (cmp == 0 :: CInt) { + R1 = 0; + jump %ENTRY_CODE(Sp(0)); + } + + if (%lt(cmp,0 :: CInt) == %lt(usize,0)) { + R1 = 1; + } else { + R1 = (-1); + } + /* Result parked in R1, return via info-pointer at TOS */ + jump %ENTRY_CODE(Sp(0)); +} + +integer_cmm_integer2Intzh +{ + /* R1 = s; R2 = d */ + W_ r, s; + + s = R1; + if (s == 0) { + r = 0; + } else { + r = W_[R2 + SIZEOF_StgArrWords]; + if (%lt(s,0)) { + r = -r; + } + } + /* Result parked in R1, return via info-pointer at TOS */ + R1 = r; + jump %ENTRY_CODE(Sp(0)); +} + +integer_cmm_integer2Wordzh +{ + /* R1 = s; R2 = d */ + W_ r, s; + + s = R1; + if (s == 0) { + r = 0; + } else { + r = W_[R2 + SIZEOF_StgArrWords]; + if (%lt(s,0)) { + r = -r; + } + } + /* Result parked in R1, return via info-pointer at TOS */ + R1 = r; + jump %ENTRY_CODE(Sp(0)); +} + +#define DOUBLE_MANTISSA_SIZE SIZEOF_DOUBLE +#define ARR_SIZE (SIZEOF_StgArrWords + DOUBLE_MANTISSA_SIZE) + +integer_cmm_decodeDoublezh +{ + D_ arg; + W_ p; + W_ mp_tmp1; + W_ mp_tmp_w; + + STK_CHK_GEN( 2 * SIZEOF_MP_INT, NO_PTRS, integer_cmm_decodeDoublezh ); + + mp_tmp1 = Sp - 1 * SIZEOF_MP_INT; + mp_tmp_w = Sp - 2 * SIZEOF_MP_INT; + + /* arguments: D1 = Double# */ + arg = D1; + + ALLOC_PRIM( ARR_SIZE, NO_PTRS, integer_cmm_decodeDoublezh ); + + /* Be prepared to tell Lennart-coded integer_cbits_decodeDouble + where mantissa.d can be put (it does not care about the rest) */ + p = Hp - ARR_SIZE + WDS(1); + SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]); + StgArrWords_words(p) = BYTES_TO_WDS(DOUBLE_MANTISSA_SIZE); + MP_INT__mp_d(mp_tmp1) = BYTE_ARR_CTS(p); + + /* Perform the operation */ + foreign "C" integer_cbits_decodeDouble(mp_tmp1 "ptr", mp_tmp_w "ptr",arg) []; + + /* returns: (Int# (expn), Int#, ByteArray#) */ + RET_NNP(W_[mp_tmp_w], TO_W_(MP_INT__mp_size(mp_tmp1)), p); +} diff --git a/libraries/integer-gmp/integer.cabal b/libraries/integer-gmp/integer.cabal index 3b36812625..ca323a48dd 100644 --- a/libraries/integer-gmp/integer.cabal +++ b/libraries/integer-gmp/integer.cabal @@ -10,6 +10,10 @@ description: cabal-version: >=1.6 build-type: Simple +extra-source-files: + cbits/float.c + cbits/alloc.c + source-repository head type: darcs location: http://darcs.haskell.org/packages/integer-gmp/ @@ -23,5 +27,6 @@ Library { -- We need to set the package name to integer (without a version number) -- as it's magic. ghc-options: -package-name integer - c-sources: cbits/float.c + extra-libraries: gmp + c-sources: cbits/cbits.c } |