module CLaSH.Sized.Internal.Signed
(
Signed (..)
, size#
, pack#
, unpack#
, eq#
, neq#
, lt#
, ge#
, gt#
, le#
, enumFrom#
, enumFromThen#
, enumFromTo#
, enumFromThenTo#
, minBound#
, maxBound#
, (+#)
, (-#)
, (*#)
, negate#
, abs#
, fromInteger#
, plus#
, minus#
, times#
, quot#
, rem#
, div#
, mod#
, toInteger#
, and#
, or#
, xor#
, complement#
, shiftL#
, shiftR#
, rotateL#
, rotateR#
, resize#
, truncateB#
, minBoundSym#
)
where
import Control.DeepSeq (NFData (..))
import Control.Lens (Index, Ixed (..), IxValue)
import Data.Bits (Bits (..), FiniteBits (..))
import Data.Data (Data)
import Data.Default (Default (..))
import Data.Proxy (Proxy (..))
import Text.Read (Read (..), ReadPrec)
import GHC.TypeLits (KnownNat, Nat, type (+), natVal)
import GHC.TypeLits.Extra (Max)
import Language.Haskell.TH (TypeQ, appT, conT, litT, numTyLit, sigE)
import Language.Haskell.TH.Syntax (Lift(..))
import Test.QuickCheck.Arbitrary (Arbitrary (..), CoArbitrary (..),
arbitraryBoundedIntegral,
coarbitraryIntegral, shrinkIntegral)
import CLaSH.Class.BitPack (BitPack (..))
import CLaSH.Class.Num (ExtendingNum (..), SaturatingNum (..),
SaturationMode (..))
import CLaSH.Class.Resize (Resize (..))
import CLaSH.Prelude.BitIndex ((!), msb, replaceBit, split)
import CLaSH.Prelude.BitReduction (reduceAnd, reduceOr)
import CLaSH.Sized.Internal.BitVector (BitVector (BV), Bit, (++#), high, low)
import qualified CLaSH.Sized.Internal.BitVector as BV
import CLaSH.XException (ShowX (..), showsPrecXWith)
newtype Signed (n :: Nat) =
S { unsafeToInteger :: Integer}
deriving (Data)
size# :: KnownNat n => Signed n -> Int
size# bv = fromInteger (natVal bv)
instance NFData (Signed n) where
rnf (S i) = rnf i `seq` ()
instance Show (Signed n) where
show (S i) = show i
instance ShowX (Signed n) where
showsPrecX = showsPrecXWith showsPrec
instance KnownNat n => Read (Signed n) where
readPrec = fromIntegral <$> (readPrec :: ReadPrec Int)
instance KnownNat n => BitPack (Signed n) where
type BitSize (Signed n) = n
pack = pack#
unpack = unpack#
pack# :: forall n . KnownNat n => Signed n -> BitVector n
pack# (S i) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n))
in if i < 0 then BV (m + i) else BV i
unpack# :: forall n . KnownNat n => BitVector n -> Signed n
unpack# (BV i) =
let m = 1 `shiftL` fromInteger (natVal (Proxy @n) 1)
in if i >= m then S (i2*m) else S i
instance Eq (Signed n) where
(==) = eq#
(/=) = neq#
eq# :: Signed n -> Signed n -> Bool
eq# (S v1) (S v2) = v1 == v2
neq# :: Signed n -> Signed n -> Bool
neq# (S v1) (S v2) = v1 /= v2
instance Ord (Signed n) where
(<) = lt#
(>=) = ge#
(>) = gt#
(<=) = le#
lt#,ge#,gt#,le# :: Signed n -> Signed n -> Bool
lt# (S n) (S m) = n < m
ge# (S n) (S m) = n >= m
gt# (S n) (S m) = n > m
le# (S n) (S m) = n <= m
instance KnownNat n => Enum (Signed n) where
succ = (+# fromInteger# 1)
pred = (-# fromInteger# 1)
toEnum = fromInteger# . toInteger
fromEnum = fromEnum . toInteger#
enumFrom = enumFrom#
enumFromThen = enumFromThen#
enumFromTo = enumFromTo#
enumFromThenTo = enumFromThenTo#
enumFrom# :: KnownNat n => Signed n -> [Signed n]
enumFromThen# :: KnownNat n => Signed n -> Signed n -> [Signed n]
enumFromTo# :: Signed n -> Signed n -> [Signed n]
enumFromThenTo# :: Signed n -> Signed n -> Signed n -> [Signed n]
enumFrom# x = map fromInteger_INLINE [unsafeToInteger x ..]
enumFromThen# x y = map fromInteger_INLINE [unsafeToInteger x, unsafeToInteger y ..]
enumFromTo# x y = map S [unsafeToInteger x .. unsafeToInteger y]
enumFromThenTo# x1 x2 y = map S [unsafeToInteger x1, unsafeToInteger x2 .. unsafeToInteger y]
instance KnownNat n => Bounded (Signed n) where
minBound = minBound#
maxBound = maxBound#
minBound#,maxBound# :: KnownNat n => Signed n
minBound# = let res = S $ negate $ 2 ^ (natVal res 1) in res
maxBound# = let res = S $ 2 ^ (natVal res 1) 1 in res
instance KnownNat n => Num (Signed n) where
(+) = (+#)
() = (-#)
(*) = (*#)
negate = negate#
abs = abs#
signum s = if s < 0 then (1) else
if s > 0 then 1 else 0
fromInteger = fromInteger#
(+#), (-#), (*#) :: forall n . KnownNat n => Signed n -> Signed n -> Signed n
(S a) +# (S b) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n) 1)
z = a + b
in if z >= m then S (z 2*m) else
if z < negate m then S (z + 2*m) else S z
(S a) -# (S b) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n) 1)
z = a b
in if z < negate m then S (z + 2*m) else
if z >= m then S (z 2*m) else S z
(S a) *# (S b) = fromInteger_INLINE (a * b)
negate#,abs# :: forall n . KnownNat n => Signed n -> Signed n
negate# (S n) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n) 1)
z = negate n
in if z == m then S n else S z
abs# (S n) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n) 1)
z = abs n
in if z == m then S n else S z
fromInteger# :: KnownNat n => Integer -> Signed (n :: Nat)
fromInteger# = fromInteger_INLINE
fromInteger_INLINE :: forall n . KnownNat n => Integer -> Signed n
fromInteger_INLINE i = mask `seq` S res
where
mask = 1 `shiftL` fromInteger (natVal (Proxy @n) 1)
res = case divMod i mask of
(s,i') | even s -> i'
| otherwise -> i' mask
instance ExtendingNum (Signed m) (Signed n) where
type AResult (Signed m) (Signed n) = Signed (Max m n + 1)
plus = plus#
minus = minus#
type MResult (Signed m) (Signed n) = Signed (m + n)
times = times#
plus#, minus# :: Signed m -> Signed n -> Signed (Max m n + 1)
plus# (S a) (S b) = S (a + b)
minus# (S a) (S b) = S (a b)
times# :: Signed m -> Signed n -> Signed (m + n)
times# (S a) (S b) = S (a * b)
instance KnownNat n => Real (Signed n) where
toRational = toRational . toInteger#
instance KnownNat n => Integral (Signed n) where
quot = quot#
rem = rem#
div = div#
mod = mod#
quotRem n d = (n `quot#` d,n `rem#` d)
divMod n d = (n `div#` d,n `mod#` d)
toInteger = toInteger#
quot#,rem# :: Signed n -> Signed n -> Signed n
quot# (S a) (S b) = S (a `quot` b)
rem# (S a) (S b) = S (a `rem` b)
div#,mod# :: Signed n -> Signed n -> Signed n
div# (S a) (S b) = S (a `div` b)
mod# (S a) (S b) = S (a `mod` b)
toInteger# :: Signed n -> Integer
toInteger# (S n) = n
instance KnownNat n => Bits (Signed n) where
(.&.) = and#
(.|.) = or#
xor = xor#
complement = complement#
zeroBits = 0
bit i = replaceBit i high 0
setBit v i = replaceBit i high v
clearBit v i = replaceBit i low v
complementBit v i = replaceBit i (BV.complement# (v ! i)) v
testBit v i = v ! i == 1
bitSizeMaybe v = Just (size# v)
bitSize = size#
isSigned _ = True
shiftL v i = shiftL# v i
shiftR v i = shiftR# v i
rotateL v i = rotateL# v i
rotateR v i = rotateR# v i
popCount s = popCount (pack# s)
and#,or#,xor# :: KnownNat n => Signed n -> Signed n -> Signed n
and# (S a) (S b) = fromInteger_INLINE (a .&. b)
or# (S a) (S b) = fromInteger_INLINE (a .|. b)
xor# (S a) (S b) = fromInteger_INLINE (xor a b)
complement# :: KnownNat n => Signed n -> Signed n
complement# (S a) = fromInteger_INLINE (complement a)
shiftL#,shiftR#,rotateL#,rotateR# :: KnownNat n => Signed n -> Int -> Signed n
shiftL# _ b | b < 0 = error "'shiftL undefined for negative numbers"
shiftL# (S n) b = fromInteger_INLINE (shiftL n b)
shiftR# _ b | b < 0 = error "'shiftR undefined for negative numbers"
shiftR# (S n) b = fromInteger_INLINE (shiftR n b)
rotateL# _ b | b < 0 = error "'shiftL undefined for negative numbers"
rotateL# s@(S n) b = fromInteger_INLINE (l .|. r)
where
l = shiftL n b'
r = shiftR n b'' .&. mask
mask = 2 ^ b' 1
b' = b `mod` sz
b'' = sz b'
sz = fromInteger (natVal s)
rotateR# _ b | b < 0 = error "'shiftR undefined for negative numbers"
rotateR# s@(S n) b = fromInteger_INLINE (l .|. r)
where
l = shiftR n b' .&. mask
r = shiftL n b''
mask = 2 ^ b'' 1
b' = b `mod` sz
b'' = sz b'
sz = fromInteger (natVal s)
instance KnownNat n => FiniteBits (Signed n) where
finiteBitSize = size#
countLeadingZeros s = countLeadingZeros (pack# s)
countTrailingZeros s = countTrailingZeros (pack# s)
instance Resize Signed where
resize = resize#
zeroExtend s = unpack# (0 ++# pack s)
truncateB = truncateB#
resize# :: forall m n . (KnownNat n, KnownNat m) => Signed n -> Signed m
resize# s@(S i) | n' <= m' = extended
| otherwise = truncated
where
n = fromInteger (natVal s)
n' = shiftL 1 n
m' = shiftL mask 1
extended = S i
mask = 1 `shiftL` fromInteger (natVal (Proxy @m) 1)
i' = i `mod` mask
truncated = if testBit i (n1)
then S (i' mask)
else S i'
truncateB# :: KnownNat m => Signed (m + n) -> Signed m
truncateB# (S n) = fromInteger_INLINE n
instance KnownNat n => Default (Signed n) where
def = fromInteger# 0
instance KnownNat n => Lift (Signed n) where
lift s@(S i) = sigE [| fromInteger# i |] (decSigned (natVal s))
decSigned :: Integer -> TypeQ
decSigned n = appT (conT ''Signed) (litT $ numTyLit n)
instance KnownNat n => SaturatingNum (Signed n) where
satPlus SatWrap a b = a +# b
satPlus SatBound a b =
let r = plus# a b
(_,r') = split r
in case msb r `xor` msb r' of
0 -> unpack# r'
_ -> case msb a .&. msb b of
0 -> maxBound#
_ -> minBound#
satPlus SatZero a b =
let r = plus# a b
(_,r') = split r
in case msb r `xor` msb r' of
0 -> unpack# r'
_ -> fromInteger# 0
satPlus SatSymmetric a b =
let r = plus# a b
(_,r') = split r
in case msb r `xor` msb r' of
0 -> unpack# r'
_ -> case msb a .&. msb b of
0 -> maxBound#
_ -> minBoundSym#
satMin SatWrap a b = a -# b
satMin SatBound a b =
let r = minus# a b
(_,r') = split r
in case msb r `xor` msb r' of
0 -> unpack# r'
_ -> case msb a ++# msb b of
2 -> minBound#
_ -> maxBound#
satMin SatZero a b =
let r = minus# a b
(_,r') = split r
in case msb r `xor` msb r' of
0 -> unpack# r'
_ -> fromInteger# 0
satMin SatSymmetric a b =
let r = minus# a b
(_,r') = split r
in case msb r `xor` msb r' of
0 -> unpack# r'
_ -> case msb a ++# msb b of
2 -> minBoundSym#
_ -> maxBound#
satMult SatWrap a b = a *# b
satMult SatBound a b =
let r = times# a b
(rL,rR) = split r
overflow = complement (reduceOr (msb rR ++# pack rL)) .|.
reduceAnd (msb rR ++# pack rL)
in case overflow of
1 -> unpack# rR
_ -> case msb rL of
0 -> maxBound#
_ -> minBound#
satMult SatZero a b =
let r = times# a b
(rL,rR) = split r
overflow = complement (reduceOr (msb rR ++# pack rL)) .|.
reduceAnd (msb rR ++# pack rL)
in case overflow of
1 -> unpack# rR
_ -> fromInteger# 0
satMult SatSymmetric a b =
let r = times# a b
(rL,rR) = split r
overflow = complement (reduceOr (msb rR ++# pack rL)) .|.
reduceAnd (msb rR ++# pack rL)
in case overflow of
1 -> unpack# rR
_ -> case msb rL of
0 -> maxBound#
_ -> minBoundSym#
minBoundSym# :: KnownNat n => Signed n
minBoundSym# = minBound# +# fromInteger# 1
instance KnownNat n => Arbitrary (Signed n) where
arbitrary = arbitraryBoundedIntegral
shrink = shrinkSizedSigned
shrinkSizedSigned :: (KnownNat n, Integral (p n)) => p n -> [p n]
shrinkSizedSigned x | natVal x < 2 = case toInteger x of
0 -> []
_ -> [0]
| otherwise = shrinkIntegral x
instance KnownNat n => CoArbitrary (Signed n) where
coarbitrary = coarbitraryIntegral
type instance Index (Signed n) = Int
type instance IxValue (Signed n) = Bit
instance KnownNat n => Ixed (Signed n) where
ix i f s = unpack# <$> BV.replaceBit# (pack# s) i
<$> f (BV.index# (pack# s) i)