{-# LANGUAGE CPP #-}
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE Safe #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.Extra.Solver #-}
{-# OPTIONS_HADDOCK show-extensions #-}
module Clash.Explicit.Synchronizer
(
dualFlipFlopSynchronizer
, asyncFIFOSynchronizer
)
where
import Data.Bits (complement, shiftR, xor)
import Data.Constraint ((:-)(..), Dict (..))
import Data.Constraint.Nat (leTrans)
import Data.Maybe (isJust)
import GHC.TypeLits (type (+), type (-), type (<=), type (^), KnownNat)
import Clash.Class.BitPack (boolToBV, unpack)
import Clash.Class.Resize (truncateB)
import Clash.Class.BitPack.BitIndex (slice)
import Clash.Explicit.Mealy (mealyB)
import Clash.Explicit.BlockRam (RamOp (..), trueDualPortBlockRam)
import Clash.Explicit.Signal
(Clock, Reset, Signal, Enable, register, unsafeSynchronizer, fromEnable,
(.&&.), mux, KnownDomain)
import Clash.Promoted.Nat (SNat (..))
import Clash.Promoted.Nat.Literals (d0)
import Clash.Sized.BitVector (BitVector, (++#))
import Clash.XException (NFDataX, fromJustX)
dualFlipFlopSynchronizer
:: ( NFDataX a
, KnownDomain dom1
, KnownDomain dom2 )
=> Clock dom1
-> Clock dom2
-> Reset dom2
-> Enable dom2
-> a
-> Signal dom1 a
-> Signal dom2 a
dualFlipFlopSynchronizer clk1 clk2 rst en i =
register clk2 rst en i
. register clk2 rst en i
. unsafeSynchronizer clk1 clk2
fifoMem
:: forall wdom rdom a addrSize
. ( KnownDomain wdom
, KnownDomain rdom
, NFDataX a
, KnownNat addrSize
, 1 <= addrSize )
=> Clock wdom
-> Clock rdom
-> Enable wdom
-> Enable rdom
-> Signal wdom Bool
-> Signal rdom (BitVector addrSize)
-> Signal wdom (BitVector addrSize)
-> Signal wdom (Maybe a)
-> Signal rdom a
fifoMem wclk rclk wen ren full raddr waddr wdataM =
fst $ trueDualPortBlockRam
rclk wclk portA portB
where
portA :: Signal rdom (RamOp (2 ^ addrSize) a)
portA = mux (fromEnable ren)
(RamRead . unpack <$> raddr)
(pure RamNoOp)
portB :: Signal wdom (RamOp (2 ^ addrSize) a)
portB = mux (fromEnable wen .&&. fmap not full .&&. fmap isJust wdataM)
(RamWrite <$> fmap unpack waddr <*> fmap fromJustX wdataM)
(pure RamNoOp)
readPtrCompareT
:: KnownNat addrSize
=> ( BitVector (addrSize + 1)
, BitVector (addrSize + 1)
, Bool )
-> ( BitVector (addrSize + 1)
, Bool )
-> ( ( BitVector (addrSize + 1)
, BitVector (addrSize + 1)
, Bool )
, ( Bool
, BitVector addrSize
, BitVector (addrSize + 1)
)
)
readPtrCompareT (bin, ptr, flag) (s_ptr, inc) =
((bin', ptr', flag'), (flag, addr, ptr))
where
bin' = bin + boolToBV (inc && not flag)
ptr' = (bin' `shiftR` 1) `xor` bin'
addr = truncateB bin'
flag' = ptr' == s_ptr
writePtrCompareT
:: (2 <= addrSize)
=> SNat addrSize
-> ( BitVector (addrSize + 1)
, BitVector (addrSize + 1)
, Bool )
-> ( BitVector (addrSize + 1)
, Bool )
-> ( ( BitVector (addrSize + 1)
, BitVector (addrSize + 1)
, Bool )
, ( Bool
, BitVector addrSize
, BitVector (addrSize + 1)
)
)
writePtrCompareT addrSize@SNat (bin, ptr, flag) (s_ptr, inc) =
((bin', ptr', flag'), (flag, addr, ptr))
where
bin' = bin + boolToBV (inc && not flag)
ptr' = (bin' `shiftR` 1) `xor` bin'
addr = truncateB bin
flag' = isFull addrSize ptr' s_ptr
isFull
:: forall addrSize
. (2 <= addrSize)
=> SNat addrSize
-> BitVector (addrSize + 1)
-> BitVector (addrSize + 1)
-> Bool
isFull addrSize@SNat ptr s_ptr =
case leTrans @1 @2 @addrSize of
Sub Dict ->
let a1 = SNat @(addrSize - 1)
a2 = SNat @(addrSize - 2)
in ptr == (complement (slice addrSize a1 s_ptr) ++# slice a2 d0 s_ptr)
asyncFIFOSynchronizer
:: ( KnownDomain wdom
, KnownDomain rdom
, 2 <= addrSize
, NFDataX a )
=> SNat addrSize
-> Clock wdom
-> Clock rdom
-> Reset wdom
-> Reset rdom
-> Enable wdom
-> Enable rdom
-> Signal rdom Bool
-> Signal wdom (Maybe a)
-> (Signal rdom a, Signal rdom Bool, Signal wdom Bool)
asyncFIFOSynchronizer addrSize@SNat wclk rclk wrst rrst wen ren rinc wdataM =
(rdata, rempty, wfull)
where
s_rptr = dualFlipFlopSynchronizer rclk wclk wrst wen 0 rptr
s_wptr = dualFlipFlopSynchronizer wclk rclk rrst ren 0 wptr
rdata =
fifoMem
wclk rclk wen ren
wfull raddr
waddr wdataM
(rempty, raddr, rptr) =
mealyB
rclk rrst ren
readPtrCompareT
(0, 0, True)
(s_wptr, rinc)
(wfull, waddr, wptr) =
mealyB
wclk wrst wen
(writePtrCompareT addrSize)
(0, 0, False)
(s_rptr, isJust <$> wdataM)