module Language.KansasLava.Signal where
import Control.Applicative
import Control.Monad (liftM, liftM2, liftM3)
import Data.List as List
import Data.Bits
import Prelude
import Data.Sized.Ix
import Data.Sized.Matrix as M
import Language.KansasLava.Stream (Stream(Cons))
import Language.KansasLava.Rep
import qualified Language.KansasLava.Stream as S
import Language.KansasLava.Types
data Signal (c :: *) a = Signal (S.Stream (X a)) (D a)
type Seq a = Signal CLK a
shallowS :: Signal c a -> S.Stream (X a)
shallowS (Signal a _) = a
deepS :: Signal c a -> D a
deepS (Signal _ d) = d
deepMapS :: (D a -> D a) -> Signal c a -> Signal c a
deepMapS f (Signal a d) = (Signal a (f d))
shallowMapS :: (S.Stream (X a) -> S.Stream (X a)) -> Signal c a -> Signal c a
shallowMapS f (Signal a d) = (Signal (f a) d)
pureS :: (Rep a) => a -> Signal i a
pureS a = Signal (pure (pureX a)) (D $ Lit $ toRep $ pureX a)
witnessS :: (Rep a) => Witness a -> Signal i a -> Signal i a
witnessS (Witness) = id
mkDeepS :: D a -> Signal c a
mkDeepS = Signal (error "incorrect use of shallow Signal")
mkShallowS :: (Clock c) => S.Stream (X a) -> Signal c a
mkShallowS s = Signal s (D $ Error "incorrect use of deep Signal")
undefinedS :: forall a sig clk . (Rep a, sig ~ Signal clk) => sig a
undefinedS = Signal (pure $ (unknownX :: X a))
(D $ Lit $ toRep (unknownX :: X a))
commentS :: forall a sig clk . (Rep a, sig ~ Signal clk) => String -> sig a -> sig a
commentS msg = idS (Comment [msg])
idS :: forall a sig clk . (Rep a, sig ~ Signal clk) => Id -> sig a -> sig a
idS id' (Signal a ae) = Signal a $ D $ Port "o0" $ E
$ Entity id'
[("o0",repType (Witness :: Witness a))]
[("i0",repType (Witness :: Witness a),unD $ ae)]
primXS :: (Rep a) => X a -> String -> Signal i a
primXS a nm = Signal (pure a) (entityD nm)
primXS1 :: forall a b i . (Rep a, Rep b) => (X a -> X b) -> String -> Signal i a -> Signal i b
primXS1 f nm (Signal a1 ae1) = Signal (fmap f a1) (entityD1 nm ae1)
primXS2 :: forall a b c i . (Rep a, Rep b, Rep c) => (X a -> X b -> X c) -> String -> Signal i a -> Signal i b -> Signal i c
primXS2 f nm (Signal a1 ae1) (Signal a2 ae2)
= Signal (S.zipWith f a1 a2)
(entityD2 nm ae1 ae2)
primXS3 :: forall a b c d i . (Rep a, Rep b, Rep c, Rep d)
=> (X a -> X b -> X c -> X d) -> String -> Signal i a -> Signal i b -> Signal i c -> Signal i d
primXS3 f nm (Signal a1 ae1) (Signal a2 ae2) (Signal a3 ae3) = Signal (S.zipWith3 f a1 a2 a3)
(entityD3 nm ae1 ae2 ae3)
primS :: (Rep a) => a -> String -> Signal i a
primS a nm = primXS (pureX a) nm
primS1 :: (Rep a, Rep b) => (a -> b) -> String -> Signal i a -> Signal i b
primS1 f nm = primXS1 (\ a -> optX $ liftM f (unX a)) nm
primS2 :: (Rep a, Rep b, Rep c) => (a -> b -> c) -> String -> Signal i a -> Signal i b -> Signal i c
primS2 f nm = primXS2 (\ a b -> optX $ liftM2 f (unX a) (unX b)) nm
primS3 :: (Rep a, Rep b, Rep c, Rep d) => (a -> b -> c -> d) -> String -> Signal i a -> Signal i b -> Signal i c -> Signal i d
primS3 f nm = primXS3 (\ a b c -> optX $ liftM3 f (unX a) (unX b) (unX c)) nm
instance (Rep a) => Show (Signal c a) where
show (Signal vs _) = show' "" vs
where
show' end (Cons a opt_as) = showRep a ++ maybe end (\ as -> " | " ++ show' " ." as) opt_as
instance (Rep a, Eq a) => Eq (Signal c a) where
(Signal _ _) == (Signal _ _) = error "undefined: Eq over a Signal"
instance (Num a, Rep a) => Num (Signal i a) where
s1 + s2 = primS2 (+) "+" s1 s2
s1 s2 = primS2 () "-" s1 s2
s1 * s2 = primS2 (*) "*" s1 s2
negate s1 = primS1 (negate) "negate" s1
abs s1 = primS1 (abs) "abs" s1
signum s1 = primS1 (signum) "signum" s1
fromInteger n = pureS (fromInteger n)
instance (Bounded a, Rep a) => Bounded (Signal i a) where
minBound = pureS $ minBound
maxBound = pureS $ maxBound
instance (Show a, Bits a, Rep a) => Bits (Signal i a) where
s1 .&. s2 = primS2 (.&.) "and2" s1 s2
s1 .|. s2 = primS2 (.|.) "or2" s1 s2
s1 `xor` s2 = primS2 (xor) "xor2" s1 s2
s1 `shiftL` n = primS2 (shiftL) ("shiftL" ++ if isSigned s1 then "A" else "") s1 (pureS n)
s1 `shiftR` n = primS2 (shiftR) ("shiftR" ++ if isSigned s1 then "A" else "") s1 (pureS n)
s1 `rotateL` n = primS2 (rotateL) "rotateL" s1 (pureS n)
s1 `rotateR` n = primS2 (rotateR) "rotateR" s1 (pureS n)
complement s = primS1 (complement) "complement" s
bitSize s = typeWidth (typeOfS s)
isSigned s = isTypeSigned (typeOfS s)
instance (Eq a, Show a, Fractional a, Rep a) => Fractional (Signal i a) where
s1 / s2 = primS2 (/) "/" s1 s2
recip s1 = primS1 (recip) "recip" s1
fromRational r = pureS (fromRational r :: a)
instance (Rep a, Enum a) => Enum (Signal i a) where
toEnum = error "toEnum not supported"
fromEnum = error "fromEnum not supported"
instance (Ord a, Rep a) => Ord (Signal i a) where
compare _ _ = error "compare not supported for Comb"
(<) _ _ = error "(<) not supported for Comb"
(>=) _ _ = error "(>=) not supported for Comb"
(>) _ _ = error "(>) not supported for Comb"
(<=)_ _ = error "(<=) not supported for Comb"
s1 `max` s2 = primS2 max "max" s1 s2
s1 `min` s2 = primS2 max "min" s1 s2
instance (Rep a, Real a) => Real (Signal i a) where
toRational = error "toRational not supported for Comb"
instance (Rep a, Integral a) => Integral (Signal i a) where
quot num dom = primS2 quot "quot" num dom
rem num dom = primS2 rem "rem" num dom
div num dom = primS2 div "div" num dom
mod num dom = primS2 mod "mod" num dom
quotRem num dom = (quot num dom, rem num dom)
divMod num dom = (div num dom, mod num dom)
toInteger = error "toInteger (Signal {})"
toS :: (Clock c, Rep a) => [a] -> Signal c a
toS = toS' . map Just
toS' :: (Clock c, Rep a) => [Maybe a] -> Signal c a
toS' = toSX . map optX
toSX :: forall a c . (Clock c, Rep a) => [X a] -> Signal c a
toSX xs = mkShallowS (S.fromFiniteList xs unknownX)
fromS :: (Rep a) => Signal c a -> [Maybe a]
fromS = fmap unX . S.toList . shallowS
fromSX :: (Rep a) => Signal c a -> [X a]
fromSX = S.toList . shallowS
takeS :: (Rep a, Clock c) => Int -> Signal c a -> Signal c a
takeS n s = mkShallowS (S.fromFiniteList (take n (S.toList (shallowS s))) unknownX)
cmpSignalRep :: forall a c . (Rep a) => Int -> Signal c a -> Signal c a -> Bool
cmpSignalRep depth s1 s2 = and $ take depth $ S.toList $ S.zipWith cmpRep
(shallowS s1)
(shallowS s2)
instance Dual (Signal c a) where
dual c d = Signal (shallowS c) (deepS d)
typeOfS :: forall w clk sig . (Rep w, sig ~ Signal clk) => sig w -> Type
typeOfS _ = repType (Witness :: Witness w)
class Pack clk a where
type Unpacked clk a
pack :: Unpacked clk a -> Signal clk a
unpack :: Signal clk a -> Unpacked clk a
mapPacked :: (Pack i a, Pack i b, sig ~ Signal i) => (Unpacked i a -> Unpacked i b) -> sig a -> sig b
mapPacked f = pack . f . unpack
zipPacked :: (Pack i a, Pack i b, Pack i c, sig ~ Signal i)
=> (Unpacked i a -> Unpacked i b -> Unpacked i c)
-> sig a -> sig b -> sig c
zipPacked f x y = pack $ f (unpack x) (unpack y)
instance (Rep a, Rep b) => Pack i (a,b) where
type Unpacked i (a,b) = (Signal i a,Signal i b)
pack (a,b) = primS2 (,) "pair" a b
unpack ab = ( primS1 (fst) "fst" ab
, primS1 (snd) "snd" ab
)
instance (Rep a, Rep b, Rep c) => Pack i (a,b,c) where
type Unpacked i (a,b,c) = (Signal i a,Signal i b, Signal i c)
pack (a,b,c) = primS3 (,,) "triple" a b c
unpack abc = ( primS1 (\(x,_,_) -> x) "fst3" abc
, primS1 (\(_,x,_) -> x) "snd3" abc
, primS1 (\(_,_,x) -> x) "thd3" abc
)
instance (Rep a) => Pack i (Maybe a) where
type Unpacked i (Maybe a) = (Signal i Bool, Signal i a)
pack (a,b) = primXS2 (\ a' b' -> case unX a' of
Nothing -> optX Nothing
Just False -> optX $ Just Nothing
Just True -> optX $ case unX b' of
Nothing -> Nothing
Just v -> Just (Just v))
"pair" a b
unpack ma = ( primXS1 (\ a -> case unX a of
Nothing -> optX Nothing
Just Nothing -> optX (Just False)
Just (Just _) -> optX (Just True))
"fst" ma
, primXS1 (\ a -> case unX a of
Nothing -> optX Nothing
Just Nothing -> optX Nothing
Just (Just v) -> optX (Just v))
"snd" ma
)
unpackMatrix :: (Rep a, Size x, sig ~ Signal clk) => sig (M.Matrix x a) -> M.Matrix x (sig a)
unpackMatrix a = unpack a
packMatrix :: (Rep a, Size x, sig ~ Signal clk) => M.Matrix x (sig a) -> sig (M.Matrix x a)
packMatrix a = pack a
instance (Rep a, Size ix) => Pack clk (Matrix ix a) where
type Unpacked clk (Matrix ix a) = Matrix ix (Signal clk a)
pack m = Signal shallow
deep
where
shallow :: (S.Stream (X (Matrix ix a)))
shallow = id
$ S.fromList
$ fmap XMatrix
$ fmap M.fromList
$ List.transpose
$ fmap S.toList
$ fmap shallowS
$ M.toList
$ m
deep :: D (Matrix ix a)
deep = D
$ Port "o0"
$ E
$ Entity (Prim "concat")
[("o0",repType (Witness :: Witness (Matrix ix a)))]
[ ("i" ++ show i,repType (Witness :: Witness a),unD $ deepS $ x)
| (x,i) <- zip (M.toList m) ([0..] :: [Int])
]
unpack ms = forAll $ \ i -> Signal (shallow i) (deep i)
where mx :: (Size ix) => Matrix ix Integer
mx = matrix (Prelude.zipWith (\ _ b -> b) (M.indices mx) [0..])
deep i = D
$ Port "o0"
$ E
$ Entity (Prim "index")
[("o0",repType (Witness :: Witness a))]
[("i0",GenericTy,Generic (mx ! i))
,("i1",repType (Witness :: Witness (Matrix ix a)),unD $ deepS ms)
]
shallow i = fmap (liftX (M.! i)) (shallowS ms)
delay :: forall a clk . (Rep a, Clock clk) => Signal clk a -> Signal clk a
delay ~(Signal line eline) = res
where
def = optX $ Nothing
res = Signal sres1 (D $ Port ("o0") $ E $ entity)
sres0 = line
sres1 = S.Cons def (Just sres0)
entity = Entity (Prim "delay")
[("o0", typeOfS res)]
[("i0", typeOfS res, unD eline),
("clk",ClkTy, Pad "clk"),
("rst",B, Pad "rst")
]
delays :: forall a clk . (Rep a, Clock clk) => Int -> Signal clk a -> Signal clk a
delays n ss = iterate delay ss !! n
register :: forall a clk . (Rep a, Clock clk) => a -> Signal clk a -> Signal clk a
register first ~(Signal line eline) = res
where
def = optX $ Just first
rep = toRep def
res = Signal sres1 (D $ Port ("o0") $ E $ entity)
sres0 = line
sres1 = S.Cons def (Just sres0)
entity = Entity (Prim "register")
[("o0", typeOfS res)]
[("i0", typeOfS res, unD eline),
("def",GenericTy,Generic (fromRepToInteger rep)),
("clk",ClkTy, Pad "clk"),
("rst",B, Pad "rst")
]
registers :: forall a clk . (Rep a, Clock clk) => Int -> a -> Signal clk a -> Signal clk a
registers n def ss = iterate (register def) ss !! n
entityD :: forall a . (Rep a) => String -> D a
entityD nm = D $ Port "o0" $ E $ Entity (Prim nm) [("o0",repType (Witness :: Witness a))]
[]
entityD1 :: forall a1 a . (Rep a, Rep a1) => String -> D a1 -> D a
entityD1 nm (D a1)
= D $ Port "o0" $ E $ Entity (Prim nm) [("o0",repType (Witness :: Witness a))]
[("i0",repType (Witness :: Witness a1),a1)]
entityD2 :: forall a1 a2 a . (Rep a, Rep a1, Rep a2) => String -> D a1 -> D a2 -> D a
entityD2 nm (D a1) (D a2)
= D $ Port "o0" $ E $ Entity (Prim nm) [("o0",repType (Witness :: Witness a))]
[("i0",repType (Witness :: Witness a1),a1)
,("i1",repType (Witness :: Witness a2),a2)]
entityD3 :: forall a1 a2 a3 a . (Rep a, Rep a1, Rep a2, Rep a3) => String -> D a1 -> D a2 -> D a3 -> D a
entityD3 nm (D a1) (D a2) (D a3)
= D $ Port "o0" $ E $ Entity (Prim nm) [("o0",repType (Witness :: Witness a))]
[("i0",repType (Witness :: Witness a1),a1)
,("i1",repType (Witness :: Witness a2),a2)
,("i2",repType (Witness :: Witness a3),a3)]
pureD :: (Rep a) => a -> D a
pureD a = pureXD (pureX a)
pureXD :: (Rep a) => X a -> D a
pureXD a = D $ Lit $ toRep a