diff options
| -rw-r--r-- | libraries/base/Data/Bits.hs | 720 | ||||
| -rw-r--r-- | libraries/base/GHC/Bits.hs | 719 | ||||
| -rw-r--r-- | libraries/base/GHC/Float.hs | 2 | ||||
| -rw-r--r-- | libraries/base/GHC/Word.hs | 2 | ||||
| -rw-r--r-- | libraries/base/base.cabal | 1 | ||||
| -rw-r--r-- | testsuite/tests/ghci/scripts/ghci064.stdout | 4 |
6 files changed, 800 insertions, 648 deletions
diff --git a/libraries/base/Data/Bits.hs b/libraries/base/Data/Bits.hs index 89702105eb..f1345e5e93 100644 --- a/libraries/base/Data/Bits.hs +++ b/libraries/base/Data/Bits.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE CPP, NoImplicitPrelude, BangPatterns, MagicHash #-} ----------------------------------------------------------------------------- -- | @@ -48,670 +50,100 @@ module Data.Bits ( bitDefault, testBitDefault, popCountDefault, - toIntegralSized - ) where - --- Defines the @Bits@ class containing bit-based operations. --- See library document for details on the semantics of the --- individual operations. + toIntegralSized, + oneBits, -#include "MachDeps.h" + And(..), Ior(..), Xor(..), Iff(..) + ) where -import Data.Maybe -import GHC.Num import GHC.Base -import GHC.Real - -infixl 8 `shift`, `rotate`, `shiftL`, `shiftR`, `rotateL`, `rotateR` -infixl 7 .&. -infixl 6 `xor` -infixl 5 .|. +import GHC.Bits +import GHC.Enum +import GHC.Read +import GHC.Show -{-# DEPRECATED bitSize "Use 'bitSizeMaybe' or 'finiteBitSize' instead" #-} -- deprecated in 7.8 - --- | The 'Bits' class defines bitwise operations over integral types. +-- | A more concise version of 'complement zeroBits'. -- --- * Bits are numbered from 0 with bit 0 being the least --- significant bit. -class Eq a => Bits a where - {-# MINIMAL (.&.), (.|.), xor, complement, - (shift | (shiftL, shiftR)), - (rotate | (rotateL, rotateR)), - bitSize, bitSizeMaybe, isSigned, testBit, bit, popCount #-} - - -- | Bitwise \"and\" - (.&.) :: a -> a -> a - - -- | Bitwise \"or\" - (.|.) :: a -> a -> a - - -- | Bitwise \"xor\" - xor :: a -> a -> a - - {-| Reverse all the bits in the argument -} - complement :: a -> a - - {-| @'shift' x i@ shifts @x@ left by @i@ bits if @i@ is positive, - or right by @-i@ bits otherwise. - Right shifts perform sign extension on signed number types; - i.e. they fill the top bits with 1 if the @x@ is negative - and with 0 otherwise. - - An instance can define either this unified 'shift' or 'shiftL' and - 'shiftR', depending on which is more convenient for the type in - question. -} - shift :: a -> Int -> a - - x `shift` i | i<0 = x `shiftR` (-i) - | i>0 = x `shiftL` i - | otherwise = x - - {-| @'rotate' x i@ rotates @x@ left by @i@ bits if @i@ is positive, - or right by @-i@ bits otherwise. - - For unbounded types like 'Integer', 'rotate' is equivalent to 'shift'. - - An instance can define either this unified 'rotate' or 'rotateL' and - 'rotateR', depending on which is more convenient for the type in - question. -} - rotate :: a -> Int -> a - - x `rotate` i | i<0 = x `rotateR` (-i) - | i>0 = x `rotateL` i - | otherwise = x - - {- - -- Rotation can be implemented in terms of two shifts, but care is - -- needed for negative values. This suggested implementation assumes - -- 2's-complement arithmetic. It is commented out because it would - -- require an extra context (Ord a) on the signature of 'rotate'. - x `rotate` i | i<0 && isSigned x && x<0 - = let left = i+bitSize x in - ((x `shift` i) .&. complement ((-1) `shift` left)) - .|. (x `shift` left) - | i<0 = (x `shift` i) .|. (x `shift` (i+bitSize x)) - | i==0 = x - | i>0 = (x `shift` i) .|. (x `shift` (i-bitSize x)) - -} - - -- | 'zeroBits' is the value with all bits unset. - -- - -- The following laws ought to hold (for all valid bit indices @/n/@): - -- - -- * @'clearBit' 'zeroBits' /n/ == 'zeroBits'@ - -- * @'setBit' 'zeroBits' /n/ == 'bit' /n/@ - -- * @'testBit' 'zeroBits' /n/ == False@ - -- * @'popCount' 'zeroBits' == 0@ - -- - -- This method uses @'clearBit' ('bit' 0) 0@ as its default - -- implementation (which ought to be equivalent to 'zeroBits' for - -- types which possess a 0th bit). - -- - -- @since 4.7.0.0 - zeroBits :: a - zeroBits = clearBit (bit 0) 0 - - -- | @bit /i/@ is a value with the @/i/@th bit set and all other bits clear. - -- - -- Can be implemented using `bitDefault' if @a@ is also an - -- instance of 'Num'. - -- - -- See also 'zeroBits'. - bit :: Int -> a - - -- | @x \`setBit\` i@ is the same as @x .|. bit i@ - setBit :: a -> Int -> a - - -- | @x \`clearBit\` i@ is the same as @x .&. complement (bit i)@ - clearBit :: a -> Int -> a - - -- | @x \`complementBit\` i@ is the same as @x \`xor\` bit i@ - complementBit :: a -> Int -> a - - {-| @x \`testBit\` i@ is the same as @x .&. bit n /= 0@ - - In other words it returns True if the bit at offset @n - is set. - - Can be implemented using `testBitDefault' if @a@ is also an - instance of 'Num'. - -} - testBit :: a -> Int -> Bool - - {-| Return the number of bits in the type of the argument. The actual - value of the argument is ignored. Returns Nothing - for types that do not have a fixed bitsize, like 'Integer'. - - @since 4.7.0.0 - -} - bitSizeMaybe :: a -> Maybe Int - - {-| Return the number of bits in the type of the argument. The actual - value of the argument is ignored. The function 'bitSize' is - undefined for types that do not have a fixed bitsize, like 'Integer'. - - Default implementation based upon 'bitSizeMaybe' provided since - 4.12.0.0. - -} - bitSize :: a -> Int - bitSize b = fromMaybe (error "bitSize is undefined") (bitSizeMaybe b) - - {-| Return 'True' if the argument is a signed type. The actual - value of the argument is ignored -} - isSigned :: a -> Bool - - {-# INLINE setBit #-} - {-# INLINE clearBit #-} - {-# INLINE complementBit #-} - x `setBit` i = x .|. bit i - x `clearBit` i = x .&. complement (bit i) - x `complementBit` i = x `xor` bit i - - {-| Shift the argument left by the specified number of bits - (which must be non-negative). Some instances may throw an - 'Control.Exception.Overflow' exception if given a negative input. - - An instance can define either this and 'shiftR' or the unified - 'shift', depending on which is more convenient for the type in - question. -} - shiftL :: a -> Int -> a - {-# INLINE shiftL #-} - x `shiftL` i = x `shift` i - - {-| Shift the argument left by the specified number of bits. The - result is undefined for negative shift amounts and shift amounts - greater or equal to the 'bitSize'. - - Defaults to 'shiftL' unless defined explicitly by an instance. - - @since 4.5.0.0 -} - unsafeShiftL :: a -> Int -> a - {-# INLINE unsafeShiftL #-} - x `unsafeShiftL` i = x `shiftL` i - - {-| Shift the first argument right by the specified number of bits. The - result is undefined for negative shift amounts and shift amounts - greater or equal to the 'bitSize'. Some instances may throw an - 'Control.Exception.Overflow' exception if given a negative input. - - Right shifts perform sign extension on signed number types; - i.e. they fill the top bits with 1 if the @x@ is negative - and with 0 otherwise. - - An instance can define either this and 'shiftL' or the unified - 'shift', depending on which is more convenient for the type in - question. -} - shiftR :: a -> Int -> a - {-# INLINE shiftR #-} - x `shiftR` i = x `shift` (-i) - - {-| Shift the first argument right by the specified number of bits, which - must be non-negative and smaller than the number of bits in the type. - - Right shifts perform sign extension on signed number types; - i.e. they fill the top bits with 1 if the @x@ is negative - and with 0 otherwise. - - Defaults to 'shiftR' unless defined explicitly by an instance. - - @since 4.5.0.0 -} - unsafeShiftR :: a -> Int -> a - {-# INLINE unsafeShiftR #-} - x `unsafeShiftR` i = x `shiftR` i - - {-| Rotate the argument left by the specified number of bits - (which must be non-negative). - - An instance can define either this and 'rotateR' or the unified - 'rotate', depending on which is more convenient for the type in - question. -} - rotateL :: a -> Int -> a - {-# INLINE rotateL #-} - x `rotateL` i = x `rotate` i - - {-| Rotate the argument right by the specified number of bits - (which must be non-negative). - - An instance can define either this and 'rotateL' or the unified - 'rotate', depending on which is more convenient for the type in - question. -} - rotateR :: a -> Int -> a - {-# INLINE rotateR #-} - x `rotateR` i = x `rotate` (-i) - - {-| Return the number of set bits in the argument. This number is - known as the population count or the Hamming weight. - - Can be implemented using `popCountDefault' if @a@ is also an - instance of 'Num'. - - @since 4.5.0.0 -} - popCount :: a -> Int - --- |The 'FiniteBits' class denotes types with a finite, fixed number of bits. --- --- @since 4.7.0.0 -class Bits b => FiniteBits b where - -- | Return the number of bits in the type of the argument. - -- The actual value of the argument is ignored. Moreover, 'finiteBitSize' - -- is total, in contrast to the deprecated 'bitSize' function it replaces. - -- - -- @ - -- 'finiteBitSize' = 'bitSize' - -- 'bitSizeMaybe' = 'Just' . 'finiteBitSize' - -- @ - -- - -- @since 4.7.0.0 - finiteBitSize :: b -> Int - - -- | Count number of zero bits preceding the most significant set bit. - -- - -- @ - -- 'countLeadingZeros' ('zeroBits' :: a) = finiteBitSize ('zeroBits' :: a) - -- @ - -- - -- 'countLeadingZeros' can be used to compute log base 2 via - -- - -- @ - -- logBase2 x = 'finiteBitSize' x - 1 - 'countLeadingZeros' x - -- @ - -- - -- Note: The default implementation for this method is intentionally - -- naive. However, the instances provided for the primitive - -- integral types are implemented using CPU specific machine - -- instructions. - -- - -- @since 4.8.0.0 - countLeadingZeros :: b -> Int - countLeadingZeros x = (w-1) - go (w-1) - where - go i | i < 0 = i -- no bit set - | testBit x i = i - | otherwise = go (i-1) - - w = finiteBitSize x - - -- | Count number of zero bits following the least significant set bit. - -- - -- @ - -- 'countTrailingZeros' ('zeroBits' :: a) = finiteBitSize ('zeroBits' :: a) - -- 'countTrailingZeros' . 'negate' = 'countTrailingZeros' - -- @ - -- - -- The related - -- <http://en.wikipedia.org/wiki/Find_first_set find-first-set operation> - -- can be expressed in terms of 'countTrailingZeros' as follows - -- - -- @ - -- findFirstSet x = 1 + 'countTrailingZeros' x - -- @ - -- - -- Note: The default implementation for this method is intentionally - -- naive. However, the instances provided for the primitive - -- integral types are implemented using CPU specific machine - -- instructions. - -- - -- @since 4.8.0.0 - countTrailingZeros :: b -> Int - countTrailingZeros x = go 0 - where - go i | i >= w = i - | testBit x i = i - | otherwise = go (i+1) - - w = finiteBitSize x - - --- The defaults below are written with lambdas so that e.g. --- bit = bitDefault --- is fully applied, so inlining will happen - --- | Default implementation for 'bit'. +-- >>> complement zeroBits :: Word == oneBits :: Word +-- True -- --- Note that: @bitDefault i = 1 `shiftL` i@ +-- >>> complement oneBits :: Word == zeroBits :: Word +-- True -- --- @since 4.6.0.0 -bitDefault :: (Bits a, Num a) => Int -> a -bitDefault = \i -> 1 `shiftL` i -{-# INLINE bitDefault #-} +-- @since 4.16 +oneBits :: (Bits a) => a +oneBits = complement zeroBits +{-# INLINE oneBits #-} --- | Default implementation for 'testBit'. +-- | Monoid under bitwise AND. -- --- Note that: @testBitDefault x i = (x .&. bit i) /= 0@ +-- >>> getAnd (And 0xab <> And 0x12) :: Word8 +-- 2 -- --- @since 4.6.0.0 -testBitDefault :: (Bits a, Num a) => a -> Int -> Bool -testBitDefault = \x i -> (x .&. bit i) /= 0 -{-# INLINE testBitDefault #-} +-- @since 4.16 +newtype And a = And { getAnd :: a } + deriving newtype (Bounded, Enum, Bits, FiniteBits, Eq) + deriving stock (Show, Read) --- | Default implementation for 'popCount'. --- --- This implementation is intentionally naive. Instances are expected to provide --- an optimized implementation for their size. --- --- @since 4.6.0.0 -popCountDefault :: (Bits a, Num a) => a -> Int -popCountDefault = go 0 - where - go !c 0 = c - go c w = go (c+1) (w .&. (w - 1)) -- clear the least significant -{-# INLINABLE popCountDefault #-} +-- | @since 4.16 +instance (Bits a) => Semigroup (And a) where + And x <> And y = And (x .&. y) +-- | @since 4.16 +instance (Bits a) => Monoid (And a) where + mempty = And oneBits --- | Interpret 'Bool' as 1-bit bit-field +-- | Monoid under bitwise inclusive OR. -- --- @since 4.7.0.0 -instance Bits Bool where - (.&.) = (&&) - - (.|.) = (||) - - xor = (/=) - - complement = not - - shift x 0 = x - shift _ _ = False - - rotate x _ = x - - bit 0 = True - bit _ = False - - testBit x 0 = x - testBit _ _ = False - - bitSizeMaybe _ = Just 1 - - bitSize _ = 1 - - isSigned _ = False - - popCount False = 0 - popCount True = 1 - --- | @since 4.7.0.0 -instance FiniteBits Bool where - finiteBitSize _ = 1 - countTrailingZeros x = if x then 0 else 1 - countLeadingZeros x = if x then 0 else 1 - --- | @since 2.01 -instance Bits Int where - {-# INLINE shift #-} - {-# INLINE bit #-} - {-# INLINE testBit #-} - -- We want popCnt# to be inlined in user code so that `ghc -msse4.2` - -- can compile it down to a popcnt instruction without an extra function call - {-# INLINE popCount #-} - - zeroBits = 0 - - bit = bitDefault - - testBit = testBitDefault - - (I# x#) .&. (I# y#) = I# (x# `andI#` y#) - (I# x#) .|. (I# y#) = I# (x# `orI#` y#) - (I# x#) `xor` (I# y#) = I# (x# `xorI#` y#) - complement (I# x#) = I# (notI# x#) - (I# x#) `shift` (I# i#) - | isTrue# (i# >=# 0#) = I# (x# `iShiftL#` i#) - | otherwise = I# (x# `iShiftRA#` negateInt# i#) - (I# x#) `shiftL` (I# i#) - | isTrue# (i# >=# 0#) = I# (x# `iShiftL#` i#) - | otherwise = overflowError - (I# x#) `unsafeShiftL` (I# i#) = I# (x# `uncheckedIShiftL#` i#) - (I# x#) `shiftR` (I# i#) - | isTrue# (i# >=# 0#) = I# (x# `iShiftRA#` i#) - | otherwise = overflowError - (I# x#) `unsafeShiftR` (I# i#) = I# (x# `uncheckedIShiftRA#` i#) - - {-# INLINE rotate #-} -- See Note [Constant folding for rotate] - (I# x#) `rotate` (I# i#) = - I# ((x# `uncheckedIShiftL#` i'#) `orI#` (x# `uncheckedIShiftRL#` (wsib -# i'#))) - where - !i'# = i# `andI#` (wsib -# 1#) - !wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -} - bitSizeMaybe i = Just (finiteBitSize i) - bitSize i = finiteBitSize i - - popCount (I# x#) = I# (word2Int# (popCnt# (int2Word# x#))) - - isSigned _ = True - --- | @since 4.6.0.0 -instance FiniteBits Int where - finiteBitSize _ = WORD_SIZE_IN_BITS - countLeadingZeros (I# x#) = I# (word2Int# (clz# (int2Word# x#))) - {-# INLINE countLeadingZeros #-} - countTrailingZeros (I# x#) = I# (word2Int# (ctz# (int2Word# x#))) - {-# INLINE countTrailingZeros #-} - --- | @since 2.01 -instance Bits Word where - {-# INLINE shift #-} - {-# INLINE bit #-} - {-# INLINE testBit #-} - {-# INLINE popCount #-} - - (W# x#) .&. (W# y#) = W# (x# `and#` y#) - (W# x#) .|. (W# y#) = W# (x# `or#` y#) - (W# x#) `xor` (W# y#) = W# (x# `xor#` y#) - complement (W# x#) = W# (not# x#) - (W# x#) `shift` (I# i#) - | isTrue# (i# >=# 0#) = W# (x# `shiftL#` i#) - | otherwise = W# (x# `shiftRL#` negateInt# i#) - (W# x#) `shiftL` (I# i#) - | isTrue# (i# >=# 0#) = W# (x# `shiftL#` i#) - | otherwise = overflowError - (W# x#) `unsafeShiftL` (I# i#) = W# (x# `uncheckedShiftL#` i#) - (W# x#) `shiftR` (I# i#) - | isTrue# (i# >=# 0#) = W# (x# `shiftRL#` i#) - | otherwise = overflowError - (W# x#) `unsafeShiftR` (I# i#) = W# (x# `uncheckedShiftRL#` i#) - (W# x#) `rotate` (I# i#) - | isTrue# (i'# ==# 0#) = W# x# - | otherwise = W# ((x# `uncheckedShiftL#` i'#) `or#` (x# `uncheckedShiftRL#` (wsib -# i'#))) - where - !i'# = i# `andI#` (wsib -# 1#) - !wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -} - bitSizeMaybe i = Just (finiteBitSize i) - bitSize i = finiteBitSize i - isSigned _ = False - popCount (W# x#) = I# (word2Int# (popCnt# x#)) - bit = bitDefault - testBit = testBitDefault - --- | @since 4.6.0.0 -instance FiniteBits Word where - finiteBitSize _ = WORD_SIZE_IN_BITS - countLeadingZeros (W# x#) = I# (word2Int# (clz# x#)) - {-# INLINE countLeadingZeros #-} - countTrailingZeros (W# x#) = I# (word2Int# (ctz# x#)) - {-# INLINE countTrailingZeros #-} - --- | @since 2.01 -instance Bits Integer where - (.&.) = integerAnd - (.|.) = integerOr - xor = integerXor - complement = integerComplement - unsafeShiftR x i = integerShiftR x (fromIntegral i) - unsafeShiftL x i = integerShiftL x (fromIntegral i) - shiftR x i@(I# i#) - | isTrue# (i# >=# 0#) = unsafeShiftR x i - | otherwise = overflowError - shiftL x i@(I# i#) - | isTrue# (i# >=# 0#) = unsafeShiftL x i - | otherwise = overflowError - shift x i | i >= 0 = integerShiftL x (fromIntegral i) - | otherwise = integerShiftR x (fromIntegral (negate i)) - testBit x i = integerTestBit x (fromIntegral i) - zeroBits = integerZero - - bit (I# i) = integerBit# (int2Word# i) - popCount x = I# (integerPopCount# x) - - rotate x i = shift x i -- since an Integer never wraps around - - bitSizeMaybe _ = Nothing - bitSize _ = errorWithoutStackTrace "Data.Bits.bitSize(Integer)" - isSigned _ = True - --- | @since 4.8.0 -instance Bits Natural where - (.&.) = naturalAnd - (.|.) = naturalOr - xor = naturalXor - complement _ = errorWithoutStackTrace - "Bits.complement: Natural complement undefined" - unsafeShiftR x i = naturalShiftR x (fromIntegral i) - unsafeShiftL x i = naturalShiftL x (fromIntegral i) - shiftR x i@(I# i#) - | isTrue# (i# >=# 0#) = unsafeShiftR x i - | otherwise = overflowError - shiftL x i@(I# i#) - | isTrue# (i# >=# 0#) = unsafeShiftL x i - | otherwise = overflowError - shift x i - | i >= 0 = naturalShiftL x (fromIntegral i) - | otherwise = naturalShiftR x (fromIntegral (negate i)) - testBit x i = naturalTestBit x (fromIntegral i) - zeroBits = naturalZero - clearBit x i = x `xor` (bit i .&. x) - - bit (I# i) = naturalBit# (int2Word# i) - popCount x = I# (word2Int# (naturalPopCount# x)) - - rotate x i = shift x i -- since an Natural never wraps around +-- >>> getIor (Ior 0xab <> Ior 0x12) :: Word8 +-- 187 +-- +-- @since 4.16 +newtype Ior a = Ior { getIor :: a } + deriving newtype (Bounded, Enum, Bits, FiniteBits, Eq) + deriving stock (Show, Read) - bitSizeMaybe _ = Nothing - bitSize _ = errorWithoutStackTrace "Data.Bits.bitSize(Natural)" - isSigned _ = False +-- | @since 4.16 +instance (Bits a) => Semigroup (Ior a) where + Ior x <> Ior y = Ior (x .|. y) ------------------------------------------------------------------------------ +-- | @since 4.16 +instance (Bits a) => Monoid (Ior a) where + mempty = Ior zeroBits --- | Attempt to convert an 'Integral' type @a@ to an 'Integral' type @b@ using --- the size of the types as measured by 'Bits' methods. +-- | Monoid under bitwise XOR. -- --- A simpler version of this function is: +-- >>> getXor (Xor 0xab <> 0x12) :: Word8 +-- 185 -- --- > toIntegral :: (Integral a, Integral b) => a -> Maybe b --- > toIntegral x --- > | toInteger x == y = Just (fromInteger y) --- > | otherwise = Nothing --- > where --- > y = toInteger x --- --- This version requires going through 'Integer', which can be inefficient. --- However, @toIntegralSized@ is optimized to allow GHC to statically determine --- the relative type sizes (as measured by 'bitSizeMaybe' and 'isSigned') and --- avoid going through 'Integer' for many types. (The implementation uses --- 'fromIntegral', which is itself optimized with rules for @base@ types but may --- go through 'Integer' for some type pairs.) --- --- @since 4.8.0.0 - -toIntegralSized :: (Integral a, Integral b, Bits a, Bits b) => a -> Maybe b -toIntegralSized x -- See Note [toIntegralSized optimization] - | maybe True (<= x) yMinBound - , maybe True (x <=) yMaxBound = Just y - | otherwise = Nothing - where - y = fromIntegral x +-- @since 4.16 +newtype Xor a = Xor { getXor :: a } + deriving newtype (Bounded, Enum, Bits, FiniteBits, Eq) + deriving stock (Show, Read) - xWidth = bitSizeMaybe x - yWidth = bitSizeMaybe y +-- | @since 4.16 +instance (Bits a) => Semigroup (Xor a) where + Xor x <> Xor y = Xor (x `xor` y) - yMinBound - | isBitSubType x y = Nothing - | isSigned x, not (isSigned y) = Just 0 - | isSigned x, isSigned y - , Just yW <- yWidth = Just (negate $ bit (yW-1)) -- Assumes sub-type - | otherwise = Nothing +-- | @since 4.16 +instance (Bits a) => Monoid (Xor a) where + mempty = Xor zeroBits - yMaxBound - | isBitSubType x y = Nothing - | isSigned x, not (isSigned y) - , Just xW <- xWidth, Just yW <- yWidth - , xW <= yW+1 = Nothing -- Max bound beyond a's domain - | Just yW <- yWidth = if isSigned y - then Just (bit (yW-1)-1) - else Just (bit yW-1) - | otherwise = Nothing -{-# INLINABLE toIntegralSized #-} - --- | 'True' if the size of @a@ is @<=@ the size of @b@, where size is measured --- by 'bitSizeMaybe' and 'isSigned'. -isBitSubType :: (Bits a, Bits b) => a -> b -> Bool -isBitSubType x y - -- Reflexive - | xWidth == yWidth, xSigned == ySigned = True - - -- Every integer is a subset of 'Integer' - | ySigned, Nothing == yWidth = True - | not xSigned, not ySigned, Nothing == yWidth = True - - -- Sub-type relations between fixed-with types - | xSigned == ySigned, Just xW <- xWidth, Just yW <- yWidth = xW <= yW - | not xSigned, ySigned, Just xW <- xWidth, Just yW <- yWidth = xW < yW - - | otherwise = False - where - xWidth = bitSizeMaybe x - xSigned = isSigned x - - yWidth = bitSizeMaybe y - ySigned = isSigned y -{-# INLINE isBitSubType #-} - -{- Note [Constant folding for rotate] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The INLINE on the Int instance of rotate enables it to be constant -folded. For example: - sumU . mapU (`rotate` 3) . replicateU 10000000 $ (7 :: Int) -goes to: - Main.$wfold = - \ (ww_sO7 :: Int#) (ww1_sOb :: Int#) -> - case ww1_sOb of wild_XM { - __DEFAULT -> Main.$wfold (+# ww_sO7 56) (+# wild_XM 1); - 10000000 -> ww_sO7 -whereas before it was left as a call to $wrotate. - -All other Bits instances seem to inline well enough on their -own to enable constant folding; for example 'shift': - sumU . mapU (`shift` 3) . replicateU 10000000 $ (7 :: Int) - goes to: - Main.$wfold = - \ (ww_sOb :: Int#) (ww1_sOf :: Int#) -> - case ww1_sOf of wild_XM { - __DEFAULT -> Main.$wfold (+# ww_sOb 56) (+# wild_XM 1); - 10000000 -> ww_sOb - } --} - --- Note [toIntegralSized optimization] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- The code in 'toIntegralSized' relies on GHC optimizing away statically --- decidable branches. --- --- If both integral types are statically known, GHC will be able optimize the --- code significantly (for @-O1@ and better). --- --- For instance (as of GHC 7.8.1) the following definitions: +-- | Monoid under bitwise \'equality\'; defined as @1@ if the corresponding +-- bits match, and @0@ otherwise. -- --- > w16_to_i32 = toIntegralSized :: Word16 -> Maybe Int32 --- > --- > i16_to_w16 = toIntegralSized :: Int16 -> Maybe Word16 +-- >>> getIff (Iff 0xab <> Iff 0x12) :: Word8 +-- 70 -- --- are translated into the following (simplified) /GHC Core/ language: --- --- > w16_to_i32 = \x -> Just (case x of _ { W16# x# -> I32# (word2Int# x#) }) --- > --- > i16_to_w16 = \x -> case eta of _ --- > { I16# b1 -> case tagToEnum# (<=# 0 b1) of _ --- > { False -> Nothing --- > ; True -> Just (W16# (narrow16Word# (int2Word# b1))) --- > } --- > } +-- @since 4.16 +newtype Iff a = Iff { getIff :: a } + deriving newtype (Bounded, Enum, Bits, FiniteBits, Eq) + deriving stock (Show, Read) + +-- | @since 4.16 +instance (Bits a) => Semigroup (Iff a) where + Iff x <> Iff y = Iff . complement $ (x `xor` y) + +-- | @since 4.16 +instance (Bits a) => Monoid (Iff a) where + mempty = Iff oneBits diff --git a/libraries/base/GHC/Bits.hs b/libraries/base/GHC/Bits.hs new file mode 100644 index 0000000000..d0703e223f --- /dev/null +++ b/libraries/base/GHC/Bits.hs @@ -0,0 +1,719 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Bits +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- This module defines bitwise operations for signed and unsigned +-- integers. Instances of the class 'Bits' for the 'Int' and +-- 'Integer' types are available from this module, and instances for +-- explicitly sized integral types are available from the +-- "Data.Int" and "Data.Word" modules. +-- +----------------------------------------------------------------------------- + +module GHC.Bits ( + Bits( + (.&.), (.|.), xor, + complement, + shift, + rotate, + zeroBits, + bit, + setBit, + clearBit, + complementBit, + testBit, + bitSizeMaybe, + bitSize, + isSigned, + shiftL, shiftR, + unsafeShiftL, unsafeShiftR, + rotateL, rotateR, + popCount + ), + FiniteBits( + finiteBitSize, + countLeadingZeros, + countTrailingZeros + ), + + bitDefault, + testBitDefault, + popCountDefault, + toIntegralSized, + ) where + +-- Defines the @Bits@ class containing bit-based operations. +-- See library document for details on the semantics of the +-- individual operations. + +#include "MachDeps.h" + +import Data.Maybe +import GHC.Num +import GHC.Base +import GHC.Real + +infixl 8 `shift`, `rotate`, `shiftL`, `shiftR`, `rotateL`, `rotateR` +infixl 7 .&. +infixl 6 `xor` +infixl 5 .|. + +{-# DEPRECATED bitSize "Use 'bitSizeMaybe' or 'finiteBitSize' instead" #-} -- deprecated in 7.8 + +-- | The 'Bits' class defines bitwise operations over integral types. +-- +-- * Bits are numbered from 0 with bit 0 being the least +-- significant bit. +class Eq a => Bits a where + {-# MINIMAL (.&.), (.|.), xor, complement, + (shift | (shiftL, shiftR)), + (rotate | (rotateL, rotateR)), + bitSize, bitSizeMaybe, isSigned, testBit, bit, popCount #-} + + -- | Bitwise \"and\" + (.&.) :: a -> a -> a + + -- | Bitwise \"or\" + (.|.) :: a -> a -> a + + -- | Bitwise \"xor\" + xor :: a -> a -> a + + {-| Reverse all the bits in the argument -} + complement :: a -> a + + {-| @'shift' x i@ shifts @x@ left by @i@ bits if @i@ is positive, + or right by @-i@ bits otherwise. + Right shifts perform sign extension on signed number types; + i.e. they fill the top bits with 1 if the @x@ is negative + and with 0 otherwise. + + An instance can define either this unified 'shift' or 'shiftL' and + 'shiftR', depending on which is more convenient for the type in + question. -} + shift :: a -> Int -> a + + x `shift` i | i<0 = x `shiftR` (-i) + | i>0 = x `shiftL` i + | otherwise = x + + {-| @'rotate' x i@ rotates @x@ left by @i@ bits if @i@ is positive, + or right by @-i@ bits otherwise. + + For unbounded types like 'Integer', 'rotate' is equivalent to 'shift'. + + An instance can define either this unified 'rotate' or 'rotateL' and + 'rotateR', depending on which is more convenient for the type in + question. -} + rotate :: a -> Int -> a + + x `rotate` i | i<0 = x `rotateR` (-i) + | i>0 = x `rotateL` i + | otherwise = x + + {- + -- Rotation can be implemented in terms of two shifts, but care is + -- needed for negative values. This suggested implementation assumes + -- 2's-complement arithmetic. It is commented out because it would + -- require an extra context (Ord a) on the signature of 'rotate'. + x `rotate` i | i<0 && isSigned x && x<0 + = let left = i+bitSize x in + ((x `shift` i) .&. complement ((-1) `shift` left)) + .|. (x `shift` left) + | i<0 = (x `shift` i) .|. (x `shift` (i+bitSize x)) + | i==0 = x + | i>0 = (x `shift` i) .|. (x `shift` (i-bitSize x)) + -} + + -- | 'zeroBits' is the value with all bits unset. + -- + -- The following laws ought to hold (for all valid bit indices @/n/@): + -- + -- * @'clearBit' 'zeroBits' /n/ == 'zeroBits'@ + -- * @'setBit' 'zeroBits' /n/ == 'bit' /n/@ + -- * @'testBit' 'zeroBits' /n/ == False@ + -- * @'popCount' 'zeroBits' == 0@ + -- + -- This method uses @'clearBit' ('bit' 0) 0@ as its default + -- implementation (which ought to be equivalent to 'zeroBits' for + -- types which possess a 0th bit). + -- + -- @since 4.7.0.0 + zeroBits :: a + zeroBits = clearBit (bit 0) 0 + + -- | @bit /i/@ is a value with the @/i/@th bit set and all other bits clear. + -- + -- Can be implemented using `bitDefault' if @a@ is also an + -- instance of 'Num'. + -- + -- See also 'zeroBits'. + bit :: Int -> a + + -- | @x \`setBit\` i@ is the same as @x .|. bit i@ + setBit :: a -> Int -> a + + -- | @x \`clearBit\` i@ is the same as @x .&. complement (bit i)@ + clearBit :: a -> Int -> a + + -- | @x \`complementBit\` i@ is the same as @x \`xor\` bit i@ + complementBit :: a -> Int -> a + + {-| @x \`testBit\` i@ is the same as @x .&. bit n /= 0@ + + In other words it returns True if the bit at offset @n + is set. + + Can be implemented using `testBitDefault' if @a@ is also an + instance of 'Num'. + -} + testBit :: a -> Int -> Bool + + {-| Return the number of bits in the type of the argument. The actual + value of the argument is ignored. Returns Nothing + for types that do not have a fixed bitsize, like 'Integer'. + + @since 4.7.0.0 + -} + bitSizeMaybe :: a -> Maybe Int + + {-| Return the number of bits in the type of the argument. The actual + value of the argument is ignored. The function 'bitSize' is + undefined for types that do not have a fixed bitsize, like 'Integer'. + + Default implementation based upon 'bitSizeMaybe' provided since + 4.12.0.0. + -} + bitSize :: a -> Int + bitSize b = fromMaybe (error "bitSize is undefined") (bitSizeMaybe b) + + {-| Return 'True' if the argument is a signed type. The actual + value of the argument is ignored -} + isSigned :: a -> Bool + + {-# INLINE setBit #-} + {-# INLINE clearBit #-} + {-# INLINE complementBit #-} + x `setBit` i = x .|. bit i + x `clearBit` i = x .&. complement (bit i) + x `complementBit` i = x `xor` bit i + + {-| Shift the argument left by the specified number of bits + (which must be non-negative). Some instances may throw an + 'Control.Exception.Overflow' exception if given a negative input. + + An instance can define either this and 'shiftR' or the unified + 'shift', depending on which is more convenient for the type in + question. -} + shiftL :: a -> Int -> a + {-# INLINE shiftL #-} + x `shiftL` i = x `shift` i + + {-| Shift the argument left by the specified number of bits. The + result is undefined for negative shift amounts and shift amounts + greater or equal to the 'bitSize'. + + Defaults to 'shiftL' unless defined explicitly by an instance. + + @since 4.5.0.0 -} + unsafeShiftL :: a -> Int -> a + {-# INLINE unsafeShiftL #-} + x `unsafeShiftL` i = x `shiftL` i + + {-| Shift the first argument right by the specified number of bits. The + result is undefined for negative shift amounts and shift amounts + greater or equal to the 'bitSize'. Some instances may throw an + 'Control.Exception.Overflow' exception if given a negative input. + + Right shifts perform sign extension on signed number types; + i.e. they fill the top bits with 1 if the @x@ is negative + and with 0 otherwise. + + An instance can define either this and 'shiftL' or the unified + 'shift', depending on which is more convenient for the type in + question. -} + shiftR :: a -> Int -> a + {-# INLINE shiftR #-} + x `shiftR` i = x `shift` (-i) + + {-| Shift the first argument right by the specified number of bits, which + must be non-negative and smaller than the number of bits in the type. + + Right shifts perform sign extension on signed number types; + i.e. they fill the top bits with 1 if the @x@ is negative + and with 0 otherwise. + + Defaults to 'shiftR' unless defined explicitly by an instance. + + @since 4.5.0.0 -} + unsafeShiftR :: a -> Int -> a + {-# INLINE unsafeShiftR #-} + x `unsafeShiftR` i = x `shiftR` i + + {-| Rotate the argument left by the specified number of bits + (which must be non-negative). + + An instance can define either this and 'rotateR' or the unified + 'rotate', depending on which is more convenient for the type in + question. -} + rotateL :: a -> Int -> a + {-# INLINE rotateL #-} + x `rotateL` i = x `rotate` i + + {-| Rotate the argument right by the specified number of bits + (which must be non-negative). + + An instance can define either this and 'rotateL' or the unified + 'rotate', depending on which is more convenient for the type in + question. -} + rotateR :: a -> Int -> a + {-# INLINE rotateR #-} + x `rotateR` i = x `rotate` (-i) + + {-| Return the number of set bits in the argument. This number is + known as the population count or the Hamming weight. + + Can be implemented using `popCountDefault' if @a@ is also an + instance of 'Num'. + + @since 4.5.0.0 -} + popCount :: a -> Int + +-- |The 'FiniteBits' class denotes types with a finite, fixed number of bits. +-- +-- @since 4.7.0.0 +class Bits b => FiniteBits b where + -- | Return the number of bits in the type of the argument. + -- The actual value of the argument is ignored. Moreover, 'finiteBitSize' + -- is total, in contrast to the deprecated 'bitSize' function it replaces. + -- + -- @ + -- 'finiteBitSize' = 'bitSize' + -- 'bitSizeMaybe' = 'Just' . 'finiteBitSize' + -- @ + -- + -- @since 4.7.0.0 + finiteBitSize :: b -> Int + + -- | Count number of zero bits preceding the most significant set bit. + -- + -- @ + -- 'countLeadingZeros' ('zeroBits' :: a) = finiteBitSize ('zeroBits' :: a) + -- @ + -- + -- 'countLeadingZeros' can be used to compute log base 2 via + -- + -- @ + -- logBase2 x = 'finiteBitSize' x - 1 - 'countLeadingZeros' x + -- @ + -- + -- Note: The default implementation for this method is intentionally + -- naive. However, the instances provided for the primitive + -- integral types are implemented using CPU specific machine + -- instructions. + -- + -- @since 4.8.0.0 + countLeadingZeros :: b -> Int + countLeadingZeros x = (w-1) - go (w-1) + where + go i | i < 0 = i -- no bit set + | testBit x i = i + | otherwise = go (i-1) + + w = finiteBitSize x + + -- | Count number of zero bits following the least significant set bit. + -- + -- @ + -- 'countTrailingZeros' ('zeroBits' :: a) = finiteBitSize ('zeroBits' :: a) + -- 'countTrailingZeros' . 'negate' = 'countTrailingZeros' + -- @ + -- + -- The related + -- <http://en.wikipedia.org/wiki/Find_first_set find-first-set operation> + -- can be expressed in terms of 'countTrailingZeros' as follows + -- + -- @ + -- findFirstSet x = 1 + 'countTrailingZeros' x + -- @ + -- + -- Note: The default implementation for this method is intentionally + -- naive. However, the instances provided for the primitive + -- integral types are implemented using CPU specific machine + -- instructions. + -- + -- @since 4.8.0.0 + countTrailingZeros :: b -> Int + countTrailingZeros x = go 0 + where + go i | i >= w = i + | testBit x i = i + | otherwise = go (i+1) + + w = finiteBitSize x + + +-- The defaults below are written with lambdas so that e.g. +-- bit = bitDefault +-- is fully applied, so inlining will happen + +-- | Default implementation for 'bit'. +-- +-- Note that: @bitDefault i = 1 `shiftL` i@ +-- +-- @since 4.6.0.0 +bitDefault :: (Bits a, Num a) => Int -> a +bitDefault = \i -> 1 `shiftL` i +{-# INLINE bitDefault #-} + +-- | Default implementation for 'testBit'. +-- +-- Note that: @testBitDefault x i = (x .&. bit i) /= 0@ +-- +-- @since 4.6.0.0 +testBitDefault :: (Bits a, Num a) => a -> Int -> Bool +testBitDefault = \x i -> (x .&. bit i) /= 0 +{-# INLINE testBitDefault #-} + +-- | Default implementation for 'popCount'. +-- +-- This implementation is intentionally naive. Instances are expected to provide +-- an optimized implementation for their size. +-- +-- @since 4.6.0.0 +popCountDefault :: (Bits a, Num a) => a -> Int +popCountDefault = go 0 + where + go !c 0 = c + go c w = go (c+1) (w .&. (w - 1)) -- clear the least significant +{-# INLINABLE popCountDefault #-} + +-- | Interpret 'Bool' as 1-bit bit-field +-- +-- @since 4.7.0.0 +instance Bits Bool where + (.&.) = (&&) + + (.|.) = (||) + + xor = (/=) + + complement = not + + shift x 0 = x + shift _ _ = False + + rotate x _ = x + + bit 0 = True + bit _ = False + + testBit x 0 = x + testBit _ _ = False + + bitSizeMaybe _ = Just 1 + + bitSize _ = 1 + + isSigned _ = False + + popCount False = 0 + popCount True = 1 + +-- | @since 4.7.0.0 +instance FiniteBits Bool where + finiteBitSize _ = 1 + countTrailingZeros x = if x then 0 else 1 + countLeadingZeros x = if x then 0 else 1 + +-- | @since 2.01 +instance Bits Int where + {-# INLINE shift #-} + {-# INLINE bit #-} + {-# INLINE testBit #-} + -- We want popCnt# to be inlined in user code so that `ghc -msse4.2` + -- can compile it down to a popcnt instruction without an extra function call + {-# INLINE popCount #-} + + zeroBits = 0 + + bit = bitDefault + + testBit = testBitDefault + + (I# x#) .&. (I# y#) = I# (x# `andI#` y#) + (I# x#) .|. (I# y#) = I# (x# `orI#` y#) + (I# x#) `xor` (I# y#) = I# (x# `xorI#` y#) + complement (I# x#) = I# (notI# x#) + (I# x#) `shift` (I# i#) + | isTrue# (i# >=# 0#) = I# (x# `iShiftL#` i#) + | otherwise = I# (x# `iShiftRA#` negateInt# i#) + (I# x#) `shiftL` (I# i#) + | isTrue# (i# >=# 0#) = I# (x# `iShiftL#` i#) + | otherwise = overflowError + (I# x#) `unsafeShiftL` (I# i#) = I# (x# `uncheckedIShiftL#` i#) + (I# x#) `shiftR` (I# i#) + | isTrue# (i# >=# 0#) = I# (x# `iShiftRA#` i#) + | otherwise = overflowError + (I# x#) `unsafeShiftR` (I# i#) = I# (x# `uncheckedIShiftRA#` i#) + + {-# INLINE rotate #-} -- See Note [Constant folding for rotate] + (I# x#) `rotate` (I# i#) = + I# ((x# `uncheckedIShiftL#` i'#) `orI#` (x# `uncheckedIShiftRL#` (wsib -# i'#))) + where + !i'# = i# `andI#` (wsib -# 1#) + !wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -} + bitSizeMaybe i = Just (finiteBitSize i) + bitSize i = finiteBitSize i + + popCount (I# x#) = I# (word2Int# (popCnt# (int2Word# x#))) + + isSigned _ = True + +-- | @since 4.6.0.0 +instance FiniteBits Int where + finiteBitSize _ = WORD_SIZE_IN_BITS + countLeadingZeros (I# x#) = I# (word2Int# (clz# (int2Word# x#))) + {-# INLINE countLeadingZeros #-} + countTrailingZeros (I# x#) = I# (word2Int# (ctz# (int2Word# x#))) + {-# INLINE countTrailingZeros #-} + +-- | @since 2.01 +instance Bits Word where + {-# INLINE shift #-} + {-# INLINE bit #-} + {-# INLINE testBit #-} + {-# INLINE popCount #-} + + (W# x#) .&. (W# y#) = W# (x# `and#` y#) + (W# x#) .|. (W# y#) = W# (x# `or#` y#) + (W# x#) `xor` (W# y#) = W# (x# `xor#` y#) + complement (W# x#) = W# (not# x#) + (W# x#) `shift` (I# i#) + | isTrue# (i# >=# 0#) = W# (x# `shiftL#` i#) + | otherwise = W# (x# `shiftRL#` negateInt# i#) + (W# x#) `shiftL` (I# i#) + | isTrue# (i# >=# 0#) = W# (x# `shiftL#` i#) + | otherwise = overflowError + (W# x#) `unsafeShiftL` (I# i#) = W# (x# `uncheckedShiftL#` i#) + (W# x#) `shiftR` (I# i#) + | isTrue# (i# >=# 0#) = W# (x# `shiftRL#` i#) + | otherwise = overflowError + (W# x#) `unsafeShiftR` (I# i#) = W# (x# `uncheckedShiftRL#` i#) + (W# x#) `rotate` (I# i#) + | isTrue# (i'# ==# 0#) = W# x# + | otherwise = W# ((x# `uncheckedShiftL#` i'#) `or#` (x# `uncheckedShiftRL#` (wsib -# i'#))) + where + !i'# = i# `andI#` (wsib -# 1#) + !wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -} + bitSizeMaybe i = Just (finiteBitSize i) + bitSize i = finiteBitSize i + isSigned _ = False + popCount (W# x#) = I# (word2Int# (popCnt# x#)) + bit = bitDefault + testBit = testBitDefault + +-- | @since 4.6.0.0 +instance FiniteBits Word where + finiteBitSize _ = WORD_SIZE_IN_BITS + countLeadingZeros (W# x#) = I# (word2Int# (clz# x#)) + {-# INLINE countLeadingZeros #-} + countTrailingZeros (W# x#) = I# (word2Int# (ctz# x#)) + {-# INLINE countTrailingZeros #-} + +-- | @since 2.01 +instance Bits Integer where + (.&.) = integerAnd + (.|.) = integerOr + xor = integerXor + complement = integerComplement + unsafeShiftR x i = integerShiftR x (fromIntegral i) + unsafeShiftL x i = integerShiftL x (fromIntegral i) + shiftR x i@(I# i#) + | isTrue# (i# >=# 0#) = unsafeShiftR x i + | otherwise = overflowError + shiftL x i@(I# i#) + | isTrue# (i# >=# 0#) = unsafeShiftL x i + | otherwise = overflowError + shift x i | i >= 0 = integerShiftL x (fromIntegral i) + | otherwise = integerShiftR x (fromIntegral (negate i)) + testBit x i = integerTestBit x (fromIntegral i) + zeroBits = integerZero + + bit (I# i) = integerBit# (int2Word# i) + popCount x = I# (integerPopCount# x) + + rotate x i = shift x i -- since an Integer never wraps around + + bitSizeMaybe _ = Nothing + bitSize _ = errorWithoutStackTrace "Data.Bits.bitSize(Integer)" + isSigned _ = True + +-- | @since 4.8.0 +instance Bits Natural where + (.&.) = naturalAnd + (.|.) = naturalOr + xor = naturalXor + complement _ = errorWithoutStackTrace + "Bits.complement: Natural complement undefined" + unsafeShiftR x i = naturalShiftR x (fromIntegral i) + unsafeShiftL x i = naturalShiftL x (fromIntegral i) + shiftR x i@(I# i#) + | isTrue# (i# >=# 0#) = unsafeShiftR x i + | otherwise = overflowError + shiftL x i@(I# i#) + | isTrue# (i# >=# 0#) = unsafeShiftL x i + | otherwise = overflowError + shift x i + | i >= 0 = naturalShiftL x (fromIntegral i) + | otherwise = naturalShiftR x (fromIntegral (negate i)) + testBit x i = naturalTestBit x (fromIntegral i) + zeroBits = naturalZero + clearBit x i = x `xor` (bit i .&. x) + + bit (I# i) = naturalBit# (int2Word# i) + popCount x = I# (word2Int# (naturalPopCount# x)) + + rotate x i = shift x i -- since an Natural never wraps around + + bitSizeMaybe _ = Nothing + bitSize _ = errorWithoutStackTrace "Data.Bits.bitSize(Natural)" + isSigned _ = False + +----------------------------------------------------------------------------- + +-- | Attempt to convert an 'Integral' type @a@ to an 'Integral' type @b@ using +-- the size of the types as measured by 'Bits' methods. +-- +-- A simpler version of this function is: +-- +-- > toIntegral :: (Integral a, Integral b) => a -> Maybe b +-- > toIntegral x +-- > | toInteger x == y = Just (fromInteger y) +-- > | otherwise = Nothing +-- > where +-- > y = toInteger x +-- +-- This version requires going through 'Integer', which can be inefficient. +-- However, @toIntegralSized@ is optimized to allow GHC to statically determine +-- the relative type sizes (as measured by 'bitSizeMaybe' and 'isSigned') and +-- avoid going through 'Integer' for many types. (The implementation uses +-- 'fromIntegral', which is itself optimized with rules for @base@ types but may +-- go through 'Integer' for some type pairs.) +-- +-- @since 4.8.0.0 + +toIntegralSized :: (Integral a, Integral b, Bits a, Bits b) => a -> Maybe b +toIntegralSized x -- See Note [toIntegralSized optimization] + | maybe True (<= x) yMinBound + , maybe True (x <=) yMaxBound = Just y + | otherwise = Nothing + where + y = fromIntegral x + + xWidth = bitSizeMaybe x + yWidth = bitSizeMaybe y + + yMinBound + | isBitSubType x y = Nothing + | isSigned x, not (isSigned y) = Just 0 + | isSigned x, isSigned y + , Just yW <- yWidth = Just (negate $ bit (yW-1)) -- Assumes sub-type + | otherwise = Nothing + + yMaxBound + | isBitSubType x y = Nothing + | isSigned x, not (isSigned y) + , Just xW <- xWidth, Just yW <- yWidth + , xW <= yW+1 = Nothing -- Max bound beyond a's domain + | Just yW <- yWidth = if isSigned y + then Just (bit (yW-1)-1) + else Just (bit yW-1) + | otherwise = Nothing +{-# INLINABLE toIntegralSized #-} + +-- | 'True' if the size of @a@ is @<=@ the size of @b@, where size is measured +-- by 'bitSizeMaybe' and 'isSigned'. +isBitSubType :: (Bits a, Bits b) => a -> b -> Bool +isBitSubType x y + -- Reflexive + | xWidth == yWidth, xSigned == ySigned = True + + -- Every integer is a subset of 'Integer' + | ySigned, Nothing == yWidth = True + | not xSigned, not ySigned, Nothing == yWidth = True + + -- Sub-type relations between fixed-with types + | xSigned == ySigned, Just xW <- xWidth, Just yW <- yWidth = xW <= yW + | not xSigned, ySigned, Just xW <- xWidth, Just yW <- yWidth = xW < yW + + | otherwise = False + where + xWidth = bitSizeMaybe x + xSigned = isSigned x + + yWidth = bitSizeMaybe y + ySigned = isSigned y +{-# INLINE isBitSubType #-} + +{- Note [Constant folding for rotate] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The INLINE on the Int instance of rotate enables it to be constant +folded. For example: + sumU . mapU (`rotate` 3) . replicateU 10000000 $ (7 :: Int) +goes to: + Main.$wfold = + \ (ww_sO7 :: Int#) (ww1_sOb :: Int#) -> + case ww1_sOb of wild_XM { + __DEFAULT -> Main.$wfold (+# ww_sO7 56) (+# wild_XM 1); + 10000000 -> ww_sO7 +whereas before it was left as a call to $wrotate. + +All other Bits instances seem to inline well enough on their +own to enable constant folding; for example 'shift': + sumU . mapU (`shift` 3) . replicateU 10000000 $ (7 :: Int) + goes to: + Main.$wfold = + \ (ww_sOb :: Int#) (ww1_sOf :: Int#) -> + case ww1_sOf of wild_XM { + __DEFAULT -> Main.$wfold (+# ww_sOb 56) (+# wild_XM 1); + 10000000 -> ww_sOb + } +-} + +-- Note [toIntegralSized optimization] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The code in 'toIntegralSized' relies on GHC optimizing away statically +-- decidable branches. +-- +-- If both integral types are statically known, GHC will be able optimize the +-- code significantly (for @-O1@ and better). +-- +-- For instance (as of GHC 7.8.1) the following definitions: +-- +-- > w16_to_i32 = toIntegralSized :: Word16 -> Maybe Int32 +-- > +-- > i16_to_w16 = toIntegralSized :: Int16 -> Maybe Word16 +-- +-- are translated into the following (simplified) /GHC Core/ language: +-- +-- > w16_to_i32 = \x -> Just (case x of _ { W16# x# -> I32# (word2Int# x#) }) +-- > +-- > i16_to_w16 = \x -> case eta of _ +-- > { I16# b1 -> case tagToEnum# (<=# 0 b1) of _ +-- > { False -> Nothing +-- > ; True -> Just (W16# (narrow16Word# (int2Word# b1))) +-- > } +-- > } diff --git a/libraries/base/GHC/Float.hs b/libraries/base/GHC/Float.hs index e25319214d..eae6edb253 100644 --- a/libraries/base/GHC/Float.hs +++ b/libraries/base/GHC/Float.hs @@ -55,8 +55,8 @@ module GHC.Float import Data.Maybe -import Data.Bits import GHC.Base +import GHC.Bits import GHC.List import GHC.Enum import GHC.Show diff --git a/libraries/base/GHC/Word.hs b/libraries/base/GHC/Word.hs index 4ff2cc4837..02dcdfcd1a 100644 --- a/libraries/base/GHC/Word.hs +++ b/libraries/base/GHC/Word.hs @@ -46,7 +46,6 @@ module GHC.Word ( eqWord64, neWord64, gtWord64, geWord64, ltWord64, leWord64 ) where -import Data.Bits import Data.Maybe #if WORD_SIZE_IN_BITS < 64 @@ -54,6 +53,7 @@ import GHC.IntWord64 #endif import GHC.Base +import GHC.Bits import GHC.Enum import GHC.Num import GHC.Real diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index 36642abea4..ac5cb24814 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -188,6 +188,7 @@ Library Foreign.Storable GHC.Arr GHC.Base + GHC.Bits GHC.ByteOrder GHC.Char GHC.Clock diff --git a/testsuite/tests/ghci/scripts/ghci064.stdout b/testsuite/tests/ghci/scripts/ghci064.stdout index 9190a68e67..d527dde6c4 100644 --- a/testsuite/tests/ghci/scripts/ghci064.stdout +++ b/testsuite/tests/ghci/scripts/ghci064.stdout @@ -40,8 +40,8 @@ instance Bounded Bool -- Defined in ‘GHC.Enum’ instance GHC.Generics.Generic Bool -- Defined in ‘GHC.Generics’ instance GHC.Ix.Ix Bool -- Defined in ‘GHC.Ix’ instance GHC.Generics.SingKind Bool -- Defined in ‘GHC.Generics’ -instance Data.Bits.Bits Bool -- Defined in ‘Data.Bits’ -instance Data.Bits.FiniteBits Bool -- Defined in ‘Data.Bits’ +instance GHC.Bits.Bits Bool -- Defined in ‘GHC.Bits’ +instance GHC.Bits.FiniteBits Bool -- Defined in ‘GHC.Bits’ instance Functor ((,) Int) -- Defined in ‘GHC.Base’ instance Foldable ((,) Int) -- Defined in ‘Data.Foldable’ instance Traversable ((,) Int) -- Defined in ‘Data.Traversable’ |