module CLaSH.Sized.Internal.Unsigned
(
Unsigned (..)
, size#
, pack#
, unpack#
, eq#
, neq#
, lt#
, ge#
, gt#
, le#
, enumFrom#
, enumFromThen#
, enumFromTo#
, enumFromThenTo#
, minBound#
, maxBound#
, (+#)
, (-#)
, (*#)
, negate#
, fromInteger#
, plus#
, minus#
, times#
, quot#
, rem#
, toInteger#
, and#
, or#
, xor#
, complement#
, shiftL#
, shiftR#
, rotateL#
, rotateR#
, resize#
)
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)
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 (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 Unsigned (n :: Nat) =
U { unsafeToInteger :: Integer }
deriving Data
size# :: KnownNat n => Unsigned n -> Int
size# u = fromInteger (natVal u)
instance NFData (Unsigned n) where
rnf (U i) = rnf i `seq` ()
instance Show (Unsigned n) where
show (U i) = show i
instance ShowX (Unsigned n) where
showsPrecX = showsPrecXWith showsPrec
instance KnownNat n => Read (Unsigned n) where
readPrec = fromIntegral <$> (readPrec :: ReadPrec Word)
instance BitPack (Unsigned n) where
type BitSize (Unsigned n) = n
pack = pack#
unpack = unpack#
pack# :: Unsigned n -> BitVector n
pack# (U i) = BV i
unpack# :: BitVector n -> Unsigned n
unpack# (BV i) = U i
instance Eq (Unsigned n) where
(==) = eq#
(/=) = neq#
eq# :: Unsigned n -> Unsigned n -> Bool
eq# (U v1) (U v2) = v1 == v2
neq# :: Unsigned n -> Unsigned n -> Bool
neq# (U v1) (U v2) = v1 /= v2
instance Ord (Unsigned n) where
(<) = lt#
(>=) = ge#
(>) = gt#
(<=) = le#
lt#,ge#,gt#,le# :: Unsigned n -> Unsigned n -> Bool
lt# (U n) (U m) = n < m
ge# (U n) (U m) = n >= m
gt# (U n) (U m) = n > m
le# (U n) (U m) = n <= m
instance KnownNat n => Enum (Unsigned 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 => Unsigned n -> [Unsigned n]
enumFromThen# :: KnownNat n => Unsigned n -> Unsigned n -> [Unsigned n]
enumFromTo# :: Unsigned n -> Unsigned n -> [Unsigned n]
enumFromThenTo# :: Unsigned n -> Unsigned n -> Unsigned n -> [Unsigned n]
enumFrom# x = map fromInteger_INLINE [unsafeToInteger x ..]
enumFromThen# x y = map fromInteger_INLINE [unsafeToInteger x, unsafeToInteger y ..]
enumFromTo# x y = map U [unsafeToInteger x .. unsafeToInteger y]
enumFromThenTo# x1 x2 y = map U [unsafeToInteger x1, unsafeToInteger x2 .. unsafeToInteger y]
instance KnownNat n => Bounded (Unsigned n) where
minBound = minBound#
maxBound = maxBound#
minBound# :: Unsigned n
minBound# = U 0
maxBound# :: forall n .KnownNat n => Unsigned n
maxBound# = let m = 1 `shiftL` fromInteger (natVal (Proxy @n))
in U (m 1)
instance KnownNat n => Num (Unsigned n) where
(+) = (+#)
() = (-#)
(*) = (*#)
negate = negate#
abs = id
signum bv = resize# (unpack# (reduceOr bv))
fromInteger = fromInteger#
(+#),(-#),(*#) :: forall n . KnownNat n => Unsigned n -> Unsigned n -> Unsigned n
(+#) (U i) (U j) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n))
z = i + j
in if z >= m then U (z m) else U z
(-#) (U i) (U j) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n))
z = i j
in if z < 0 then U (m + z) else U z
(*#) (U i) (U j) = fromInteger_INLINE (i * j)
negate# :: forall n . KnownNat n => Unsigned n -> Unsigned n
negate# (U 0) = U 0
negate# (U i) = sz `seq` U (sz i)
where
sz = 1 `shiftL` fromInteger (natVal (Proxy @n))
fromInteger# :: KnownNat n => Integer -> Unsigned n
fromInteger# = fromInteger_INLINE
fromInteger_INLINE :: forall n . KnownNat n => Integer -> Unsigned n
fromInteger_INLINE i = U (i `mod` sz)
where
sz = 1 `shiftL` fromInteger (natVal (Proxy @n))
instance (KnownNat m, KnownNat n) => ExtendingNum (Unsigned m) (Unsigned n) where
type AResult (Unsigned m) (Unsigned n) = Unsigned (Max m n + 1)
plus = plus#
minus = minus#
type MResult (Unsigned m) (Unsigned n) = Unsigned (m + n)
times = times#
plus# :: Unsigned m -> Unsigned n -> Unsigned (Max m n + 1)
plus# (U a) (U b) = U (a + b)
minus# :: forall m n . (KnownNat m, KnownNat n) => Unsigned m -> Unsigned n
-> Unsigned (Max m n + 1)
minus# (U a) (U b) =
let sz = fromInteger (natVal (Proxy @(Max m n + 1)))
mask = 1 `shiftL` sz
z = a b
in if z < 0 then U (mask + z) else U z
times# :: Unsigned m -> Unsigned n -> Unsigned (m + n)
times# (U a) (U b) = U (a * b)
instance KnownNat n => Real (Unsigned n) where
toRational = toRational . toInteger#
instance KnownNat n => Integral (Unsigned n) where
quot = quot#
rem = rem#
div = quot#
mod = rem#
quotRem n d = (n `quot#` d,n `rem#` d)
divMod n d = (n `quot#` d,n `rem#` d)
toInteger = toInteger#
quot#,rem# :: Unsigned n -> Unsigned n -> Unsigned n
quot# (U i) (U j) = U (i `quot` j)
rem# (U i) (U j) = U (i `rem` j)
toInteger# :: Unsigned n -> Integer
toInteger# (U i) = i
instance KnownNat n => Bits (Unsigned 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 == high
bitSizeMaybe v = Just (size# v)
bitSize = size#
isSigned _ = False
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 u = popCount (pack# u)
and# :: Unsigned n -> Unsigned n -> Unsigned n
and# (U v1) (U v2) = U (v1 .&. v2)
or# :: Unsigned n -> Unsigned n -> Unsigned n
or# (U v1) (U v2) = U (v1 .|. v2)
xor# :: Unsigned n -> Unsigned n -> Unsigned n
xor# (U v1) (U v2) = U (v1 `xor` v2)
complement# :: KnownNat n => Unsigned n -> Unsigned n
complement# (U i) = fromInteger_INLINE (complement i)
shiftL#, rotateL#, rotateR# :: KnownNat n => Unsigned n -> Int -> Unsigned n
shiftL# (U v) i
| i < 0 = error
$ "'shiftL undefined for negative number: " ++ show i
| otherwise = fromInteger_INLINE (shiftL v i)
shiftR# :: Unsigned n -> Int -> Unsigned n
shiftR# (U v) i
| i < 0 = error
$ "'shiftR undefined for negative number: " ++ show i
| otherwise = U (shiftR v i)
rotateL# _ b | b < 0 = error "'shiftL undefined for negative numbers"
rotateL# bv@(U n) b = fromInteger_INLINE (l .|. r)
where
l = shiftL n b'
r = shiftR n b''
b' = b `mod` sz
b'' = sz b'
sz = fromInteger (natVal bv)
rotateR# _ b | b < 0 = error "'shiftR undefined for negative numbers"
rotateR# bv@(U n) b = fromInteger_INLINE (l .|. r)
where
l = shiftR n b'
r = shiftL n b''
b' = b `mod` sz
b'' = sz b'
sz = fromInteger (natVal bv)
instance KnownNat n => FiniteBits (Unsigned n) where
finiteBitSize = size#
countLeadingZeros u = countLeadingZeros (pack# u)
countTrailingZeros u = countTrailingZeros (pack# u)
instance Resize Unsigned where
resize = resize#
zeroExtend = extend
truncateB = resize#
resize# :: forall n m . KnownNat m => Unsigned n -> Unsigned m
resize# (U i) = let m = 1 `shiftL` fromInteger (natVal (Proxy @m))
in if i >= m then fromInteger_INLINE i else U i
instance Default (Unsigned n) where
def = minBound#
instance KnownNat n => Lift (Unsigned n) where
lift u@(U i) = sigE [| fromInteger# i |] (decUnsigned (natVal u))
decUnsigned :: Integer -> TypeQ
decUnsigned n = appT (conT ''Unsigned) (litT $ numTyLit n)
instance KnownNat n => SaturatingNum (Unsigned n) where
satPlus SatWrap a b = a +# b
satPlus SatZero a b =
let r = plus# a b
in case msb r of
0 -> resize# r
_ -> minBound#
satPlus _ a b =
let r = plus# a b
in case msb r of
0 -> resize# r
_ -> maxBound#
satMin SatWrap a b = a -# b
satMin _ a b =
let r = minus# a b
in case msb r of
0 -> resize# r
_ -> minBound#
satMult SatWrap a b = a *# b
satMult SatZero a b =
let r = times# a b
(rL,rR) = split r
in case rL of
0 -> unpack# rR
_ -> minBound#
satMult _ a b =
let r = times# a b
(rL,rR) = split r
in case rL of
0 -> unpack# rR
_ -> maxBound#
instance KnownNat n => Arbitrary (Unsigned n) where
arbitrary = arbitraryBoundedIntegral
shrink = BV.shrinkSizedUnsigned
instance KnownNat n => CoArbitrary (Unsigned n) where
coarbitrary = coarbitraryIntegral
type instance Index (Unsigned n) = Int
type instance IxValue (Unsigned n) = Bit
instance KnownNat n => Ixed (Unsigned n) where
ix i f s = unpack# <$> BV.replaceBit# (pack# s) i
<$> f (BV.index# (pack# s) i)