Add primops for shifting

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}
 
 %*********************************************************

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#

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)