[commit: integer-gmp] master: Define testBitInteger; part of #3489 (225ec4c)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/integer-gmp

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/225ec4c24be47acb8eaef30a61bd24864ce48f9a

>---------------------------------------------------------------

commit 225ec4c24be47acb8eaef30a61bd24864ce48f9a
Author: Ian Lynagh <ian at well-typed.com>
Date:   Sun Aug 5 15:55:32 2012 +0100

    Define testBitInteger; part of #3489
    
    Based on a patch from pumpkingod at gmail.com

>---------------------------------------------------------------

 GHC/Integer.lhs         |    2 +-
 GHC/Integer/GMP/Prim.hs |    6 ++++++
 GHC/Integer/Type.lhs    |    7 ++++++-
 cbits/gmp-wrappers.cmm  |   31 +++++++++++++++++++++++++++++++
 4 files changed, 44 insertions(+), 2 deletions(-)

diff --git a/GHC/Integer.lhs b/GHC/Integer.lhs
index 57a97e1..3802aed 100644
--- a/GHC/Integer.lhs
+++ b/GHC/Integer.lhs
@@ -33,7 +33,7 @@ module GHC.Integer (
     encodeDoubleInteger, decodeDoubleInteger, doubleFromInteger,
     -- gcdInteger, lcmInteger,
     andInteger, orInteger, xorInteger, complementInteger,
-    shiftLInteger, shiftRInteger,
+    shiftLInteger, shiftRInteger, testBitInteger,
     hashInteger,
  ) where
 
diff --git a/GHC/Integer/GMP/Prim.hs b/GHC/Integer/GMP/Prim.hs
index 354d55f..cf3b97e 100644
--- a/GHC/Integer/GMP/Prim.hs
+++ b/GHC/Integer/GMP/Prim.hs
@@ -37,6 +37,7 @@ module GHC.Integer.GMP.Prim (
     xorInteger#,
     complementInteger#,
 
+    testBitInteger#,
     mul2ExpInteger#,
     fdivQ2ExpInteger#,
 
@@ -162,6 +163,11 @@ foreign import prim "integer_cmm_xorIntegerzh" xorInteger#
 
 -- |
 --
+foreign import prim "integer_cmm_testBitIntegerzh" testBitInteger#
+  :: Int# -> ByteArray# -> Int# -> Int#
+
+-- |
+--
 foreign import prim "integer_cmm_mul2ExpIntegerzh" mul2ExpInteger#
   :: Int# -> ByteArray# -> Int# -> (# Int#, ByteArray# #)
 
diff --git a/GHC/Integer/Type.lhs b/GHC/Integer/Type.lhs
index 464deb6..c953786 100644
--- a/GHC/Integer/Type.lhs
+++ b/GHC/Integer/Type.lhs
@@ -37,7 +37,7 @@ import GHC.Integer.GMP.Prim (
     decodeDouble#,
     int2Integer#, integer2Int#, word2Integer#, integer2Word#,
     andInteger#, orInteger#, xorInteger#, complementInteger#,
-    mul2ExpInteger#, fdivQ2ExpInteger#,
+    testBitInteger#, mul2ExpInteger#, fdivQ2ExpInteger#,
 #if WORD_SIZE_IN_BITS < 64
     int64ToInteger#,  integerToInt64#,
     word64ToInteger#, integerToWord64#,
@@ -553,6 +553,11 @@ shiftRInteger :: Integer -> Int# -> Integer
 shiftRInteger j@(S# _) i = shiftRInteger (toBig j) i
 shiftRInteger (J# s d) i = case fdivQ2ExpInteger# s d i of
                            (# s', d' #) -> J# s' d'
+
+{-# NOINLINE testBitInteger #-}
+testBitInteger :: Integer -> Int# -> Bool
+testBitInteger j@(S# _) i = testBitInteger (toBig j) i
+testBitInteger (J# s d) i = testBitInteger# s d i /=# 0#
 \end{code}
 
 %*********************************************************
diff --git a/cbits/gmp-wrappers.cmm b/cbits/gmp-wrappers.cmm
index ef2df30..7a5ce6c 100644
--- a/cbits/gmp-wrappers.cmm
+++ b/cbits/gmp-wrappers.cmm
@@ -299,6 +299,36 @@ name                                                                    \
          MP_INT__mp_d(mp_result) - SIZEOF_StgArrWords);                 \
 }
 
+#define GMP_TAKE1_UL1_RETI1(name,mp_fun)                                \
+name                                                                    \
+{                                                                       \
+  CInt s1;                                                              \
+  W_ d1;                                                                \
+  CLong ul;                                                             \
+  W_ mp_tmp;                                                            \
+  CInt res;                                                             \
+                                                                        \
+  /* call doYouWantToGC() */                                            \
+  MAYBE_GC(R2_PTR, name);                                               \
+                                                                        \
+  STK_CHK_GEN( SIZEOF_MP_INT, R2_PTR, name );                           \
+                                                                        \
+  s1 = W_TO_INT(R1);                                                    \
+  d1 = R2;                                                              \
+  ul = W_TO_LONG(R3);                                                   \
+                                                                        \
+  mp_tmp     = Sp - 1 * SIZEOF_MP_INT;                                  \
+  MP_INT__mp_alloc(mp_tmp) = W_TO_INT(BYTE_ARR_WDS(d1));                \
+  MP_INT__mp_size(mp_tmp)  = (s1);                                      \
+  MP_INT__mp_d(mp_tmp)     = BYTE_ARR_CTS(d1);                          \
+                                                                        \
+  /* Perform the operation */                                           \
+  (res) = foreign "C" mp_fun(mp_tmp "ptr", ul) [];                      \
+  R1 = res;                                                             \
+                                                                        \
+  jump %ENTRY_CODE(Sp(0));                                              \
+}
+
 #define GMP_TAKE1_RET1(name,mp_fun)                                     \
 name                                                                    \
 {                                                                       \
@@ -385,6 +415,7 @@ 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_UL1_RETI1(integer_cmm_testBitIntegerzh,   __gmpz_tstbit)
 GMP_TAKE1_UL1_RET1(integer_cmm_mul2ExpIntegerzh,    __gmpz_mul_2exp)
 GMP_TAKE1_UL1_RET1(integer_cmm_fdivQ2ExpIntegerzh,  __gmpz_fdiv_q_2exp)
 GMP_TAKE1_RET1(integer_cmm_complementIntegerzh,     __gmpz_com)