module CLaSH.Sized.Signed
( Signed
, resizeS_wrap
)
where
import Data.Bits
import Data.Default
import Data.Typeable
import Language.Haskell.TH
import Language.Haskell.TH.Syntax(Lift(..))
import GHC.TypeLits
import CLaSH.Bit
import CLaSH.Class.BitVector
import CLaSH.Class.Num
import CLaSH.Promoted.Ord
import CLaSH.Sized.Vector
newtype Signed (n :: Nat) = S Integer
deriving Typeable
instance Eq (Signed n) where
(==) = eqS
eqS :: (Signed n) -> (Signed n) -> Bool
(S n) `eqS` (S m) = n == m
instance Ord (Signed n) where
(<) = ltS
(>=) = geS
(>) = gtS
(<=) = leS
ltS,geS,gtS,leS :: Signed n -> Signed n -> Bool
ltS (S n) (S m) = n < m
geS (S n) (S m) = n >= m
gtS (S n) (S m) = n > m
leS (S n) (S m) = n <= m
instance KnownNat n => Enum (Signed n) where
succ = plusS (fromIntegerS 1)
pred = minS (fromIntegerS 1)
toEnum = fromIntegerS . toInteger
fromEnum = fromEnum . toIntegerS
enumFrom = enumFromS
enumFromThen = enumFromThenS
enumFromTo = enumFromToS
enumFromThenTo = enumFromThenToS
enumFromS :: KnownNat n => Signed n -> [Signed n]
enumFromThenS :: KnownNat n => Signed n -> Signed n -> [Signed n]
enumFromToS :: KnownNat n => Signed n -> Signed n -> [Signed n]
enumFromThenToS :: KnownNat n => Signed n -> Signed n -> Signed n -> [Signed n]
enumFromS x = map toEnum [fromEnum x ..]
enumFromThenS x y = map toEnum [fromEnum x, fromEnum y ..]
enumFromToS x y = map toEnum [fromEnum x .. fromEnum y]
enumFromThenToS x1 x2 y = map toEnum [fromEnum x1, fromEnum x2 .. fromEnum y]
instance KnownNat n => Bounded (Signed n) where
minBound = minBoundS
maxBound = maxBoundS
minBoundS,maxBoundS :: KnownNat n => Signed n
minBoundS = let res = S $ negate $ 2 ^ (natVal res 1) in res
maxBoundS = let res = S $ 2 ^ (natVal res 1) 1 in res
instance KnownNat n => Num (Signed n) where
(+) = plusS
() = minS
(*) = timesS
negate = negateS
abs = absS
signum = signumS
fromInteger = fromIntegerS
plusS,minS,timesS :: KnownNat n => Signed n -> Signed n -> Signed n
plusS (S a) (S b) = fromIntegerS_inlineable (a + b)
minS (S a) (S b) = fromIntegerS_inlineable (a b)
timesS (S a) (S b) = fromIntegerS_inlineable (a * b)
negateS,absS,signumS :: KnownNat n => Signed n -> Signed n
negateS (S n) = fromIntegerS_inlineable (0 n)
absS (S n) = fromIntegerS_inlineable (abs n)
signumS (S n) = fromIntegerS_inlineable (signum n)
fromIntegerS,fromIntegerS_inlineable :: KnownNat n => Integer -> Signed (n :: Nat)
fromIntegerS = fromIntegerS_inlineable
fromIntegerS_inlineable i
| nS == 0 = S 0
| otherwise = res
where
nS = natVal res
sz = 2 ^ (nS 1)
res = case divMod i sz of
(s,i') | even s -> S i'
| otherwise -> S (i' sz)
instance KnownNat (Max m n) => Add (Signed m) (Signed n) where
type AResult (Signed m) (Signed n) = Signed (Max m n)
plus = plusS2
minus = minusS2
plusS2, minusS2 :: KnownNat (Max m n) => Signed m -> Signed n -> Signed (Max m n)
plusS2 (S a) (S b) = fromIntegerS_inlineable (a + b)
minusS2 (S a) (S b) = fromIntegerS_inlineable (a b)
instance KnownNat (m + n) => Mult (Signed m) (Signed n) where
type MResult (Signed m) (Signed n) = Signed (m + n)
mult = multS2
multS2 :: KnownNat (m + n) => Signed m -> Signed n -> Signed (m + n)
multS2 (S a) (S b) = fromIntegerS_inlineable (a * b)
instance KnownNat n => Real (Signed n) where
toRational = toRational . toIntegerS
instance KnownNat n => Integral (Signed n) where
quot = quotS
rem = remS
div = divS
mod = modS
quotRem = quotRemS
divMod = divModS
toInteger = toIntegerS
quotS,remS,divS,modS :: KnownNat n => Signed n -> Signed n -> Signed n
quotS = (fst.) . quotRemS_inlineable
remS = (snd.) . quotRemS_inlineable
divS = (fst.) . divModS_inlineable
modS = (snd.) . divModS_inlineable
quotRemS,divModS :: KnownNat n => Signed n -> Signed n -> (Signed n, Signed n)
quotRemS n d = (n `quotS` d,n `remS` d)
divModS n d = (n `divS` d,n `modS` d)
quotRemS_inlineable,divModS_inlineable :: KnownNat n => Signed n -> Signed n -> (Signed n, Signed n)
(S a) `quotRemS_inlineable` (S b) = let (a',b') = a `quotRem` b
in (fromIntegerS_inlineable a', fromIntegerS_inlineable b')
(S a) `divModS_inlineable` (S b) = let (a',b') = a `divMod` b
in (fromIntegerS_inlineable a', fromIntegerS_inlineable b')
toIntegerS :: Signed n -> Integer
toIntegerS (S n) = n
instance KnownNat n => Bits (Signed n) where
(.&.) = andS
(.|.) = orS
xor = xorS
complement = complementS
bit = bitS
testBit = testBitS
bitSizeMaybe = Just . finiteBitSizeS
isSigned = const True
shiftL = shiftLS
shiftR = shiftRS
rotateL = rotateLS
rotateR = rotateRS
popCount = popCountS
andS,orS,xorS :: KnownNat n => Signed n -> Signed n -> Signed n
(S a) `andS` (S b) = fromIntegerS_inlineable (a .&. b)
(S a) `orS` (S b) = fromIntegerS_inlineable (a .|. b)
(S a) `xorS` (S b) = fromIntegerS_inlineable (xor a b)
complementS :: KnownNat n => Signed n -> Signed n
complementS = fromBitVector . vmap complement . toBitVector
bitS :: KnownNat n => Int -> Signed n
bitS i = res
where
sz = finiteBitSizeS res
res | sz > i = fromIntegerS_inlineable (bit i)
| otherwise = error $ concat [ "bit: "
, "Setting out-of-range bit position, size: "
, show sz
, ", position: "
, show i
]
testBitS :: KnownNat n => Signed n -> Int -> Bool
testBitS s@(S n) i
| sz > i = testBit n i
| otherwise = error $ concat [ "testBit: "
, "Setting out-of-range bit position, size: "
, show sz
, ", position: "
, show i
]
where
sz = finiteBitSizeS s
shiftLS,shiftRS,rotateLS,rotateRS :: KnownNat n => Signed n -> Int -> Signed n
shiftLS _ b | b < 0 = error "'shiftL'{Signed} undefined for negative numbers"
shiftLS (S n) b = fromIntegerS_inlineable (shiftL n b)
shiftRS _ b | b < 0 = error "'shiftR'{Signed} undefined for negative numbers"
shiftRS (S n) b = fromIntegerS_inlineable (shiftR n b)
rotateLS _ b | b < 0 = error "'shiftL'{Signed} undefined for negative numbers"
rotateLS n b = let b' = b `mod` finiteBitSizeS n
in shiftL n b' .|. shiftR n (finiteBitSizeS n b')
rotateRS _ b | b < 0 = error "'shiftR'{Signed} undefined for negative numbers"
rotateRS n b = let b' = b `mod` finiteBitSizeS n
in shiftR n b' .|. shiftL n (finiteBitSizeS n b')
popCountS :: Signed n -> Int
popCountS (S n) = popCount n
instance KnownNat n => FiniteBits (Signed n) where
finiteBitSize = finiteBitSizeS
finiteBitSizeS :: KnownNat n => Signed n -> Int
finiteBitSizeS = fromInteger . natVal
instance Show (Signed n) where
show (S n) = show n
instance KnownNat n => Default (Signed n) where
def = fromIntegerS 0
instance KnownNat n => Lift (Signed n) where
lift s@(S i) = sigE [| fromIntegerS i |] (decSigned (natVal s))
decSigned :: Integer -> TypeQ
decSigned n = appT (conT ''Signed) (litT $ numTyLit n)
instance BitVector (Signed n) where
type BitSize (Signed n) = n
toBV = toBitVector
fromBV = fromBitVector
toBitVector :: KnownNat n => Signed n -> Vec n Bit
toBitVector (S m) = vreverse $ vmap (\x -> if odd x then H else L) $ viterateI (`div` 2) m
fromBitVector :: KnownNat n => Vec n Bit -> Signed n
fromBitVector = fromBitList . reverse . toList
fromBitList :: KnownNat n => [Bit] -> Signed n
fromBitList l = fromIntegerS_inlineable
$ sum [ n
| (n,b) <- zip (iterate (*2) 1) l
, b == H
]
resizeS :: (KnownNat n, KnownNat m) => Signed n -> Signed m
resizeS s@(S n) | n' <= m' = extend
| otherwise = trunc
where
n' = fromInteger (natVal s)
m' = fromInteger (natVal extend)
extend = fromIntegerS_inlineable n
trunc = case toList (toBitVector s) of
(x:xs) -> fromBitList $ reverse $ x : (drop (n' m') xs)
_ -> error "resizeS impossible case: empty list"
resizeS_wrap :: KnownNat m => Signed n -> Signed m
resizeS_wrap (S n) = fromIntegerS_inlineable n
instance Resize Signed where
resize = resizeS