[commit: ghc] wip/T7860: Implement {set, clear, complement}BitBigNat primitives (81d8897)
git at git.haskell.org
git at git.haskell.org
Wed Jun 22 08:50:38 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T7860
Link : http://ghc.haskell.org/trac/ghc/changeset/81d889729c34dbf37c60290116f2f00af1dacd55/ghc
>---------------------------------------------------------------
commit 81d889729c34dbf37c60290116f2f00af1dacd55
Author: Herbert Valerio Riedel <hvr at gnu.org>
Date: Tue Jun 21 23:49:32 2016 +0200
Implement {set,clear,complement}BitBigNat primitives
and hook up to `Natural`'s `Bits` instance
This doesn't yet benefit `Integer`, as we still need "negative" `BigNat`
variants for that.
>---------------------------------------------------------------
81d889729c34dbf37c60290116f2f00af1dacd55
libraries/base/GHC/Natural.hs | 17 +++-
.../integer-gmp/src/GHC/Integer/GMP/Internals.hs | 3 +
libraries/integer-gmp/src/GHC/Integer/Type.hs | 90 ++++++++++++++++++++--
3 files changed, 101 insertions(+), 9 deletions(-)
diff --git a/libraries/base/GHC/Natural.hs b/libraries/base/GHC/Natural.hs
index 953b2a4..fb405a6 100644
--- a/libraries/base/GHC/Natural.hs
+++ b/libraries/base/GHC/Natural.hs
@@ -324,7 +324,22 @@ instance Bits Natural where
testBit (NatS# w) i = testBit (W# w) i
testBit (NatJ# bn) (I# i#) = testBitBigNat bn i#
- -- TODO: setBit, clearBit, complementBit (needs more primitives)
+ clearBit n@(NatS# w#) i
+ | i < finiteBitSize (0::Word) = let !(W# w2#) = clearBit (W# w#) i in NatS# w2#
+ | otherwise = n
+ clearBit (NatJ# bn) (I# i#) = bigNatToNatural (clearBitBigNat bn i#)
+
+ setBit (NatS# w#) i@(I# i#)
+ | i < finiteBitSize (0::Word) = let !(W# w2#) = setBit (W# w#) i in NatS# w2#
+ | otherwise = bigNatToNatural (setBitBigNat (wordToBigNat w#) i#)
+ setBit (NatJ# bn) (I# i#) = bigNatToNatural (setBitBigNat bn i#)
+
+ complementBit (NatS# w#) i@(I# i#)
+ | i < finiteBitSize (0::Word) = let !(W# w2#) = setBit (W# w#) i in NatS# w2#
+ | otherwise = bigNatToNatural (setBitBigNat (wordToBigNat w#) i#)
+ complementBit (NatJ# bn) (I# i#) = bigNatToNatural (complementBitBigNat bn i#)
+
+ -- TODO: complementBit (needs more primitives)
shiftL n 0 = n
shiftL (NatS# 0##) _ = NatS# 0##
diff --git a/libraries/integer-gmp/src/GHC/Integer/GMP/Internals.hs b/libraries/integer-gmp/src/GHC/Integer/GMP/Internals.hs
index 0ad6848..a613ab1 100644
--- a/libraries/integer-gmp/src/GHC/Integer/GMP/Internals.hs
+++ b/libraries/integer-gmp/src/GHC/Integer/GMP/Internals.hs
@@ -106,6 +106,9 @@ module GHC.Integer.GMP.Internals
, shiftRBigNat
, shiftLBigNat
, testBitBigNat
+ , clearBitBigNat
+ , complementBitBigNat
+ , setBitBigNat
, andBigNat
, xorBigNat
, popCountBigNat
diff --git a/libraries/integer-gmp/src/GHC/Integer/Type.hs b/libraries/integer-gmp/src/GHC/Integer/Type.hs
index 6506ebf..2bacc13 100644
--- a/libraries/integer-gmp/src/GHC/Integer/Type.hs
+++ b/libraries/integer-gmp/src/GHC/Integer/Type.hs
@@ -1061,7 +1061,7 @@ bitBigNat i#
mbn@(MBN# mba#) <- newBigNat# (li# +# 1#)
-- FIXME: do we really need to zero-init MBAs returned by 'newByteArray#'?
-- clear all limbs (except for the most-significant limb)
- _ <- svoid (setByteArray# mba# 0# (li# `uncheckedIShiftL#` GMP_LIMB_SHIFT#) 0#)
+ _ <- svoid (clearWordArray# mba# 0# li#)
-- set single bit in most-significant limb
_ <- svoid (writeBigNat# mbn li# (uncheckedShiftL# 1## bi#))
unsafeFreezeBigNat# mbn
@@ -1092,6 +1092,67 @@ testBitNegBigNat bn i#
allZ j | isTrue# (indexBigNat# bn (j -# 1#) `eqWord#` 0##) = allZ (j -# 1#)
| True = False
+
+clearBitBigNat :: BigNat -> Int# -> BigNat
+clearBitBigNat bn i#
+ | not (inline testBitBigNat bn i#) = bn
+ | isTrue# (nx# ==# 1#) = wordToBigNat (bigNatToWord bn `xor#` bitWord# bi#)
+ | isTrue# (li# +# 1# ==# nx#) = -- special case, operating on most-sig limb
+ case indexBigNat# bn li# `xor#` bitWord# bi# of
+ 0## -> do -- most-sig limb became zero -> result has less limbs
+ case fmssl bn (li# -# 1#) of
+ 0# -> zeroBigNat
+ n# -> runS $ do
+ mbn <- newBigNat# n#
+ _ <- copyWordArray bn 0# mbn 0# n#
+ unsafeFreezeBigNat# mbn
+ newlimb# -> runS $ do -- no shrinking
+ mbn <- newBigNat# nx#
+ _ <- copyWordArray bn 0# mbn 0# li#
+ _ <- svoid (writeBigNat# mbn li# newlimb#)
+ unsafeFreezeBigNat# mbn
+
+ | True = runS $ do
+ mbn <- newBigNat# nx#
+ _ <- copyWordArray bn 0# mbn 0# nx#
+ let newlimb# = indexBigNat# bn li# `xor#` bitWord# bi#
+ _ <- svoid (writeBigNat# mbn li# newlimb#)
+ unsafeFreezeBigNat# mbn
+
+ where
+ (# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS#
+ nx# = sizeofBigNat# bn
+
+
+
+setBitBigNat :: BigNat -> Int# -> BigNat
+setBitBigNat bn i#
+ | inline testBitBigNat bn i# = bn
+ | isTrue# (d# ># 0#) = runS $ do -- result BigNat will have more limbs
+ mbn@(MBN# mba#) <- newBigNat# (li# +# 1#)
+ _ <- copyWordArray bn 0# mbn 0# nx#
+ _ <- svoid (clearWordArray# mba# nx# (d# -# 1#))
+ _ <- svoid (writeBigNat# mbn li# (bitWord# bi#))
+ unsafeFreezeBigNat# mbn
+
+ | True = runS $ do
+ mbn <- newBigNat# nx#
+ _ <- copyWordArray bn 0# mbn 0# nx#
+ _ <- svoid (writeBigNat# mbn li# (indexBigNat# bn li#
+ `or#` bitWord# bi#))
+ unsafeFreezeBigNat# mbn
+
+ where
+ (# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS#
+ nx# = sizeofBigNat# bn
+ d# = li# +# 1# -# nx#
+
+
+complementBitBigNat :: BigNat -> Int# -> BigNat
+complementBitBigNat bn i#
+ | testBitBigNat bn i# = clearBitBigNat bn i#
+ | True = setBitBigNat bn i#
+
popCountBigNat :: BigNat -> Int#
popCountBigNat bn@(BN# ba#) = word2Int# (c_mpn_popcount ba# (sizeofBigNat# bn))
@@ -1748,6 +1809,15 @@ copyWordArray# src src_ofs dst dst_ofs len
dst (dst_ofs `uncheckedIShiftL#` GMP_LIMB_SHIFT#)
(len `uncheckedIShiftL#` GMP_LIMB_SHIFT#)
+copyWordArray :: BigNat -> Int# -> MutBigNat s -> Int# -> Int# -> S s ()
+copyWordArray (BN# ba#) ofs_ba# (MBN# mba#) ofs_mba# len#
+ = svoid (copyWordArray# ba# ofs_ba# mba# ofs_mba# len#)
+
+clearWordArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
+clearWordArray# mba ofs len
+ = setByteArray# mba (ofs `uncheckedIShiftL#` GMP_LIMB_SHIFT#)
+ (len `uncheckedIShiftL#` GMP_LIMB_SHIFT#) 0#
+
-- | Version of 'normSizeofMutBigNat'#' which scans all allocated 'MutBigNat#'
normSizeofMutBigNat# :: MutBigNat s -> State# s -> (# State# s, Int# #)
normSizeofMutBigNat# mbn@(MBN# mba) s = normSizeofMutBigNat'# mbn sz# s'
@@ -1791,13 +1861,7 @@ byteArrayToBigNat# ba# n0#
where
(# baszq#, baszr# #) = quotRemInt# (sizeofByteArray# ba#) GMP_LIMB_BYTES#
- n# = fmssl (n0# -# 1#)
-
- -- find most signifcant set limb, return normalized size
- fmssl i#
- | isTrue# (i# <# 0#) = 0#
- | isTrue# (neWord# (indexWordArray# ba# i#) 0##) = i# +# 1#
- | True = fmssl (i# -# 1#)
+ n# = fmssl (BN# ba#) (n0# -# 1#)
-- | Read 'Integer' (without sign) from memory location at @/addr/@ in
-- base-256 representation.
@@ -2050,3 +2114,13 @@ cmpI# x# y# = (x# ># y#) -# (x# <# y#)
minI# :: Int# -> Int# -> Int#
minI# x# y# | isTrue# (x# <=# y#) = x#
| True = y#
+
+
+
+-- find most-sig set limb, starting at given index
+fmssl :: BigNat -> Int# -> Int#
+fmssl bn i0# = go i0#
+ where
+ go i# | isTrue# (i# <# 0#) = 0#
+ | isTrue# (neWord# (indexBigNat# bn i#) 0##) = i# +# 1#
+ | True = go (i# -# 1#)
More information about the ghc-commits
mailing list