diff --git a/GHC/Integer.lhs b/GHC/Integer.lhs index c32da603a3272036bef309c31f94cbf547766c4e..971c7e6895708123a3895779a247ad8384e339fa 100644 --- a/GHC/Integer.lhs +++ b/GHC/Integer.lhs @@ -40,6 +40,7 @@ module GHC.Integer ( encodeDoubleInteger, decodeDoubleInteger, doubleFromInteger, gcdInteger, lcmInteger, andInteger, orInteger, xorInteger, complementInteger, + shiftLInteger, shiftRInteger, hashInteger, ) where @@ -67,6 +68,7 @@ import GHC.Integer.GMP.Internals ( decodeDouble#, int2Integer#, integer2Int#, word2Integer#, integer2Word#, andInteger#, orInteger#, xorInteger#, complementInteger#, + mul2ExpInteger#, fdivQ2ExpInteger#, #if WORD_SIZE_IN_BITS < 64 int64ToInteger#, integerToInt64#, word64ToInteger#, integerToWord64#, @@ -515,6 +517,16 @@ complementInteger (S# x) = S# (word2Int# (int2Word# x `xor#` int2Word# (0# -# 1#))) complementInteger (J# s d) = case complementInteger# s d of (# s', d' #) -> J# s' d' + +shiftLInteger :: Integer -> Int# -> Integer +shiftLInteger j@(S# _) i = shiftLInteger (toBig j) i +shiftLInteger (J# s d) i = case mul2ExpInteger# s d i of + (# s', d' #) -> J# s' d' + +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' \end{code} %********************************************************* diff --git a/GHC/Integer/GMP/Internals.hs b/GHC/Integer/GMP/Internals.hs index f05a8d6b8c030468a7eefff30a16d0ba941edf1c..e3fd3930ebe11325c2106bfb37b9474ca81df234 100644 --- a/GHC/Integer/GMP/Internals.hs +++ b/GHC/Integer/GMP/Internals.hs @@ -37,6 +37,9 @@ module GHC.Integer.GMP.Internals ( xorInteger#, complementInteger#, + mul2ExpInteger#, + fdivQ2ExpInteger#, + #if WORD_SIZE_IN_BITS < 64 int64ToInteger#, integerToInt64#, word64ToInteger#, integerToWord64#, @@ -168,6 +171,16 @@ foreign import prim "integer_cmm_orIntegerzh" orInteger# foreign import prim "integer_cmm_xorIntegerzh" xorInteger# :: Int# -> ByteArray# -> Int# -> ByteArray# -> (# Int#, ByteArray# #) +-- | +-- +foreign import prim "integer_cmm_mul2ExpIntegerzh" mul2ExpInteger# + :: Int# -> ByteArray# -> Int# -> (# Int#, ByteArray# #) + +-- | +-- +foreign import prim "integer_cmm_fdivQ2ExpIntegerzh" fdivQ2ExpInteger# + :: Int# -> ByteArray# -> Int# -> (# Int#, ByteArray# #) + -- | -- foreign import prim "integer_cmm_complementIntegerzh" complementInteger# diff --git a/cbits/gmp-wrappers.cmm b/cbits/gmp-wrappers.cmm index 4c0ec4addbe4653cbad8bd82cf392b7498771780..036fc6fdfbda792393599d30f3d08e5a478bf431 100644 --- a/cbits/gmp-wrappers.cmm +++ b/cbits/gmp-wrappers.cmm @@ -264,6 +264,39 @@ name \ MP_INT__mp_d(mp_result1) - SIZEOF_StgArrWords); \ } +#define GMP_TAKE1_UL1_RET1(name,mp_fun) \ +name \ +{ \ + CInt s1; \ + W_ d1; \ + CLong ul; \ + W_ mp_tmp; \ + W_ mp_result; \ + \ + /* call doYouWantToGC() */ \ + MAYBE_GC(R2_PTR & R4_PTR, name); \ + \ + STK_CHK_GEN( 2 * SIZEOF_MP_INT, R2_PTR, name ); \ + \ + s1 = W_TO_INT(R1); \ + d1 = R2; \ + ul = R3; \ + \ + mp_tmp = Sp - 1 * SIZEOF_MP_INT; \ + mp_result = Sp - 2 * SIZEOF_MP_INT; \ + MP_INT__mp_alloc(mp_tmp) = W_TO_INT(StgArrWords_words(d1)); \ + MP_INT__mp_size(mp_tmp) = (s1); \ + MP_INT__mp_d(mp_tmp) = BYTE_ARR_CTS(d1); \ + \ + foreign "C" __gmpz_init(mp_result "ptr") []; \ + \ + /* Perform the operation */ \ + foreign "C" mp_fun(mp_result "ptr",mp_tmp "ptr", ul) []; \ + \ + RET_NP(TO_W_(MP_INT__mp_size(mp_result)), \ + MP_INT__mp_d(mp_result) - SIZEOF_StgArrWords); \ +} + #define GMP_TAKE1_RET1(name,mp_fun) \ name \ { \ @@ -348,6 +381,8 @@ 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_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) GMP_TAKE2_RET2(integer_cmm_quotRemIntegerzh, __gmpz_tdiv_qr)