{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Extra.Solver #-}
{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-}
{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-}
module Clash.Signal.BiSignal (
BiSignalIn()
, BiSignalOut()
, BiSignalDefault(..)
, SBiSignalDefault(..)
, HasBiSignalDefault(..)
, mergeBiSignalOuts
, readFromBiSignal
, writeToBiSignal
, veryUnsafeToBiSignalIn
) where
import Data.Kind (Type)
import Data.List (intercalate)
import Data.Maybe (fromMaybe,isJust)
import Clash.Annotations.Primitive (hasBlackBox)
import Clash.Class.HasDomain
import Clash.Class.BitPack (BitPack (..))
import Clash.Sized.BitVector (BitVector)
import qualified Clash.Sized.Vector as V
import Clash.Sized.Vector (Vec)
import Clash.Signal.Internal (Signal(..), Domain, head#, tail#)
import Clash.XException (errorX, fromJustX)
import GHC.TypeLits (KnownNat, Nat)
import GHC.Stack (HasCallStack)
import Data.Reflection (Given (..))
data BiSignalDefault
= PullUp
| PullDown
| Floating
deriving (Int -> BiSignalDefault -> ShowS
[BiSignalDefault] -> ShowS
BiSignalDefault -> String
(Int -> BiSignalDefault -> ShowS)
-> (BiSignalDefault -> String)
-> ([BiSignalDefault] -> ShowS)
-> Show BiSignalDefault
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BiSignalDefault] -> ShowS
$cshowList :: [BiSignalDefault] -> ShowS
show :: BiSignalDefault -> String
$cshow :: BiSignalDefault -> String
showsPrec :: Int -> BiSignalDefault -> ShowS
$cshowsPrec :: Int -> BiSignalDefault -> ShowS
Show)
data SBiSignalDefault :: BiSignalDefault -> Type where
SPullUp :: SBiSignalDefault 'PullUp
SPullDown :: SBiSignalDefault 'PullDown
SFloating :: SBiSignalDefault 'Floating
instance Given (SBiSignalDefault 'PullUp) where
given :: SBiSignalDefault 'PullUp
given = SBiSignalDefault 'PullUp
SPullUp
instance Given (SBiSignalDefault 'PullDown) where
given :: SBiSignalDefault 'PullDown
given = SBiSignalDefault 'PullDown
SPullDown
instance Given (SBiSignalDefault 'Floating) where
given :: SBiSignalDefault 'Floating
given = SBiSignalDefault 'Floating
SFloating
class HasBiSignalDefault (ds :: BiSignalDefault) where
pullUpMode :: BiSignalIn ds dom n -> SBiSignalDefault ds
instance HasBiSignalDefault 'PullUp where
pullUpMode :: BiSignalIn 'PullUp dom n -> SBiSignalDefault 'PullUp
pullUpMode BiSignalIn 'PullUp dom n
_ = SBiSignalDefault 'PullUp
SPullUp
instance HasBiSignalDefault 'PullDown where
pullUpMode :: BiSignalIn 'PullDown dom n -> SBiSignalDefault 'PullDown
pullUpMode BiSignalIn 'PullDown dom n
_ = SBiSignalDefault 'PullDown
SPullDown
instance HasBiSignalDefault 'Floating where
pullUpMode :: BiSignalIn 'Floating dom n -> SBiSignalDefault 'Floating
pullUpMode BiSignalIn 'Floating dom n
_ = SBiSignalDefault 'Floating
SFloating
type role BiSignalIn nominal nominal nominal
data BiSignalIn (ds :: BiSignalDefault) (dom :: Domain) (n :: Nat)
= BiSignalIn (SBiSignalDefault ds) (Signal dom (Maybe (BitVector n)))
type role BiSignalOut nominal nominal nominal
#if MIN_VERSION_base(4,15,0)
data BiSignalOut (ds :: BiSignalDefault) (dom :: Domain) (n :: Nat)
= BiSignalOut ![Signal dom (Maybe (BitVector n))]
#else
newtype BiSignalOut (ds :: BiSignalDefault) (dom :: Domain) (n :: Nat)
= BiSignalOut [Signal dom (Maybe (BitVector n))]
#endif
type instance HasDomain dom1 (BiSignalOut ds dom2 n) = DomEq dom1 dom2
type instance TryDomain t (BiSignalOut ds dom n) = 'Found dom
instance Semigroup (BiSignalOut defaultState dom n) where
(BiSignalOut [Signal dom (Maybe (BitVector n))]
b1) <> :: BiSignalOut defaultState dom n
-> BiSignalOut defaultState dom n -> BiSignalOut defaultState dom n
<> (BiSignalOut [Signal dom (Maybe (BitVector n))]
b2) = [Signal dom (Maybe (BitVector n))]
-> BiSignalOut defaultState dom n
forall (ds :: BiSignalDefault) (dom :: Domain) (n :: Nat).
[Signal dom (Maybe (BitVector n))] -> BiSignalOut ds dom n
BiSignalOut ([Signal dom (Maybe (BitVector n))]
b1 [Signal dom (Maybe (BitVector n))]
-> [Signal dom (Maybe (BitVector n))]
-> [Signal dom (Maybe (BitVector n))]
forall a. [a] -> [a] -> [a]
++ [Signal dom (Maybe (BitVector n))]
b2)
instance Monoid (BiSignalOut defaultState dom n) where
mempty :: BiSignalOut defaultState dom n
mempty = [Signal dom (Maybe (BitVector n))]
-> BiSignalOut defaultState dom n
forall (ds :: BiSignalDefault) (dom :: Domain) (n :: Nat).
[Signal dom (Maybe (BitVector n))] -> BiSignalOut ds dom n
BiSignalOut []
prepend#
:: Given (SBiSignalDefault ds)
=> Maybe (BitVector n)
-> BiSignalIn ds d n
-> BiSignalIn ds d n
prepend# :: Maybe (BitVector n) -> BiSignalIn ds d n -> BiSignalIn ds d n
prepend# Maybe (BitVector n)
a ~(BiSignalIn SBiSignalDefault ds
_ Signal d (Maybe (BitVector n))
as) = SBiSignalDefault ds
-> Signal d (Maybe (BitVector n)) -> BiSignalIn ds d n
forall (ds :: BiSignalDefault) (dom :: Domain) (n :: Nat).
SBiSignalDefault ds
-> Signal dom (Maybe (BitVector n)) -> BiSignalIn ds dom n
BiSignalIn SBiSignalDefault ds
forall a. Given a => a
given (Maybe (BitVector n)
a Maybe (BitVector n)
-> Signal d (Maybe (BitVector n)) -> Signal d (Maybe (BitVector n))
forall (dom :: Domain) a. a -> Signal dom a -> Signal dom a
:- Signal d (Maybe (BitVector n))
as)
readFromBiSignal#
:: ( HasCallStack
, KnownNat n)
=> BiSignalIn ds d n
-> Signal d (BitVector n)
readFromBiSignal# :: BiSignalIn ds d n -> Signal d (BitVector n)
readFromBiSignal# (BiSignalIn SBiSignalDefault ds
ds Signal d (Maybe (BitVector n))
s) =
case SBiSignalDefault ds
ds of
SBiSignalDefault ds
SFloating -> BitVector n -> Maybe (BitVector n) -> BitVector n
forall a. a -> Maybe a -> a
fromMaybe (String -> BitVector n
forall a. HasCallStack => String -> a
errorX String
" undefined value on BiSignalIn") (Maybe (BitVector n) -> BitVector n)
-> Signal d (Maybe (BitVector n)) -> Signal d (BitVector n)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal d (Maybe (BitVector n))
s
SBiSignalDefault ds
SPullDown -> BitVector n -> Maybe (BitVector n) -> BitVector n
forall a. a -> Maybe a -> a
fromMaybe BitVector n
forall a. Bounded a => a
minBound (Maybe (BitVector n) -> BitVector n)
-> Signal d (Maybe (BitVector n)) -> Signal d (BitVector n)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal d (Maybe (BitVector n))
s
SBiSignalDefault ds
SPullUp -> BitVector n -> Maybe (BitVector n) -> BitVector n
forall a. a -> Maybe a -> a
fromMaybe BitVector n
forall a. Bounded a => a
maxBound (Maybe (BitVector n) -> BitVector n)
-> Signal d (Maybe (BitVector n)) -> Signal d (BitVector n)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal d (Maybe (BitVector n))
s
{-# NOINLINE readFromBiSignal# #-}
{-# ANN readFromBiSignal# hasBlackBox #-}
readFromBiSignal
:: ( HasCallStack
, BitPack a)
=> BiSignalIn ds d (BitSize a)
-> Signal d a
readFromBiSignal :: BiSignalIn ds d (BitSize a) -> Signal d a
readFromBiSignal = (BitVector (BitSize a) -> a)
-> Signal d (BitVector (BitSize a)) -> Signal d a
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap BitVector (BitSize a) -> a
forall a. BitPack a => BitVector (BitSize a) -> a
unpack (Signal d (BitVector (BitSize a)) -> Signal d a)
-> (BiSignalIn ds d (BitSize a)
-> Signal d (BitVector (BitSize a)))
-> BiSignalIn ds d (BitSize a)
-> Signal d a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BiSignalIn ds d (BitSize a) -> Signal d (BitVector (BitSize a))
forall (n :: Nat) (ds :: BiSignalDefault) (d :: Domain).
(HasCallStack, KnownNat n) =>
BiSignalIn ds d n -> Signal d (BitVector n)
readFromBiSignal#
mergeBiSignalOuts
:: ( HasCallStack
, KnownNat n
)
=> Vec n (BiSignalOut defaultState dom m)
-> BiSignalOut defaultState dom m
mergeBiSignalOuts :: Vec n (BiSignalOut defaultState dom m)
-> BiSignalOut defaultState dom m
mergeBiSignalOuts = [BiSignalOut defaultState dom m] -> BiSignalOut defaultState dom m
forall a. Monoid a => [a] -> a
mconcat ([BiSignalOut defaultState dom m]
-> BiSignalOut defaultState dom m)
-> (Vec n (BiSignalOut defaultState dom m)
-> [BiSignalOut defaultState dom m])
-> Vec n (BiSignalOut defaultState dom m)
-> BiSignalOut defaultState dom m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vec n (BiSignalOut defaultState dom m)
-> [BiSignalOut defaultState dom m]
forall (n :: Nat) a. Vec n a -> [a]
V.toList
{-# NOINLINE mergeBiSignalOuts #-}
{-# ANN mergeBiSignalOuts hasBlackBox #-}
writeToBiSignal#
:: HasCallStack
=> BiSignalIn ds d n
-> Signal d (Maybe (BitVector n))
-> Signal d Bool
-> Signal d (BitVector n)
-> BiSignalOut ds d n
writeToBiSignal# :: BiSignalIn ds d n
-> Signal d (Maybe (BitVector n))
-> Signal d Bool
-> Signal d (BitVector n)
-> BiSignalOut ds d n
writeToBiSignal# BiSignalIn ds d n
_ Signal d (Maybe (BitVector n))
maybeSignal Signal d Bool
_ Signal d (BitVector n)
_ = [Signal d (Maybe (BitVector n))] -> BiSignalOut ds d n
forall (ds :: BiSignalDefault) (dom :: Domain) (n :: Nat).
[Signal dom (Maybe (BitVector n))] -> BiSignalOut ds dom n
BiSignalOut [Signal d (Maybe (BitVector n))
maybeSignal]
{-# NOINLINE writeToBiSignal# #-}
{-# ANN writeToBiSignal# hasBlackBox #-}
writeToBiSignal
:: (HasCallStack, BitPack a)
=> BiSignalIn ds d (BitSize a)
-> Signal d (Maybe a)
-> BiSignalOut ds d (BitSize a)
writeToBiSignal :: BiSignalIn ds d (BitSize a)
-> Signal d (Maybe a) -> BiSignalOut ds d (BitSize a)
writeToBiSignal BiSignalIn ds d (BitSize a)
input Signal d (Maybe a)
writes =
BiSignalIn ds d (BitSize a)
-> Signal d (Maybe (BitVector (BitSize a)))
-> Signal d Bool
-> Signal d (BitVector (BitSize a))
-> BiSignalOut ds d (BitSize a)
forall (ds :: BiSignalDefault) (d :: Domain) (n :: Nat).
HasCallStack =>
BiSignalIn ds d n
-> Signal d (Maybe (BitVector n))
-> Signal d Bool
-> Signal d (BitVector n)
-> BiSignalOut ds d n
writeToBiSignal#
BiSignalIn ds d (BitSize a)
input
((a -> BitVector (BitSize a))
-> Maybe a -> Maybe (BitVector (BitSize a))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> BitVector (BitSize a)
forall a. BitPack a => a -> BitVector (BitSize a)
pack (Maybe a -> Maybe (BitVector (BitSize a)))
-> Signal d (Maybe a) -> Signal d (Maybe (BitVector (BitSize a)))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal d (Maybe a)
writes)
(Maybe a -> Bool
forall a. Maybe a -> Bool
isJust (Maybe a -> Bool) -> Signal d (Maybe a) -> Signal d Bool
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal d (Maybe a)
writes)
(a -> BitVector (BitSize a)
forall a. BitPack a => a -> BitVector (BitSize a)
pack (a -> BitVector (BitSize a))
-> (Maybe a -> a) -> Maybe a -> BitVector (BitSize a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJustX (Maybe a -> BitVector (BitSize a))
-> Signal d (Maybe a) -> Signal d (BitVector (BitSize a))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal d (Maybe a)
writes)
{-# INLINE writeToBiSignal #-}
veryUnsafeToBiSignalIn
:: ( HasCallStack
, KnownNat n
, Given (SBiSignalDefault ds)
)
=> BiSignalOut ds d n
-> BiSignalIn ds d n
veryUnsafeToBiSignalIn :: BiSignalOut ds d n -> BiSignalIn ds d n
veryUnsafeToBiSignalIn (BiSignalOut [Signal d (Maybe (BitVector n))]
signals) = Maybe (BitVector n) -> BiSignalIn ds d n -> BiSignalIn ds d n
forall (ds :: BiSignalDefault) (n :: Nat) (d :: Domain).
Given (SBiSignalDefault ds) =>
Maybe (BitVector n) -> BiSignalIn ds d n -> BiSignalIn ds d n
prepend# Maybe (BitVector n)
result BiSignalIn ds d n
biSignalOut'
where
result :: Maybe (BitVector n)
result = case (Signal d (Maybe (BitVector n)) -> Bool)
-> [Signal d (Maybe (BitVector n))]
-> [Signal d (Maybe (BitVector n))]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe (BitVector n) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (BitVector n) -> Bool)
-> (Signal d (Maybe (BitVector n)) -> Maybe (BitVector n))
-> Signal d (Maybe (BitVector n))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal d (Maybe (BitVector n)) -> Maybe (BitVector n)
forall (dom :: Domain) a. Signal dom a -> a
head#) [Signal d (Maybe (BitVector n))]
signals of
[] -> Maybe (BitVector n)
forall a. Maybe a
Nothing
[Signal d (Maybe (BitVector n))
w] -> Signal d (Maybe (BitVector n)) -> Maybe (BitVector n)
forall (dom :: Domain) a. Signal dom a -> a
head# Signal d (Maybe (BitVector n))
w
[Signal d (Maybe (BitVector n))]
_ -> String -> Maybe (BitVector n)
forall a. HasCallStack => String -> a
errorX String
err
err :: String
err = [String] -> String
unwords
[ String
"Multiple components wrote to the BiSignal. This is undefined behavior"
, String
"in hardware and almost certainly a logic error. The components wrote:\n"
, String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n " ((Signal d (Maybe (BitVector n)) -> String)
-> [Signal d (Maybe (BitVector n))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe (BitVector n) -> String
forall a. Show a => a -> String
show (Maybe (BitVector n) -> String)
-> (Signal d (Maybe (BitVector n)) -> Maybe (BitVector n))
-> Signal d (Maybe (BitVector n))
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal d (Maybe (BitVector n)) -> Maybe (BitVector n)
forall (dom :: Domain) a. Signal dom a -> a
head#) [Signal d (Maybe (BitVector n))]
signals)
]
biSignalOut' :: BiSignalIn ds d n
biSignalOut' = BiSignalOut ds d n -> BiSignalIn ds d n
forall (n :: Nat) (ds :: BiSignalDefault) (d :: Domain).
(HasCallStack, KnownNat n, Given (SBiSignalDefault ds)) =>
BiSignalOut ds d n -> BiSignalIn ds d n
veryUnsafeToBiSignalIn (BiSignalOut ds d n -> BiSignalIn ds d n)
-> BiSignalOut ds d n -> BiSignalIn ds d n
forall a b. (a -> b) -> a -> b
$ [Signal d (Maybe (BitVector n))] -> BiSignalOut ds d n
forall (ds :: BiSignalDefault) (dom :: Domain) (n :: Nat).
[Signal dom (Maybe (BitVector n))] -> BiSignalOut ds dom n
BiSignalOut ([Signal d (Maybe (BitVector n))] -> BiSignalOut ds d n)
-> [Signal d (Maybe (BitVector n))] -> BiSignalOut ds d n
forall a b. (a -> b) -> a -> b
$ (Signal d (Maybe (BitVector n)) -> Signal d (Maybe (BitVector n)))
-> [Signal d (Maybe (BitVector n))]
-> [Signal d (Maybe (BitVector n))]
forall a b. (a -> b) -> [a] -> [b]
map Signal d (Maybe (BitVector n)) -> Signal d (Maybe (BitVector n))
forall (dom :: Domain) a. Signal dom a -> Signal dom a
tail# [Signal d (Maybe (BitVector n))]
signals
{-# NOINLINE veryUnsafeToBiSignalIn #-}
{-# ANN veryUnsafeToBiSignalIn hasBlackBox #-}