module Language.KansasLava.Protocols.Patch
where
import Language.KansasLava.Protocols.Enabled
import Language.KansasLava.Protocols.Types
import Language.KansasLava.Rep
import Language.KansasLava.Types
import Language.KansasLava.Utils
import Language.KansasLava.Signal
import Data.Sized.Unsigned (U8)
import Data.Sized.Matrix as M
import qualified Data.ByteString.Lazy as B
import Control.Applicative
import Control.Monad.Fix
import Prelude
type Patch lhs_in rhs_out
lhs_out rhs_in
= (lhs_in,rhs_in) -> (lhs_out,rhs_out)
outputP :: a -> Patch () a
() ()
outputP a = \ _ -> ((),a)
runP :: (Unit u1, Unit u2)
=> Patch u1 a
u2 () -> a
runP p = a
where
(_,a) = p (unit,unit)
execP :: Patch a b
c d
-> (a,d) -> (c,b)
execP = id
emptyP :: Patch a a
b b
emptyP ~(a,b) = (b,a)
fstP :: Patch a b
c e -> Patch (a :> f) (b :> f)
(c :> g) (e :> g)
fstP p = p `stackP` emptyP
sndP :: Patch a b
c d -> Patch (f :> a) (f :> b)
(g :> c) (g :> d)
sndP p = emptyP `stackP` p
forwardP :: (li -> ro)
-> Patch li ro
b b
forwardP f1 ~(li,ri) = (ri,f1 li)
backwardP :: (ri -> lo)
-> Patch a a
lo ri
backwardP f2 ~(li,ri) = (f2 ri,li)
infixr 3 `stackP`
stackP :: Patch li1 ro1
lo1 ri1
-> Patch li2 ro2
lo2 ri2
-> Patch (li1 :> li2) (ro1 :> ro2)
(lo1 :> lo2) (ri1 :> ri2)
stackP p1 p2 inp = (lo1 :> lo2,ro1 :> ro2)
where
(li1 :> li2,ri1 :> ri2) = inp
(lo1,ro1) = p1 (li1,ri1)
(lo2,ro2) = p2 (li2,ri2)
matrixStackP :: (m ~ (Matrix x), Size x)
=> m (Patch li ro
lo ri)
-> Patch (m li) (m ro)
(m lo) (m ri)
matrixStackP m inp = ( fmap (\ (l,_) -> l) m'
, fmap (\ (_,r) -> r) m'
)
where
(m_li,m_ri) = inp
m' = (\ p li ri -> p (li,ri)) <$> m <*> m_li <*> m_ri
loopP :: Patch (a :> b) (a :> c)
(d :> e) (d :> f)
-> Patch b c
e f
loopP g ~(b,f) = (e,c)
where
(d:>e,a:>c) = g (a:>b,d:>f)
openP :: Patch c (() :> c)
d (() :> d)
openP = forwardP (\ a -> (() :> a)) $$
backwardP (\ ~(_ :> a) -> a)
mapP :: forall a b c sig ack . (Rep a, Rep b, Clock c, sig ~ Signal c)
=> (forall clk' . Signal clk' a -> Signal clk' b)
-> Patch (sig (Enabled a)) (sig (Enabled b))
(ack) (ack)
mapP = forwardP . mapEnabled
class Unit unit where
unit :: unit
unUnit :: (Unit unit) => unit -> ()
unUnit _ = ()
instance Unit () where unit = ()
instance (Unit a,Unit b) => Unit (a,b) where unit = (unit,unit)
instance (Unit a,Unit b) => Unit (a :> b) where unit = (unit :> unit)
instance (Unit a,Size x) => Unit (Matrix x a) where unit = pure unit
rawReadP :: FilePath -> IO (Patch () [Maybe U8]
() ())
rawReadP fileName = do
fileContents <- B.readFile fileName
return $ outputP $ map (Just . fromIntegral) $ B.unpack fileContents
readP :: (Read a)
=> FilePath -> IO (Patch () [Maybe a]
() ())
readP fileName = do
fileContents <- readFile fileName
return $ outputP $ map (Just . read) $ words $ fileContents
rawWriteP :: (Unit u1, Unit u2)
=> FilePath
-> Int
-> Patch u1 [Maybe U8]
u2 ()
-> IO ()
rawWriteP fileName n patch = do
B.writeFile fileName $ B.pack [ fromIntegral x | Just x <- take n $ runP patch ]
writeP :: (Show a, Unit u1, Unit u2)
=> FilePath
-> Int
-> Patch u1 [Maybe a]
u2 ()
-> IO ()
writeP fileName n patch = do
writeFile fileName $ unlines [ show x | Just x <- take n $ runP patch ]
infixr 5 $$
($$) ::
Patch li1 o
lo1 i
-> Patch o ro2
i ri2
-> Patch li1 ro2
lo1 ri2
(p1 $$ p2) inp = (lhs_out1,rhs_out2)
where
(lhs_in,rhs_in) = inp
(lhs_out1,rhs_out1) = p1 (lhs_in,lhs_out2)
(lhs_out2,rhs_out2) = p2 (rhs_out1,rhs_in)
readyToAckBridge :: forall a c sig . (Rep a, Clock c, sig ~ Signal c)
=> Patch (sig (Enabled a)) (sig (Enabled a))
(sig Ready) (sig Ack)
readyToAckBridge ~(inp, ack_in0) = (toReady ready, out)
where
(in_en, in_val) = unpack inp
ack_in = fromAck ack_in0
captureData = in_en .&&. bitNot dataHeld .&&. bitNot ack_in
dataHolder = delay
$ cASE [ (captureData, in_val)
] dataHolder
dataHeld = register False
$ cASE [ (captureData, high)
, (ack_in, low)
] dataHeld
out = cASE [ (dataHeld, packEnabled dataHeld dataHolder)
] inp
ready = bitNot dataHeld
ackToReadyBridge :: (Rep a, Clock c, sig ~ Signal c)
=> Patch (sig (Enabled a)) (sig (Enabled a))
(sig Ack) (sig Ready)
ackToReadyBridge ~(inp, ready_in) = (toAck ack, out)
where
out = inp
ack = (fromReady ready_in) .&&. (isEnabled inp)
dupP :: forall c sig a . (Clock c, sig ~ Signal c, Rep a)
=> Patch (sig (Enabled a)) (sig (Enabled a) :> sig (Enabled a))
(sig Ack) (sig Ack :> sig Ack)
dupP ~(inp,ack1 :> ack2) = (toAck have_read,out1 :> out2)
where
have_read = (state .==. 0) .&&. isEnabled inp
written1 = (state ./=. 0) .&&. fromAck ack1
written2 = (state ./=. 0) .&&. fromAck ack2
state :: sig X4
state = register 0
$ cASE [ (have_read, pureS 1)
, (written1 .&&. written2, pureS 0)
, (written1 .&&. state .==. 1, pureS 3)
, (written2 .&&. state .==. 1, pureS 2)
, (written1 .&&. state .==. 2, pureS 0)
, (written2 .&&. state .==. 3, pureS 0)
] state
store :: sig a
store = cASE [ (have_read,enabledVal inp)
]
$ delay store
out1 = packEnabled (state .==. 1 .||. state .==. 2) store
out2 = packEnabled (state .==. 1 .||. state .==. 3) store
matrixDupP :: (Clock c, sig ~ Signal c, Rep a, Size x)
=> Patch (sig (Enabled a)) (Matrix x (sig (Enabled a)))
(sig Ack) (Matrix x (sig Ack))
matrixDupP = ackToReadyBridge $$ matrixDupP' $$ matrixStackP (pure readyToAckBridge) where
matrixDupP' ~(inp,readys) = (toReady go, pure out)
where
go = foldr1 (.&&.) $ map fromReady $ M.toList readys
out = packEnabled (go .&&. isEnabled inp) (enabledVal inp)
unzipP :: (Clock c, sig ~ Signal c, Rep a, Rep b)
=> Patch (sig (Enabled (a,b))) (sig (Enabled a) :> sig (Enabled b))
(sig Ack) (sig Ack :> sig Ack)
unzipP = dupP $$
stackP (forwardP $ mapEnabled (fst . unpack))
(forwardP $ mapEnabled (snd . unpack))
matrixUnzipP :: (Clock c, sig ~ Signal c, Rep a, Rep x, Size x)
=> Patch (sig (Enabled (Matrix x a))) (Matrix x (sig (Enabled a)))
(sig Ack) (Matrix x (sig Ack))
matrixUnzipP =
matrixDupP $$
matrixStackP (forAll $ \ x -> forwardP (mapEnabled $ \ v -> v .!. pureS x))
deMuxP :: forall c sig a . (Clock c, sig ~ Signal c, Rep a)
=> Patch (sig (Enabled Bool) :> sig (Enabled a)) (sig (Enabled a) :> sig (Enabled a))
(sig Ack :> sig Ack) (sig Ack :> sig Ack)
deMuxP = fe $$ matrixDeMuxP $$ be
where
fe = fstP (mapP (unsigned))
be = backwardP (\ ~(b :> c) -> matrix [c,b]) $$
forwardP (\ m -> ((m M.! (1 :: X2)) :> (m M.! 0)))
matrixDeMuxP :: forall c sig a x . (Clock c, sig ~ Signal c, Rep a, Rep x, Size x)
=> Patch (sig (Enabled x) :> sig (Enabled a)) (Matrix x (sig (Enabled a)))
(sig Ack :> sig Ack) (Matrix x (sig Ack))
matrixDeMuxP = matrixDeMuxP' $$ matrixStackP (pure readyToAckBridge) where
matrixDeMuxP' ~(ix :> inp, m_ready) = (toAck ackCond :> toAck ackIn,out)
where
go = isEnabled ix .&&. isEnabled inp .&&. fromReady (pack m_ready .!. enabledVal ix)
ackCond = go
ackIn = go
out = forAll $ \ x -> packEnabled (go .&&. enabledVal ix .==. pureS x) (enabledVal inp)
zipP :: (Clock c, sig ~ Signal c, Rep a, Rep b)
=> Patch (sig (Enabled a) :> sig (Enabled b)) (sig (Enabled (a,b)))
(sig Ack :> sig Ack) (sig Ack)
zipP ~(in1 :> in2, outReady) = (toAck ack :> toAck ack, out)
where
try = isEnabled in1 .&&. isEnabled in2
ack = try .&&. fromAck outReady
out = packEnabled try (pack (enabledVal in1, enabledVal in2))
matrixZipP :: forall c sig a x . (Clock c, sig ~ Signal c, Rep a, Rep x, Size x)
=> Patch (Matrix x (sig (Enabled a))) (sig (Enabled (Matrix x a)))
(Matrix x (sig Ack)) (sig Ack)
matrixZipP ~(mIn, outReady) = (mAcks, out)
where
try = foldr1 (.&&.) (map isEnabled $ M.toList mIn)
mAcks = fmap toAck $ pure (try .&&. fromAck outReady)
mIn' = fmap enabledVal mIn
out = packEnabled try (pack mIn' :: sig (Matrix x a))
muxP :: (Clock c, sig ~ Signal c, Rep a)
=> Patch (sig (Enabled Bool) :> sig (Enabled a) :> sig (Enabled a)) (sig (Enabled a))
(sig Ack :> sig Ack :> sig Ack) (sig Ack)
muxP = fe $$ matrixMuxP
where
fe = forwardP (\ ~(a :> b :> c) -> (mapEnabled (unsigned) a :> matrix [c,b])) $$
backwardP (\ ~(a :> m) -> (a :> (m M.! (1 :: X2)) :> (m M.! 0)))
matrixMuxP :: forall c sig a x . (Clock c, sig ~ Signal c, Rep a, Rep x, Size x)
=> Patch (sig (Enabled x) :> Matrix x (sig (Enabled a))) (sig (Enabled a))
(sig Ack :> Matrix x (sig Ack)) (sig Ack)
matrixMuxP ~(~(cond :> m),ack) = ((toAck ackCond :> fmap toAck m_acks),out)
where
try = isEnabled cond
gos :: Matrix x (sig Bool)
gos = forEach m $ \ x inp -> try
.&&. (enabledVal cond .==. pureS x)
.&&. isEnabled inp
ackCond = foldr1 (.||.) $ M.toList m_acks
m_acks = fmap (\ g -> g .&&. fromAck ack) gos
out = cASE (zip (M.toList gos) (M.toList m))
disabledS
fifo1 :: forall c sig a . (Clock c, sig ~ Signal c, Rep a)
=> Patch (sig (Enabled a)) (sig (Enabled a))
(sig Ack) (sig Ack)
fifo1 ~(inp,ack) = (toAck have_read, out)
where
have_read = (state .==. 0) .&&. isEnabled inp
written = (state .==. 1) .&&. fromAck ack
state :: sig X2
state = register 0
$ cASE [ (have_read, pureS 1)
, (written, pureS 0)
] state
store :: sig a
store = delay
$ cASE [ (have_read,enabledVal inp)
]
store
out = packEnabled (state .==. 1) store
fifo2 :: forall c sig a . (Clock c, sig ~ Signal c, Rep a)
=> Patch (sig (Enabled a)) (sig (Enabled a))
(sig Ack) (sig Ack)
fifo2 = ackToReadyBridge $$ fifo2' where
fifo2' ~(inp,ack) = (toReady ready, out)
where
dataIncoming = isEnabled inp
dataOutRead = (state ./=. 0) .&&. fromAck ack
state :: sig X5
state = register 0
$ cASE [ ((state.==.0) .&&. dataIncoming, 1)
, ((state.==.1) .&&. dataIncoming .&&. dataOutRead, 2)
, ((state.==.1) .&&. dataIncoming, 4)
, ((state.==.1) .&&. dataOutRead, 0)
, ((state.==.2) .&&. dataIncoming .&&. dataOutRead, 1)
, ((state.==.2) .&&. dataIncoming, 3)
, ((state.==.2) .&&. dataOutRead, 0)
, ((state.==.3) .&&. dataOutRead, 1)
, ((state.==.4) .&&. dataOutRead, 2)
] state
fstStore :: sig a
fstStore = cASE [ (((state.==.0) .||. (state.==.2)) .&&. dataIncoming, enabledVal inp)
]
$ delay fstStore
sndStore :: sig a
sndStore = cASE [ ((state.==.1) .&&. dataIncoming, enabledVal inp)
]
$ delay sndStore
ready = (state ./=. 3) .&&. (state ./=. 4)
outval = cASE [ (((state.==.2) .||. (state.==.3)), sndStore)
] fstStore
out = packEnabled (state ./=. 0) outval
matrixToElementsP :: forall c sig a x . (Clock c, sig ~ Signal c, Rep a, Rep x, Size x, Num x, Enum x)
=> Patch (sig (Enabled (Matrix x a))) (sig (Enabled a))
(sig Ack) (sig Ack)
matrixToElementsP =
openP
$$ stackP
(cycleP (coord :: Matrix x x))
(matrixUnzipP)
$$ matrixMuxP
matrixFromElementsP :: forall c sig a x . (Clock c, sig ~ Signal c, Rep a, Rep x, Size x, Num x, Enum x)
=> Patch (sig (Enabled a)) (sig (Enabled (Matrix x a)))
(sig Ack) (sig Ack)
matrixFromElementsP =
openP
$$ fstP (cycleP (coord :: Matrix x x))
$$ matrixDeMuxP
$$ matrixZipP
globalClockP :: (clk ~ CLK, sig ~ Signal clk) =>
Patch (sig a) (sig a)
(sig b) (sig b)
globalClockP ~(li,ri) = (ri,li)
cycleP :: forall a c ix sig .
( Size ix
, Rep a
, Rep ix
, Num ix
, Clock c
, sig ~ Signal c
)
=> Matrix ix a
-> Patch () (sig (Enabled a))
() (sig Ack)
cycleP m ~(_,ack) = ((),out)
where
ix :: sig ix
ix = register 0
$ cASE [ (fromAck ack, loopingIncS ix) ]
ix
out = packEnabled high
$ funMap (\ x -> return (m M.! x))
ix
constP :: forall a c ix sig .
( Size ix
, Rep a
, Rep ix
, Num ix
, Clock c
, sig ~ Signal c
)
=> Matrix ix a
-> Patch () (sig (Enabled a))
() (sig Ack)
constP m ~(_,ackOut) = ((),out)
where
ix :: sig ix
ix = register 0
$ cASE [ (fromAck ackOut, loopingIncS ix) ]
ix
st :: sig Bool
st = register False
$ cASE [ (fromAck ackOut .&&. ix .==. (maxBound :: sig ix), high) ]
st
out :: sig (Enabled a)
out = mux st
(packEnabled high $ funMap (\ x -> return (m M.! x)) ix
, disabledS
)
prependP :: forall a c ix sig .
( Size ix
, Rep a
, Rep ix
, Num ix
, Clock c
, sig ~ Signal c
)
=> Matrix ix a
-> Patch (sig (Enabled a)) (sig (Enabled a))
(sig Ack) (sig Ack)
prependP m ~(inp,ackOut) = (ackIn,out)
where
ix :: sig ix
ix = register 0
$ cASE [ (fromAck ackOut, loopingIncS ix) ]
ix
st :: sig Bool
st = register False
$ cASE [ (fromAck ackOut .&&. ix .==. (maxBound :: sig ix), high) ]
st
ackIn :: sig Ack
ackIn = mux st
( toAck low
, ackOut
)
out :: sig (Enabled a)
out = mux st
( packEnabled high $ funMap (\ x -> return (m M.! x)) ix
, inp
)
data MergePlan = PriorityMerge
| RoundRobinMerge
mergeP :: forall c sig a . (Clock c, sig ~ Signal c, Rep a)
=> MergePlan
-> Patch ((sig (Enabled a)) :> (sig (Enabled a))) (sig (Enabled a))
((sig Ack) :> (sig Ack)) (sig Ack)
mergeP plan = fe $$ matrixMergeP plan
where
fe = forwardP (\ ~(b :> c) -> (matrix [b,c])) $$
backwardP (\ ~m -> ( (m M.! (0 :: X2)) :> (m M.! (1 :: X2))))
matrixMergeP :: forall c sig a x . (Clock c, sig ~ Signal c, Rep a, Rep x, Size x, Num x, Enum x)
=> MergePlan
-> Patch (Matrix x (sig (Enabled a))) (sig (Enabled a))
(Matrix x (sig Ack)) (sig Ack)
matrixMergeP plan ~(mInp, ackOut) = (mAckInp, out)
where
isEs :: sig (Matrix x Bool)
isEs = pack (fmap isEnabled mInp)
inpIndex :: sig x
inpIndex = case plan of
PriorityMerge -> cASE (zip (map isEnabled $ M.toList mInp) (map pureS [0..])) (pureS 0)
RoundRobinMerge -> let reg = register 0 (mux ((isEs .!. reg) .&&. bitNot (fromAck ackOut))
(loopingIncS reg,reg)) in reg
mAckInp = forEach mInp $ \ x _inp -> toAck $ ((pureS x) .==. inpIndex) .&&. (fromAck ackOut)
out = (pack mInp) .!. inpIndex
type FabricPatch fab
lhs_in rhs_out
lhs_out rhs_in
= (lhs_in,rhs_in) -> fab (lhs_out,rhs_out)
patchF :: (MonadFix fab)
=> Patch a b
c d -> FabricPatch fab a b
c d
patchF patch inp = return (patch inp)
infixr 4 |$|
(|$|) :: (MonadFix fab)
=> FabricPatch fab a b
d e
-> FabricPatch fab b c
e f
-> FabricPatch fab a c
d f
f1 |$| f2 = \ ~(lhs_in,rhs_in) -> do
rec ~(lhs_out1,rhs_out1) <- f1 (lhs_in,lhs_out2)
~(lhs_out2,rhs_out2) <- f2 (rhs_out1,rhs_in)
return (lhs_out1,rhs_out2)
runF :: (MonadFix fab)
=> FabricPatch fab () a
() () -> fab a
runF p = do
~(_,a) <- p ((),())
return a
buildF :: (MonadFix fab)
=> ((a,d) -> fab (c,b))
-> FabricPatch fab a b
c d
buildF = id
emptyF :: (MonadFix fab)
=> FabricPatch
fab a a
b b
emptyF = patchF emptyP
infixr 3 `stackF`
stackF :: (MonadFix fab)
=> FabricPatch fab
li1 ro1
lo1 ri1
-> FabricPatch fab
li2 ro2
lo2 ri2
-> FabricPatch fab
(li1 :> li2) (ro1 :> ro2)
(lo1 :> lo2) (ri1 :> ri2)
stackF p1 p2 ~(li1 :> li2,ri1 :> ri2) = do
(lo1,ro1) <- p1 (li1,ri1)
(lo2,ro2) <- p2 (li2,ri2)
return $ (lo1 :> lo2,ro1 :> ro2)