{-# LANGUAGE FlexibleContexts, UndecidableInstances, TypeFamilies, ParallelListComp, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, RankNTypes #-}
module Language.KansasLava.Utils where
import Control.Monad
import Data.Bits
import Language.KansasLava.Rep
import Language.KansasLava.Signal
import qualified Language.KansasLava.Stream as S
import Language.KansasLava.Types
import Data.Sized.Matrix as M
import Data.Sized.Signed as SI
high :: (sig ~ Signal i) => sig Bool
high = pureS True
low :: (sig ~ Signal i) => sig Bool
low = pureS False
and2 :: ( sig ~ Signal i) => sig Bool -> sig Bool -> sig Bool
and2 s1 s2 = primXS2 (\ a b -> case (unX a,unX b) of
(Just True,Just True) -> optX $ Just True
(Just False,_) -> optX $ Just False
(_,Just False) -> optX $ Just False
_ -> optX $ Nothing) "and2"
s1
s2
or2 :: ( sig ~ Signal i) => sig Bool -> sig Bool -> sig Bool
or2 s1 s2 = primXS2 (\ a b -> case (unX a,unX b) of
(Just False,Just False) -> optX $ Just False
(Just True,_) -> optX $ Just True
(_,Just True) -> optX $ Just True
_ -> optX $ Nothing ) "or2"
s1
s2
xor2 :: ( sig ~ Signal i) => sig Bool -> sig Bool -> sig Bool
xor2 s1 s2 = primXS2 (\ a b -> case (unX a,unX b) of
(Just a',Just b') -> optX $ Just (a' /= b')
_ -> optX $ Nothing ) "xor2"
s1
s2
nand2 :: ( sig ~ Signal i) => sig Bool -> sig Bool -> sig Bool
nand2 s1 s2 = primXS2 (\ a b -> case (unX a,unX b) of
(Just True,Just True) -> optX $ Just False
(Just False,_) -> optX $ Just True
(_,Just False) -> optX $ Just True
_ -> optX $ Nothing) "nand2"
s1
s2
nor2 :: ( sig ~ Signal i) => sig Bool -> sig Bool -> sig Bool
nor2 s1 s2 = primXS2 (\ a b -> case (unX a,unX b) of
(Just False,Just False) -> optX $ Just True
(Just True,_) -> optX $ Just False
(_,Just True) -> optX $ Just False
_ -> optX $ Nothing ) "nor2"
s1
s2
bitNot :: ( sig ~ Signal i) => sig Bool -> sig Bool
bitNot s1 = primS1 not "not" s1
testABit :: forall a i w sig . (Bits a, Rep a, Size w, Rep w, w ~ (W a), sig ~ Signal i)
=> sig a -> sig w -> sig Bool
testABit sig0 ix = sig1 .!. ix
where
sig1 :: sig (Matrix w Bool)
sig1 = (bitwise) sig0
isPositive :: forall sig i ix . (sig ~ Signal i, Size ix, Integral ix, Rep ix) => sig (Signed ix) -> sig Bool
isPositive a = bitNot $ testABit a (fromIntegral msb)
where msb = finiteBitSize a - 1
infixr 3 .&&.
infixr 2 .||.
infixr 2 .^.
(.&&.) :: ( sig ~ Signal i) => sig Bool -> sig Bool -> sig Bool
(.&&.) = and2
(.||.) :: ( sig ~ Signal i) => sig Bool -> sig Bool -> sig Bool
(.||.) = or2
(.^.) :: ( sig ~ Signal i) => sig Bool -> sig Bool -> sig Bool
(.^.) = xor2
funMap :: forall sig a b i . (sig ~ Signal i, Rep a, Rep b) => (a -> Maybe b) -> sig a -> sig b
funMap fn (Signal a ae) = mustAssignSLV $ Signal (fmap fn' a)
(D $ Port ("o0")
$ E
$ Entity (Prim "asyncRead")
[("o0",tB)]
[ ("i0",tMB,rom)
, ("i1",tA,unD ae)
])
where tA = repType (Witness :: Witness a)
tB = repType (Witness :: Witness b)
tMB = MatrixTy (Prelude.length all_a_bitRep) tB
undefB = unknownRepValue (Witness :: Witness b)
fn' a' = case unX a' of
Nothing -> optX Nothing
Just v -> optX (fn v)
all_a_bitRep :: [RepValue]
all_a_bitRep = allReps (Witness :: Witness a)
rom = Port "o0" $ E $ Entity (Prim "rom") [("o0",tMB)] [("defs",RomTy (Prelude.length all_a_bitRep),Lits lits)]
lits :: [RepValue]
lits = [ case unX (fromRep w_a) of
Nothing -> undefB
Just a' -> case fn a' of
Nothing -> undefB
Just b -> toRep (pureX b)
| w_a <- all_a_bitRep
]
mux :: forall sig a i . ( sig ~ Signal i, Rep a) => sig Bool -> (sig a,sig a) -> sig a
mux iSig (fSig,tSig) = primXS3 muxShallow "mux" iSig fSig tSig
muxShallow :: forall a . (Rep a) => X Bool -> X a -> X a -> X a
muxShallow i f t =
case unX i of
Nothing -> optX Nothing
Just True -> t
Just False -> f
eval :: forall a . (Rep a) => a -> ()
eval a = count $ unRepValue $ toRep (optX (Just a))
where count (Just True:rest) = count rest
count (Just False:rest) = count rest
count (Nothing:rest) = count rest
count [] = ()
evalX :: forall a . (Rep a) => X a -> ()
evalX a = count $ unRepValue $ toRep a
where count (Just True:rest) = count rest
count (Just False:rest) = count rest
count (Nothing:rest) = count rest
count [] = ()
muxMatrix
:: forall sig x a i
. ( sig ~ Signal i, Size x, Rep x, Rep a)
=> sig (Matrix x a)
-> sig x
-> sig a
muxMatrix = (.!.)
(.!.) :: forall sig x a i
. ( sig ~ Signal i, Size x, Rep x, Rep a)
=> sig (Matrix x a)
-> sig x
-> sig a
(.!.) mSig xSig = primS2 (flip (M.!)) "index" xSig mSig
boolOp :: forall a i sig . (Rep a, sig ~ Signal i) => (a -> a -> Bool) -> String -> sig a -> sig a -> sig Bool
boolOp fn nm a b = primS2 fn nm a b
infix 4 .==., .>=., .<=., .<., .>.
(.==.) :: forall a i sig . (Rep a, Eq a, sig ~ Signal i) => sig a -> sig a -> sig Bool
(.==.) = boolOp (==) ".==."
(./=.) :: forall a i sig . (Rep a, Eq a, sig ~ Signal i) => sig a -> sig a -> sig Bool
(./=.) xs ys = bitNot (xs .==. ys)
(.>=.) :: forall a i sig . (Rep a, Ord a, sig ~ Signal i) => sig a -> sig a -> sig Bool
(.>=.) = boolOp (>=) ".>=."
(.<=.) :: forall a i sig . (Rep a, Ord a, sig ~ Signal i) => sig a -> sig a -> sig Bool
(.<=.) = boolOp (<=) ".<=."
(.<.) :: forall a i sig . (Rep a, Ord a, sig ~ Signal i) => sig a -> sig a -> sig Bool
(.<.) = boolOp (<) ".<."
(.>.) :: forall a i sig . (Rep a, Ord a, sig ~ Signal i) => sig a -> sig a -> sig Bool
(.>.) = boolOp (>) ".>."
lavaId :: ( sig ~ Signal i, Rep a) => sig a -> sig a
lavaId a = primS1 id "id" a
ignoring :: ( sig ~ Signal i, Rep a, Rep b) => sig a -> sig b -> sig a
ignoring a b = primS2 const "const" a b
cASE :: (Rep b, sig ~ Signal i) => [(sig Bool,sig b)] -> sig b -> sig b
cASE [] def = def
cASE ((p,e):pes) def = mux p (cASE pes def, e)
bitwise :: forall sig a b i . ( sig ~ Signal i, Rep a, Rep b, W a ~ W b) => sig a -> sig b
bitwise a = primXS1 (fromRep . toRep) "coerce" a
coerce :: forall sig a b i . ( sig ~ Signal i, Rep a, Rep b, W a ~ W b) => (a -> b) -> sig a -> sig b
coerce f a = primXS1 g "coerce" a
where
g :: X a -> X b
g x = y'
where
y = optX $ liftM f $ unX x
y' | toRep x == toRep y = y
| otherwise = error "coerce fails to preserve bit pattern"
signedX :: forall a b . (Rep a, Rep b) => X a -> X b
signedX = id
. fromRep
. RepValue
. (\ m -> take (repWidth (Witness :: Witness b)) (m ++ repeat (last m)))
. unRepValue
. toRep
signed :: (Rep a, Rep b, Num b, sig ~ Signal i) => sig a -> sig b
signed a = primXS1 signedX "signed" a
unsignedX :: forall a b . (Rep a, Rep b) => X a -> X b
unsignedX = id
. fromRep
. RepValue
. (\ m -> take (repWidth (Witness :: Witness b)) (m ++ repeat (Just False)))
. unRepValue
. toRep
unsigned :: (Rep a, Rep b, Num b, sig ~ Signal i) => sig a -> sig b
unsigned a = primXS1 unsignedX "unsigned" a
mustAssignSLV :: (Rep a, sig ~ Signal i) => sig a -> sig a
mustAssignSLV (Signal a (D (Port "o0" (E (Entity (Prim nm) [("o0",tA)] inps)))))
= res
where
res = Signal a (D coer)
coer = Port "o0" (E (Entity (Prim "coerce") [("o0",tA)] [("i0",V width,new)]))
new = Port "o0" (E (Entity (Prim nm) [("o0",V width)] inps))
width = typeWidth tA
mustAssignSLV _ = error "mustAssignSLV: internal error"
unsafeId :: forall sig a b i . ( sig ~ Signal i, Rep a, Rep b) => sig a -> sig b
unsafeId a = primXS1 (fromRep . toRep) "coerce" a
unappendS :: forall a a1 a2 sig clk . ( sig ~ Signal clk, Rep a, Rep a1, Rep a2, W a ~ ADD (W a1) (W a2)) => sig a -> (sig a1, sig a2)
unappendS a = unpack (bitwise a :: sig (a1,a2))
appendS :: forall sig a b c clk . ( sig ~ Signal clk, Rep a, Rep b, Rep c, W c ~ ADD (W a) (W b)) => sig a -> sig b -> sig c
appendS x y = bitwise (pack (x,y) :: sig (a,b))
refinesFrom :: forall sig a i . (Clock i, sig ~ Signal i, Rep a) => sig a -> sig a -> sig Bool
refinesFrom a b = mkShallowS (S.zipWith fn (shallowS a) (shallowS b))
where
fn a' b' = let res = and [ case (vut,ref) of
(_,Nothing) -> True
(Just x,Just y) -> x == y
_ -> False
| (vut,ref) <- zip (unRepValue (toRep a'))
(unRepValue (toRep b'))
]
in optX (Just res)
iterateS :: (Rep a, Clock c, seq ~ Signal c)
=> (forall j . Signal j a -> Signal j a)
-> a -> seq a
iterateS f start = out where
out = register start (f out)
loopingIncS :: (Bounded a, Eq a, Num a, Rep a, sig ~ Signal i) => sig a -> sig a
loopingIncS a = mux (a .==. maxBound) (a + 1, pureS 0)
loopingDecS :: (Bounded a, Eq a, Num a, Rep a, sig ~ Signal i) => sig a -> sig a
loopingDecS a = mux (a .==. 0) (a - 1, pureS maxBound)