{-|
  Copyright   :  (C) 2019,      Myrtle Software Ltd.
                     2020-2023, QBayLogic B.V.
                     2021,      Myrtle.ai
                     2022-2023, Google Inc
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>

This module contains a mini dsl for creating haskell blackbox
instantiations.
-}

{-# LANGUAGE CPP               #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms   #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeApplications  #-}
{-# LANGUAGE ViewPatterns      #-}

module Clash.Primitives.DSL
  (
  -- * Annotations
    BlackBoxHaskellOpts(..)
  , blackBoxHaskell

  -- * Declarations
  , BlockState (..)
  , TExpr(..)
  , addDeclaration
  , assign
  , compInBlock
  , declaration
  , declarationReturn
  , declare
  , declareN
  , instDecl
  , instHO
  , viaAnnotatedSignal

  -- ** Literals
  , bvLit
  , LitHDL (..)
  , pattern High
  , pattern Low
  , constructProduct
  , tuple
  , vec

  -- ** Extraction
  , tInputs
  , tResults
  , getStr
  , getBool
  , getVec
  , exprToInteger
  , tExprToInteger
  , deconstructProduct
  , untuple
  , unvec
  , deconstructMaybe

  -- ** Conversion
  , bitCoerce
  , toBV
  , toBvWithAttrs
  , fromBV
  , enableToBit
  , boolToBit
  , boolFromBit
  , boolFromBitVector
  , unsignedFromBitVector
  , boolFromBits

  , unsafeToActiveHigh
  , unsafeToActiveLow

  -- ** Operations
  , andExpr
  , notExpr
  , pureToBV
  , pureToBVResized
  , open

  -- ** Utilities
  , clog2
  , litTExpr
  , toIdentifier
  , tySize
  ) where

import           Control.Lens                    hiding (Indexed, assign)
#if MIN_VERSION_mtl(2,3,0)
import           Control.Monad                   (forM, forM_, zipWithM)
#endif
import           Control.Monad.State
import           Data.Default                    (Default(def))
import           Data.IntMap                     (IntMap)
import qualified Data.IntMap                     as IntMap
import           Data.List                       (intersperse)
import           Data.List.Extra                 (zipEqual)
import           Data.Maybe                      (fromMaybe)
import           Data.Monoid                     (Ap(getAp))
import           Data.Semigroup                  hiding (Product)
import           Data.String
import           Data.Text                       (Text)
import qualified Data.Text                       as Text
import           Data.Text.Extra                 (showt)
import           Data.Text.Prettyprint.Doc.Extra
import           GHC.Stack                       (HasCallStack)

import           Clash.Annotations.Primitive     (HDL (..), Primitive (..))
import           Clash.Annotations.SynthesisAttributes (Attr)
import           Clash.Backend                   hiding (Usage, fromBV, toBV)
import           Clash.Backend.VHDL              (VHDLState)
import           Clash.Explicit.Signal           (ResetPolarity(..), vResetPolarity)
import           Clash.Netlist.BlackBox.Util     (exprToString, getDomainConf, renderElem)
import           Clash.Netlist.BlackBox.Types
  (BlackBoxTemplate, Element(Component, Text), Decl(..))
import qualified Clash.Netlist.Id                as Id
import           Clash.Netlist.Types             hiding (Component, toBit)
import           Clash.Netlist.Util
import           Clash.Util                      (clogBase)
import qualified Data.String.Interpolate         as I
import           Language.Haskell.TH             (Name)
import           Prelude

-- | Options for 'blackBoxHaskell' function. Use 'def' from package
-- 'data-default' for a set of default options.
data BlackBoxHaskellOpts = BlackBoxHaskellOpts
  { -- | Arguments to ignore (i.e., remove during normalization)
    --
    -- Default: []
    BlackBoxHaskellOpts -> [Int]
bo_ignoredArguments :: [Int]

    -- | HDLs to use the blackbox for
    --
    -- Default: all
  , BlackBoxHaskellOpts -> [HDL]
bo_supportedHdls :: [HDL]

    -- | Does this blackbox assign its results to multiple binders?
    --
    -- Default: False.
  , BlackBoxHaskellOpts -> Bool
bo_multiResult :: Bool
  }

instance Default BlackBoxHaskellOpts where
  def :: BlackBoxHaskellOpts
def = BlackBoxHaskellOpts :: [Int] -> [HDL] -> Bool -> BlackBoxHaskellOpts
BlackBoxHaskellOpts
    { bo_ignoredArguments :: [Int]
bo_ignoredArguments = []
    , bo_supportedHdls :: [HDL]
bo_supportedHdls = [HDL
forall a. Bounded a => a
minBound..HDL
forall a. Bounded a => a
maxBound]
    , bo_multiResult :: Bool
bo_multiResult = Bool
False
    }

-- | Create a blackBoxHaskell primitive. To be used as part of an annotation:
--
-- @
-- {-\# ANN myFunction (blackBoxHaskell 'myFunction 'myBBF def{bo_ignoredArguments=[1,2]}) \#-}
-- @
--
-- @[1,2]@ would mean this blackbox __ignores__ its second and third argument.
blackBoxHaskell
  :: Name
  -- ^ blackbox name
  -> Name
  -- ^ template function name
  -> BlackBoxHaskellOpts
  -- ^ Options, see data structure for more information
  -> Primitive
blackBoxHaskell :: Name -> Name -> BlackBoxHaskellOpts -> Primitive
blackBoxHaskell Name
bb Name
tf BlackBoxHaskellOpts{Bool
[Int]
[HDL]
bo_multiResult :: Bool
bo_supportedHdls :: [HDL]
bo_ignoredArguments :: [Int]
bo_multiResult :: BlackBoxHaskellOpts -> Bool
bo_supportedHdls :: BlackBoxHaskellOpts -> [HDL]
bo_ignoredArguments :: BlackBoxHaskellOpts -> [Int]
..} =
  [HDL] -> String -> Primitive
InlineYamlPrimitive [HDL]
bo_supportedHdls [I.__i|
    BlackBoxHaskell:
      name: #{bb}
      templateFunction: #{tf}
      ignoredArguments : #{bo_ignoredArguments}
      multiResult : #{toYamlBool bo_multiResult}
    |]
 where
  toYamlBool :: Bool -> String
  toYamlBool :: Bool -> String
toYamlBool Bool
True = String
"true"
  toYamlBool Bool
False = String
"false"

-- | The state of a block. Contains a list of declarations and a the
--   backend state.
data BlockState backend = BlockState
  { BlockState backend -> [Declaration]
_bsDeclarations :: [Declaration]
    -- ^ Declarations store
  , BlockState backend -> IntMap Int
_bsHigherOrderCalls :: IntMap Int
    -- ^ Tracks how many times a higher order function has been instantiated.
    -- Needed to fill in the second field of 'Clash.Netlist.BlackBox.Types.Decl'
  , BlockState backend -> backend
_bsBackend :: backend
    -- ^ Backend state
  }
makeLenses ''BlockState

instance Backend backend => HasIdentifierSet (BlockState backend) where
  identifierSet :: Lens' (BlockState backend) IdentifierSet
  identifierSet :: (IdentifierSet -> f IdentifierSet)
-> BlockState backend -> f (BlockState backend)
identifierSet = (backend -> f backend)
-> BlockState backend -> f (BlockState backend)
forall backend backend.
Lens (BlockState backend) (BlockState backend) backend backend
bsBackend ((backend -> f backend)
 -> BlockState backend -> f (BlockState backend))
-> ((IdentifierSet -> f IdentifierSet) -> backend -> f backend)
-> (IdentifierSet -> f IdentifierSet)
-> BlockState backend
-> f (BlockState backend)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IdentifierSet -> f IdentifierSet) -> backend -> f backend
forall s. HasIdentifierSet s => Lens' s IdentifierSet
identifierSet

instance HasUsageMap backend => HasUsageMap (BlockState backend) where
  usageMap :: (UsageMap -> f UsageMap)
-> BlockState backend -> f (BlockState backend)
usageMap = (backend -> f backend)
-> BlockState backend -> f (BlockState backend)
forall backend backend.
Lens (BlockState backend) (BlockState backend) backend backend
bsBackend((backend -> f backend)
 -> BlockState backend -> f (BlockState backend))
-> ((UsageMap -> f UsageMap) -> backend -> f backend)
-> (UsageMap -> f UsageMap)
-> BlockState backend
-> f (BlockState backend)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(UsageMap -> f UsageMap) -> backend -> f backend
forall s. HasUsageMap s => Lens' s UsageMap
usageMap

liftToBlockState
  :: forall backend a. Backend backend
   => State backend a -> State (BlockState backend) a
liftToBlockState :: State backend a -> State (BlockState backend) a
liftToBlockState (StateT backend -> Identity (a, backend)
f) = (BlockState backend -> Identity (a, BlockState backend))
-> State (BlockState backend) a
forall s (m :: Type -> Type) a. (s -> m (a, s)) -> StateT s m a
StateT BlockState backend -> Identity (a, BlockState backend)
g
 where
  g :: BlockState backend -> Identity (a, BlockState backend)
  g :: BlockState backend -> Identity (a, BlockState backend)
g BlockState backend
sbsIn = do
    let sIn :: backend
sIn = BlockState backend -> backend
forall backend. BlockState backend -> backend
_bsBackend BlockState backend
sbsIn
    (a
res,backend
sOut) <- backend -> Identity (a, backend)
f backend
sIn
    (a, BlockState backend) -> Identity (a, BlockState backend)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (a
res, BlockState backend
sbsIn{_bsBackend :: backend
_bsBackend = backend
sOut})

-- | A typed expression.
data TExpr = TExpr
  { TExpr -> HWType
ety :: HWType
  , TExpr -> Expr
eex :: Expr
  } deriving Int -> TExpr -> ShowS
[TExpr] -> ShowS
TExpr -> String
(Int -> TExpr -> ShowS)
-> (TExpr -> String) -> ([TExpr] -> ShowS) -> Show TExpr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TExpr] -> ShowS
$cshowList :: [TExpr] -> ShowS
show :: TExpr -> String
$cshow :: TExpr -> String
showsPrec :: Int -> TExpr -> ShowS
$cshowsPrec :: Int -> TExpr -> ShowS
Show
makeLenses ''TExpr

-- | Run a block declaration. Assign the result of the block builder to the
-- result variable in the given blackbox context.
declarationReturn
  :: Backend backend
  => BlackBoxContext
  -> Text.Text
  -- ^ block name
  -> State (BlockState backend) [TExpr]
  -- ^ block builder yielding an expression that should be assigned to the
  -- result variable in the blackbox context
  -> State backend Doc
  -- ^ pretty printed block
declarationReturn :: BlackBoxContext
-> Text -> State (BlockState backend) [TExpr] -> State backend Doc
declarationReturn BlackBoxContext
bbCtx Text
blockName State (BlockState backend) [TExpr]
blockBuilder =
  Text -> State (BlockState backend) () -> State backend Doc
forall backend.
Backend backend =>
Text -> State (BlockState backend) () -> State backend Doc
declaration Text
blockName (State (BlockState backend) () -> State backend Doc)
-> State (BlockState backend) () -> State backend Doc
forall a b. (a -> b) -> a -> b
$ do
    [TExpr]
res <- State (BlockState backend) [TExpr]
blockBuilder
    [((Expr, HWType), TExpr)]
-> (((Expr, HWType), TExpr) -> State (BlockState backend) ())
-> State (BlockState backend) ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(Expr, HWType)] -> [TExpr] -> [((Expr, HWType), TExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip (BlackBoxContext -> [(Expr, HWType)]
bbResults BlackBoxContext
bbCtx) [TExpr]
res) ((((Expr, HWType), TExpr) -> State (BlockState backend) ())
 -> State (BlockState backend) ())
-> (((Expr, HWType), TExpr) -> State (BlockState backend) ())
-> State (BlockState backend) ()
forall a b. (a -> b) -> a -> b
$ \((Expr, HWType)
rNm, TExpr
r) -> case (Expr, HWType)
rNm of
      (Identifier Identifier
resultNm Maybe Modifier
Nothing, HWType
_) ->
        Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Identifier -> Usage -> Expr -> Declaration
Assignment Identifier
resultNm Usage
Cont (TExpr -> Expr
eex TExpr
r))
      (Expr
t,HWType
_) -> String -> State (BlockState backend) ()
forall a. HasCallStack => String -> a
error (String
"declarationReturn expected an Identifier, but got: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Expr -> String
forall a. Show a => a -> String
show Expr
t)


emptyBlockState :: backend -> BlockState backend
emptyBlockState :: backend -> BlockState backend
emptyBlockState backend
bck = BlockState :: forall backend.
[Declaration] -> IntMap Int -> backend -> BlockState backend
BlockState
  { _bsDeclarations :: [Declaration]
_bsDeclarations = []
  , _bsHigherOrderCalls :: IntMap Int
_bsHigherOrderCalls = IntMap Int
forall a. IntMap a
IntMap.empty
  , _bsBackend :: backend
_bsBackend = backend
bck
  }

-- | Run a block declaration.
declaration
  :: Backend backend
  => Text.Text
  -- ^ block name
  -> State (BlockState backend) ()
  -- ^ block builder
  -> State backend Doc
  -- ^ pretty printed block
declaration :: Text -> State (BlockState backend) () -> State backend Doc
declaration Text
blockName State (BlockState backend) ()
c = do
  backend
backend0 <- StateT backend Identity backend
forall s (m :: Type -> Type). MonadState s m => m s
get
  let initState :: BlockState backend
initState = backend -> BlockState backend
forall backend. backend -> BlockState backend
emptyBlockState backend
backend0
      (BlockState {backend
[Declaration]
IntMap Int
_bsBackend :: backend
_bsHigherOrderCalls :: IntMap Int
_bsDeclarations :: [Declaration]
_bsBackend :: forall backend. BlockState backend -> backend
_bsHigherOrderCalls :: forall backend. BlockState backend -> IntMap Int
_bsDeclarations :: forall backend. BlockState backend -> [Declaration]
..}) = State (BlockState backend) ()
-> BlockState backend -> BlockState backend
forall s a. State s a -> s -> s
execState State (BlockState backend) ()
c BlockState backend
initState
  backend -> StateT backend Identity ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put backend
_bsBackend
  Identifier
blockNameUnique <- Text -> StateT backend Identity Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic Text
blockName
  Ap (State backend) Doc -> State backend Doc
forall k (f :: k -> Type) (a :: k). Ap f a -> f a
getAp (Ap (State backend) Doc -> State backend Doc)
-> Ap (State backend) Doc -> State backend Doc
forall a b. (a -> b) -> a -> b
$ Identifier -> [Declaration] -> Ap (State backend) Doc
forall state.
Backend state =>
Identifier -> [Declaration] -> Ap (State state) Doc
blockDecl Identifier
blockNameUnique ([Declaration] -> [Declaration]
forall a. [a] -> [a]
reverse [Declaration]
_bsDeclarations)

-- | Add a declaration to the state.
addDeclaration :: Declaration -> State (BlockState backend) ()
addDeclaration :: Declaration -> State (BlockState backend) ()
addDeclaration Declaration
dec = ([Declaration] -> Identity [Declaration])
-> BlockState backend -> Identity (BlockState backend)
forall backend. Lens' (BlockState backend) [Declaration]
bsDeclarations (([Declaration] -> Identity [Declaration])
 -> BlockState backend -> Identity (BlockState backend))
-> ([Declaration] -> [Declaration])
-> State (BlockState backend) ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Declaration -> [Declaration] -> [Declaration]
forall s a. Cons s s a a => a -> s -> s
cons Declaration
dec

-- | Declare a new signal with the given name and type.
declare'
  :: Backend backend
  => Text
  -- ^ Name hint
  -> HWType
  -- ^ Type of new signal
  -> State (BlockState backend) Identifier
  -- ^ Expression pointing the the new signal
declare' :: Text -> HWType -> State (BlockState backend) Identifier
declare' Text
decName HWType
ty = do
  Identifier
uniqueName <- Text -> State (BlockState backend) Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic Text
decName
  Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Maybe Text -> Identifier -> HWType -> Maybe Expr -> Declaration
NetDecl' Maybe Text
forall a. Maybe a
Nothing Identifier
uniqueName HWType
ty Maybe Expr
forall a. Maybe a
Nothing)
  Identifier -> State (BlockState backend) Identifier
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Identifier
uniqueName

-- | Declare a new signal with the given name and type.
declare
  :: Backend backend
  => Text
  -- ^ Name hint
  -> HWType
  -- ^ Type of new signal
  -> State (BlockState backend) TExpr
  -- ^ Expression pointing the the new signal
declare :: Text -> HWType -> State (BlockState backend) TExpr
declare Text
decName HWType
ty = do
  Identifier
uniqueName <- Text -> HWType -> State (BlockState backend) Identifier
forall backend.
Backend backend =>
Text -> HWType -> State (BlockState backend) Identifier
declare' Text
decName HWType
ty
  TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HWType -> Expr -> TExpr
TExpr HWType
ty (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
uniqueName Maybe Modifier
forall a. Maybe a
Nothing))

-- | Declare /n/ new signals with the given type and based on the given name
declareN
  :: Backend backend
  => Text
  -- ^ Name hint
  -> [HWType]
  -- ^ Types of the signals
  -> State (BlockState backend) [TExpr]
  -- ^ Expressions pointing the the new signals
declareN :: Text -> [HWType] -> State (BlockState backend) [TExpr]
declareN Text
decName [HWType]
tys = do
  Identifier
firstName <- Text -> StateT (BlockState backend) Identity Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic Text
decName
  [Identifier]
nextNames <- Int
-> Identifier -> StateT (BlockState backend) Identity [Identifier]
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Int -> Identifier -> m [Identifier]
Id.nextN ([HWType] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [HWType]
tys Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Identifier
firstName
  let uniqueNames :: [Identifier]
uniqueNames = Identifier
firstName Identifier -> [Identifier] -> [Identifier]
forall a. a -> [a] -> [a]
: [Identifier]
nextNames
  (Identifier
 -> HWType -> StateT (BlockState backend) Identity TExpr)
-> [Identifier] -> [HWType] -> State (BlockState backend) [TExpr]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM
    (\Identifier
uniqueName HWType
ty -> do
      Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Declaration -> State (BlockState backend) ())
-> Declaration -> State (BlockState backend) ()
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Identifier -> HWType -> Maybe Expr -> Declaration
NetDecl' Maybe Text
forall a. Maybe a
Nothing Identifier
uniqueName HWType
ty Maybe Expr
forall a. Maybe a
Nothing
      TExpr -> StateT (BlockState backend) Identity TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TExpr -> StateT (BlockState backend) Identity TExpr)
-> TExpr -> StateT (BlockState backend) Identity TExpr
forall a b. (a -> b) -> a -> b
$ HWType -> Expr -> TExpr
TExpr HWType
ty (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
uniqueName Maybe Modifier
forall a. Maybe a
Nothing)
    ) [Identifier]
uniqueNames [HWType]
tys

-- | Assign an expression to an identifier, returns the new typed
--   identifier expression.
assign
  :: Backend backend
  => Text
  -- ^ Name hint for assignment
  -> TExpr
  -- ^ expression to be assigned to freshly generated identifier
  -> State (BlockState backend) TExpr
  -- ^ the identifier of the expression that actually got assigned
assign :: Text -> TExpr -> State (BlockState backend) TExpr
assign Text
aName (TExpr HWType
ty Expr
aExpr) = do
  TExpr
texp <- Text -> HWType -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> HWType -> State (BlockState backend) TExpr
declare Text
aName HWType
ty
  let uniqueName :: Identifier
uniqueName = case TExpr
texp of
        TExpr HWType
_ (Identifier Identifier
x Maybe Modifier
Nothing) -> Identifier
x
        TExpr
t' -> String -> Identifier
forall a. HasCallStack => String -> a
error (String
"assign expected an Identifier, but got: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
t')

  Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Identifier -> Usage -> Expr -> Declaration
Assignment Identifier
uniqueName Usage
Cont Expr
aExpr)
  TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
texp

-- | Extract the elements of a vector expression and return expressions
-- to them. If given expression is not an identifier, an intermediate variable
-- will be used to assign the given expression to which is subsequently indexed.
unvec
  :: (HasCallStack, Backend backend)
  => Text
  -- ^ Name hint for intermediate signal
  -> TExpr
  -- ^ Vector expression
  -> State (BlockState backend) [TExpr]
  -- ^ Vector elements
unvec :: Text -> TExpr -> State (BlockState backend) [TExpr]
unvec Text
vName v :: TExpr
v@(TExpr -> HWType
ety -> Vector Int
vSize HWType
eType) = do
  TExpr
texp <- Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
toIdentifier Text
vName TExpr
v
  let vUniqueName :: Identifier
vUniqueName = case TExpr
texp of
        TExpr HWType
_ (Identifier Identifier
x Maybe Modifier
Nothing) -> Identifier
x
        TExpr
t' -> String -> Identifier
forall a. HasCallStack => String -> a
error (String
"unvec expected an Identifier, but got: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
t')

  let vIndex :: Int -> Expr
vIndex Int
i = Identifier -> Maybe Modifier -> Expr
Identifier Identifier
vUniqueName (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Indexed (TExpr -> HWType
ety TExpr
v, Int
10, Int
i)))
  [TExpr] -> State (BlockState backend) [TExpr]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Int -> TExpr) -> [Int] -> [TExpr]
forall a b. (a -> b) -> [a] -> [b]
map (HWType -> Expr -> TExpr
TExpr HWType
eType (Expr -> TExpr) -> (Int -> Expr) -> Int -> TExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Expr
vIndex) [Int
0..Int
vSizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1])
unvec Text
_ TExpr
e = String -> State (BlockState backend) [TExpr]
forall a. HasCallStack => String -> a
error (String -> State (BlockState backend) [TExpr])
-> String -> State (BlockState backend) [TExpr]
forall a b. (a -> b) -> a -> b
$ String
"unvec: cannot be called on non-vector: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HWType -> String
forall a. Show a => a -> String
show (TExpr -> HWType
ety TExpr
e)

-- | Deconstruct a 'Maybe' into its constructor 'Bit' and contents of its 'Just'
-- field. Note that the contents might be undefined, if the constructor bit is
-- set to 'Nothing'.
deconstructMaybe ::
  (HasCallStack, Backend backend) =>
  -- | Maybe expression
  TExpr ->
  -- | Name hint for constructor bit, data
  (Text, Text) ->
  -- | Constructor represented as a Bit, contents of Just
  State (BlockState backend) (TExpr, TExpr)
deconstructMaybe :: TExpr -> (Text, Text) -> State (BlockState backend) (TExpr, TExpr)
deconstructMaybe e :: TExpr
e@TExpr{HWType
ety :: HWType
ety :: TExpr -> HWType
ety} (Text
bitName, Text
contentName)
  | SP Text
tyName [(Text
_nothing, []),(Text
_just, [HWType
aTy])] <- HWType
ety
  , Text
tyName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Text
forall a. IsString a => String -> a
fromString (Name -> String
forall a. Show a => a -> String
show ''Maybe)
  = do
    TExpr
eBv <- Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
toBV (Text
bitName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_and_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
contentName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_bv") TExpr
e
    Identifier
eId <- Text -> TExpr -> State (BlockState backend) Identifier
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) Identifier
toIdentifier' (Text
bitName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_and_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
contentName) TExpr
eBv
    let eSize :: Int
eSize = HWType -> Int
typeSize HWType
ety

    TExpr
bitExpr <- Text -> HWType -> TExpr -> State (BlockState backend) TExpr
forall backend.
(HasCallStack, Backend backend) =>
Text -> HWType -> TExpr -> State (BlockState backend) TExpr
fromBV Text
bitName HWType
Bit TExpr :: HWType -> Expr -> TExpr
TExpr
      { eex :: Expr
eex = Identifier -> Maybe Modifier -> Expr
Identifier Identifier
eId (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Sliced (Int -> HWType
BitVector Int
eSize, Int
eSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
eSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)))
      , ety :: HWType
ety = Int -> HWType
BitVector Int
1
      }

    TExpr
contentExpr <- Text -> HWType -> TExpr -> State (BlockState backend) TExpr
forall backend.
(HasCallStack, Backend backend) =>
Text -> HWType -> TExpr -> State (BlockState backend) TExpr
fromBV Text
contentName HWType
aTy TExpr :: HWType -> Expr -> TExpr
TExpr
      { eex :: Expr
eex = Identifier -> Maybe Modifier -> Expr
Identifier Identifier
eId (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Sliced (Int -> HWType
BitVector Int
eSize, Int
eSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
0)))
      , ety :: HWType
ety = Int -> HWType
BitVector (Int
eSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      }

    (TExpr, TExpr) -> State (BlockState backend) (TExpr, TExpr)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TExpr
bitExpr, TExpr
contentExpr)

deconstructMaybe TExpr
e (Text, Text)
_ =
  String -> State (BlockState backend) (TExpr, TExpr)
forall a. HasCallStack => String -> a
error (String -> State (BlockState backend) (TExpr, TExpr))
-> String -> State (BlockState backend) (TExpr, TExpr)
forall a b. (a -> b) -> a -> b
$ String
"deconstructMaybe: cannot be called on non-Maybe: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HWType -> String
forall a. Show a => a -> String
show (TExpr -> HWType
ety TExpr
e)

-- | Extract the fields of a product type and return expressions
--   to them. These new expressions are given unique names and get
--   declared in the block scope.
deconstructProduct
  :: (HasCallStack, Backend backend)
  => TExpr
  -- ^ Product expression
  -> [Text]
  -- ^ Name hints for element assignments
  -> State (BlockState backend) [TExpr]
deconstructProduct :: TExpr -> [Text] -> State (BlockState backend) [TExpr]
deconstructProduct (TExpr ty :: HWType
ty@(Product Text
_ Maybe [Text]
_ [HWType]
fieldTys) (Identifier Identifier
resName Maybe Modifier
Nothing)) [Text]
nameHints =
  [(Int, Text, HWType)]
-> ((Int, Text, HWType)
    -> StateT (BlockState backend) Identity TExpr)
-> State (BlockState backend) [TExpr]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Int] -> [Text] -> [HWType] -> [(Int, Text, HWType)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int
0..] [Text]
nameHints [HWType]
fieldTys) (((Int, Text, HWType)
  -> StateT (BlockState backend) Identity TExpr)
 -> State (BlockState backend) [TExpr])
-> ((Int, Text, HWType)
    -> StateT (BlockState backend) Identity TExpr)
-> State (BlockState backend) [TExpr]
forall a b. (a -> b) -> a -> b
$ \(Int
fieldIndex, Text
nameHint, HWType
fieldTy) ->
    Text -> TExpr -> StateT (BlockState backend) Identity TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
assign Text
nameHint (TExpr -> StateT (BlockState backend) Identity TExpr)
-> TExpr -> StateT (BlockState backend) Identity TExpr
forall a b. (a -> b) -> a -> b
$
      HWType -> Expr -> TExpr
TExpr HWType
fieldTy (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
resName (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Indexed (HWType
ty, Int
0, Int
fieldIndex))))

deconstructProduct t0 :: TExpr
t0@(TExpr (Product {}) Expr
_) [Text]
nameHints = do
  TExpr
t1 <- Text -> TExpr -> StateT (BlockState backend) Identity TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
toIdentifier Text
"product" TExpr
t0
  TExpr -> [Text] -> State (BlockState backend) [TExpr]
forall backend.
(HasCallStack, Backend backend) =>
TExpr -> [Text] -> State (BlockState backend) [TExpr]
deconstructProduct TExpr
t1 [Text]
nameHints

deconstructProduct TExpr
e [Text]
i =
  String -> State (BlockState backend) [TExpr]
forall a. HasCallStack => String -> a
error (String -> State (BlockState backend) [TExpr])
-> String -> State (BlockState backend) [TExpr]
forall a b. (a -> b) -> a -> b
$ String
"deconstructProduct: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
e String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Text] -> String
forall a. Show a => a -> String
show [Text]
i

-- | Extract the elements of a tuple expression and return expressions
--   to them. These new expressions are given unique names and get
--   declared in the block scope.
untuple
  :: (HasCallStack, Backend backend)
  => TExpr
  -- ^ Tuple expression
  -> [Text]
  -- ^ Name hints for element assignments
  -> State (BlockState backend) [TExpr]
untuple :: TExpr -> [Text] -> State (BlockState backend) [TExpr]
untuple = TExpr -> [Text] -> State (BlockState backend) [TExpr]
forall backend.
(HasCallStack, Backend backend) =>
TExpr -> [Text] -> State (BlockState backend) [TExpr]
deconstructProduct

-- | The high literal bit.
pattern High :: TExpr
pattern $bHigh :: TExpr
$mHigh :: forall r. TExpr -> (Void# -> r) -> (Void# -> r) -> r
High <- TExpr Bit (Literal _ (BitLit H))
  where High = HWType -> Expr -> TExpr
TExpr HWType
Bit (Maybe (HWType, Int) -> Literal -> Expr
Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (HWType
Bit,Int
1)) (Bit -> Literal
BitLit Bit
H))

-- | The low literal bit.
pattern Low :: TExpr
pattern $bLow :: TExpr
$mLow :: forall r. TExpr -> (Void# -> r) -> (Void# -> r) -> r
Low <- TExpr Bit (Literal _ (BitLit L))
  where Low = HWType -> Expr -> TExpr
TExpr HWType
Bit (Maybe (HWType, Int) -> Literal -> Expr
Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (HWType
Bit,Int
1)) (Bit -> Literal
BitLit Bit
L))

-- | The true literal bool.
pattern T :: TExpr
pattern $bT :: TExpr
$mT :: forall r. TExpr -> (Void# -> r) -> (Void# -> r) -> r
T <- TExpr Bool (Literal _ (BoolLit True))
  where T = HWType -> Expr -> TExpr
TExpr HWType
Bool (Maybe (HWType, Int) -> Literal -> Expr
Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (HWType
Bool,Int
1)) (Bool -> Literal
BoolLit Bool
True))

-- | The false literal bool.
pattern F :: TExpr
pattern $bF :: TExpr
$mF :: forall r. TExpr -> (Void# -> r) -> (Void# -> r) -> r
F <- TExpr Bool (Literal _ (BoolLit False))
  where F = HWType -> Expr -> TExpr
TExpr HWType
Bool (Maybe (HWType, Int) -> Literal -> Expr
Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (HWType
Bool,Int
1)) (Bool -> Literal
BoolLit Bool
False))

-- | Construct a fully defined BitVector literal
bvLit
  :: Int
  -- ^ BitVector size
  -> Integer
  -- ^ Literal
  -> TExpr
bvLit :: Int -> Integer -> TExpr
bvLit Int
sz Integer
n =
  HWType -> Expr -> TExpr
TExpr
    (Int -> HWType
BitVector Int
sz)
    (Maybe (HWType, Int) -> Literal -> Expr
Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
BitVector Int
sz, Int
sz)) (Integer -> Integer -> Literal
BitVecLit Integer
0 Integer
n))

-- | Convert a bool to a bit.
boolToBit
  :: (HasCallStack, Backend backend)
  => Text
  -- ^ Name hint for intermediate signal
  -> TExpr
  -> State (BlockState backend) TExpr
boolToBit :: Text -> TExpr -> State (BlockState backend) TExpr
boolToBit Text
bitName = \case
  TExpr
T -> TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
High
  TExpr
F -> TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
Low
  TExpr HWType
Bool Expr
boolExpr -> do
    TExpr
texp <- Text -> HWType -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> HWType -> State (BlockState backend) TExpr
declare Text
bitName HWType
Bit
    let uniqueBitName :: Identifier
uniqueBitName = case TExpr
texp of
          TExpr HWType
_ (Identifier Identifier
x Maybe Modifier
Nothing) -> Identifier
x
          TExpr
t' -> String -> Identifier
forall a. HasCallStack => String -> a
error (String
"boolFromBit expected an Identifier, but got: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
t')
    Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Declaration -> State (BlockState backend) ())
-> Declaration -> State (BlockState backend) ()
forall a b. (a -> b) -> a -> b
$
      Identifier
-> HWType
-> Expr
-> HWType
-> [(Maybe Literal, Expr)]
-> Declaration
CondAssignment Identifier
uniqueBitName HWType
Bit Expr
boolExpr HWType
Bool
        [ (Literal -> Maybe Literal
forall a. a -> Maybe a
Just (Bool -> Literal
BoolLit Bool
True), Maybe (HWType, Int) -> Literal -> Expr
Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (Bit -> Literal
BitLit Bit
H))
        , (Maybe Literal
forall a. Maybe a
Nothing            , Maybe (HWType, Int) -> Literal -> Expr
Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (Bit -> Literal
BitLit Bit
L))
        ]
    Usage -> Identifier -> State (BlockState backend) ()
forall s. HasUsageMap s => Usage -> Identifier -> State s ()
declareUseOnce (Blocking -> Usage
Proc Blocking
NonBlocking) Identifier
uniqueBitName
    TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
texp
  TExpr
tExpr -> String -> State (BlockState backend) TExpr
forall a. HasCallStack => String -> a
error (String -> State (BlockState backend) TExpr)
-> String -> State (BlockState backend) TExpr
forall a b. (a -> b) -> a -> b
$ String
"boolToBit: Got \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
tExpr String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\" expected Bool"

-- | Convert an enable to a bit.
enableToBit
  :: (HasCallStack, Backend backend)
  => Text
  -- ^ Name hint for intermediate signal
  -> TExpr
  -> State (BlockState backend) TExpr
enableToBit :: Text -> TExpr -> State (BlockState backend) TExpr
enableToBit Text
bitName = \case
  TExpr ena :: HWType
ena@(Enable Text
_) Expr
enableExpr -> do
    TExpr
texp <- Text -> HWType -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> HWType -> State (BlockState backend) TExpr
declare Text
bitName HWType
Bit
    let uniqueBitName :: Identifier
uniqueBitName = case TExpr
texp of
          TExpr HWType
_ (Identifier Identifier
x Maybe Modifier
Nothing) -> Identifier
x
          TExpr
t' -> String -> Identifier
forall a. HasCallStack => String -> a
error (String
"boolFromBit expected an Identifier, but got: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
t')
    Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Declaration -> State (BlockState backend) ())
-> Declaration -> State (BlockState backend) ()
forall a b. (a -> b) -> a -> b
$
      Identifier
-> HWType
-> Expr
-> HWType
-> [(Maybe Literal, Expr)]
-> Declaration
CondAssignment Identifier
uniqueBitName HWType
Bit Expr
enableExpr HWType
ena
        -- Enable normalizes to Bool for all current backends
        [ (Literal -> Maybe Literal
forall a. a -> Maybe a
Just (Bool -> Literal
BoolLit Bool
True), Maybe (HWType, Int) -> Literal -> Expr
Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (Bit -> Literal
BitLit Bit
H))
        , (Maybe Literal
forall a. Maybe a
Nothing            , Maybe (HWType, Int) -> Literal -> Expr
Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (Bit -> Literal
BitLit Bit
L))
        ]
    Usage -> Identifier -> State (BlockState backend) ()
forall s. HasUsageMap s => Usage -> Identifier -> State s ()
declareUseOnce (Blocking -> Usage
Proc Blocking
NonBlocking) Identifier
uniqueBitName
    TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
texp
  TExpr
tExpr -> String -> State (BlockState backend) TExpr
forall a. HasCallStack => String -> a
error (String -> State (BlockState backend) TExpr)
-> String -> State (BlockState backend) TExpr
forall a b. (a -> b) -> a -> b
$ String
"enableToBit: Got \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
tExpr String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\" expected Enable"

-- | Use to create an output `Bool` from a `Bit`. The expression given
--   must be the identifier of the bool you wish to get assigned.
--   Returns a reference to a declared `Bit` that should get assigned
--   by something (usually the output port of an entity).
boolFromBit
  :: (HasCallStack, Backend backend)
  => Text
  -- ^ Name hint for intermediate signal
  -> TExpr
  -> State (BlockState backend) TExpr
boolFromBit :: Text -> TExpr -> State (BlockState backend) TExpr
boolFromBit Text
boolName = \case
  TExpr
High -> TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
T
  TExpr
Low -> TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
F
  TExpr HWType
Bit Expr
bitExpr -> do
    TExpr
texp <- Text -> HWType -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> HWType -> State (BlockState backend) TExpr
declare Text
boolName HWType
Bool
    let uniqueBoolName :: Identifier
uniqueBoolName = case TExpr
texp of
          TExpr HWType
_ (Identifier Identifier
x Maybe Modifier
Nothing) -> Identifier
x
          TExpr
t' -> String -> Identifier
forall a. HasCallStack => String -> a
error (String
"boolFromBit expected an Identifier, but got: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
t')
    Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Declaration -> State (BlockState backend) ())
-> Declaration -> State (BlockState backend) ()
forall a b. (a -> b) -> a -> b
$
      Identifier
-> HWType
-> Expr
-> HWType
-> [(Maybe Literal, Expr)]
-> Declaration
CondAssignment Identifier
uniqueBoolName HWType
Bool Expr
bitExpr HWType
Bit
        [ (Literal -> Maybe Literal
forall a. a -> Maybe a
Just (Bit -> Literal
BitLit Bit
H), Maybe (HWType, Int) -> Literal -> Expr
Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (Bool -> Literal
BoolLit Bool
True))
        , (Maybe Literal
forall a. Maybe a
Nothing        , Maybe (HWType, Int) -> Literal -> Expr
Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (Bool -> Literal
BoolLit Bool
False))
        ]
    Usage -> Identifier -> State (BlockState backend) ()
forall s. HasUsageMap s => Usage -> Identifier -> State s ()
declareUseOnce (Blocking -> Usage
Proc Blocking
NonBlocking) Identifier
uniqueBoolName
    TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
texp
  TExpr
tExpr -> String -> State (BlockState backend) TExpr
forall a. HasCallStack => String -> a
error (String -> State (BlockState backend) TExpr)
-> String -> State (BlockState backend) TExpr
forall a b. (a -> b) -> a -> b
$ String
"boolFromBit: Got \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
tExpr String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\" expected Bit"

-- | Used to create an output `Bool` from a `BitVector` of given size.
-- Works in a similar way to `boolFromBit` above.
--
-- TODO: Implement for (System)Verilog
boolFromBitVector
  :: Size
  -> Text
  -- ^ Name hint for intermediate signal
  -> TExpr
  -> State (BlockState VHDLState) TExpr
boolFromBitVector :: Int -> Text -> TExpr -> State (BlockState VHDLState) TExpr
boolFromBitVector Int
n =
  HWType
-> HWType
-> (Text -> Text)
-> Text
-> TExpr
-> State (BlockState VHDLState) TExpr
forall backend.
(HasCallStack, Backend backend) =>
HWType
-> HWType
-> (Text -> Text)
-> Text
-> TExpr
-> State (BlockState backend) TExpr
outputCoerce (Int -> HWType
BitVector Int
n) HWType
Bool (\Text
i -> Text
"unsigned(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") > 0")

-- | Used to create an output `Unsigned` from a `BitVector` of given
-- size. Works in a similar way to `boolFromBit` above.
unsignedFromBitVector ::
  (HasCallStack, Backend backend) =>
  -- | Name hint for intermediate signal
  Text ->
  -- | BitVector expression
  TExpr ->
  -- | Unsigned expression
  State (BlockState backend) TExpr
unsignedFromBitVector :: Text -> TExpr -> State (BlockState backend) TExpr
unsignedFromBitVector Text
nameHint e :: TExpr
e@TExpr{ety :: TExpr -> HWType
ety=BitVector Int
n} =
  Text -> HWType -> TExpr -> State (BlockState backend) TExpr
forall backend.
(HasCallStack, Backend backend) =>
Text -> HWType -> TExpr -> State (BlockState backend) TExpr
fromBV Text
nameHint (Int -> HWType
Unsigned Int
n) TExpr
e
unsignedFromBitVector Text
_nameHint TExpr{HWType
ety :: HWType
ety :: TExpr -> HWType
ety} =
  String -> State (BlockState backend) TExpr
forall a. HasCallStack => String -> a
error (String -> State (BlockState backend) TExpr)
-> String -> State (BlockState backend) TExpr
forall a b. (a -> b) -> a -> b
$ String
"unsignedFromBitVector: Expected BitVector, got: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HWType -> String
forall a. Show a => a -> String
show HWType
ety

-- | Used to create an output `Bool` from a number of `Bit`s, using
-- conjunction. Similarly to `untuple`, it returns a list of
-- references to declared values (the inputs to the function) which
-- should get assigned by something---usually output ports of an
-- entity.
--
-- TODO: Implement for (System)Verilog
boolFromBits
  :: [Text]
  -> TExpr
  -> State (BlockState VHDLState) [TExpr]
boolFromBits :: [Text] -> TExpr -> State (BlockState VHDLState) [TExpr]
boolFromBits [Text]
inNames = [HWType]
-> HWType
-> ([Text] -> Text)
-> [Text]
-> TExpr
-> State (BlockState VHDLState) [TExpr]
forall backend.
(HasCallStack, Backend backend) =>
[HWType]
-> HWType
-> ([Text] -> Text)
-> [Text]
-> TExpr
-> State (BlockState backend) [TExpr]
outputFn ((Text -> HWType) -> [Text] -> [HWType]
forall a b. (a -> b) -> [a] -> [b]
map (HWType -> Text -> HWType
forall a b. a -> b -> a
const HWType
Bit) [Text]
inNames) HWType
Bool
  ((Text -> Text -> Text) -> Text -> [Text] -> Text
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>) Text
"" ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse Text
" and " ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
i -> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = '1')")) [Text]
inNames

-- | Used to create an output value with an arbitrary VHDL coercion.
-- The expression given should be the identifier of the output value
-- you wish to get assigned. Returns a reference to a declared value
-- of the input type that should get assigned by something (usually
-- the output port of an entity).
outputCoerce
  :: (HasCallStack, Backend backend)
  => HWType
  -> HWType
  -> (Text -> Text)
  -> Text
  -> TExpr
  -> State (BlockState backend) TExpr
outputCoerce :: HWType
-> HWType
-> (Text -> Text)
-> Text
-> TExpr
-> State (BlockState backend) TExpr
outputCoerce HWType
fromType HWType
toType Text -> Text
exprStringFn Text
inName0 TExpr
expr_
  | TExpr HWType
outType (Identifier Identifier
outName Maybe Modifier
Nothing) <- TExpr
expr_
  , HWType
outType HWType -> HWType -> Bool
forall a. Eq a => a -> a -> Bool
== HWType
toType = do
      Identifier
inName1 <- Text -> StateT (BlockState backend) Identity Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic Text
inName0
      let inName2 :: Identifier
inName2 = HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake (Text -> Text
exprStringFn (Identifier -> Text
Id.toText Identifier
inName1))
          exprIdent :: Expr
exprIdent = Identifier -> Maybe Modifier -> Expr
Identifier Identifier
inName2 Maybe Modifier
forall a. Maybe a
Nothing
      Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Maybe Text -> Identifier -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Identifier
inName1 HWType
fromType)
      Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Identifier -> Usage -> Expr -> Declaration
Assignment Identifier
outName Usage
Cont Expr
exprIdent)
      TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HWType -> Expr -> TExpr
TExpr HWType
fromType (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
inName1 Maybe Modifier
forall a. Maybe a
Nothing))
outputCoerce HWType
_ HWType
toType Text -> Text
_ Text
_ TExpr
texpr = String -> State (BlockState backend) TExpr
forall a. HasCallStack => String -> a
error (String -> State (BlockState backend) TExpr)
-> String -> State (BlockState backend) TExpr
forall a b. (a -> b) -> a -> b
$ String
"outputCoerce: the expression " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
texpr
                                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" must be an Identifier with type " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HWType -> String
forall a. Show a => a -> String
show HWType
toType

-- | Used to create an output value that is an arbitrary function (as
-- VHDL) of existing values. The expression given should be the
-- identifier of the output value you wish to get assigned. Similarly
-- to `untuple`, it returns a list of references to declared values
-- (the inputs to the function) which should get assigned by
-- something---usually output ports of an entity.
outputFn
  :: (HasCallStack, Backend backend)
  => [HWType]
  -> HWType
  -> ([Text] -> Text)
  -> [Text]
  -> TExpr
  -> State (BlockState backend) [TExpr]
outputFn :: [HWType]
-> HWType
-> ([Text] -> Text)
-> [Text]
-> TExpr
-> State (BlockState backend) [TExpr]
outputFn [HWType]
fromTypes HWType
toType [Text] -> Text
exprFn [Text]
inNames0 (TExpr HWType
outType (Identifier Identifier
outName Maybe Modifier
Nothing))
  | HWType
outType HWType -> HWType -> Bool
forall a. Eq a => a -> a -> Bool
== HWType
toType = do
      [Identifier]
inNames1 <- (Text -> StateT (BlockState backend) Identity Identifier)
-> [Text] -> StateT (BlockState backend) Identity [Identifier]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> StateT (BlockState backend) Identity Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic [Text]
inNames0
      let idExpr :: Identifier
idExpr = HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake ([Text] -> Text
exprFn ((Identifier -> Text) -> [Identifier] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Identifier -> Text
Id.toText [Identifier]
inNames1))
          exprIdent :: Expr
exprIdent = Identifier -> Maybe Modifier -> Expr
Identifier Identifier
idExpr Maybe Modifier
forall a. Maybe a
Nothing
      Getting
  (Sequenced () (StateT (BlockState backend) Identity))
  [State (BlockState backend) ()]
  (State (BlockState backend) ())
-> [State (BlockState backend) ()] -> State (BlockState backend) ()
forall (m :: Type -> Type) a s.
Monad m =>
Getting (Sequenced a m) s (m a) -> s -> m ()
sequenceOf_ Getting
  (Sequenced () (StateT (BlockState backend) Identity))
  [State (BlockState backend) ()]
  (State (BlockState backend) ())
forall s t a b. Each s t a b => Traversal s t a b
each [ Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Maybe Text -> Identifier -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Identifier
nm HWType
t)
                       | (Identifier
nm, HWType
t) <- [Identifier] -> [HWType] -> [(Identifier, HWType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Identifier]
inNames1 [HWType]
fromTypes ]
      Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Identifier -> Usage -> Expr -> Declaration
Assignment Identifier
outName Usage
Cont Expr
exprIdent)
      [TExpr] -> State (BlockState backend) [TExpr]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [ HWType -> Expr -> TExpr
TExpr HWType
t (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
nm Maybe Modifier
forall a. Maybe a
Nothing)
           | (Identifier
nm,HWType
t) <- [Identifier] -> [HWType] -> [(Identifier, HWType)]
forall a b. HasCallStack => [a] -> [b] -> [(a, b)]
zipEqual [Identifier]
inNames1 [HWType]
fromTypes ]
outputFn [HWType]
_ HWType
outType [Text] -> Text
_ [Text]
_ TExpr
texpr =
  String -> State (BlockState backend) [TExpr]
forall a. HasCallStack => String -> a
error (String -> State (BlockState backend) [TExpr])
-> String -> State (BlockState backend) [TExpr]
forall a b. (a -> b) -> a -> b
$ String
"outputFn: the expression " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
texpr
  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" must be an Identifier with type " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HWType -> String
forall a. Show a => a -> String
show HWType
outType

-- | Create a vector of 'TExpr's
vec
  :: (HasCallStack, Backend backend)
  => [TExpr]
  -- ^ Elements of vector
  -> State (BlockState backend) TExpr
  -- ^ Vector elements
vec :: [TExpr] -> State (BlockState backend) TExpr
vec els :: [TExpr]
els@(TExpr
el:[TExpr]
_)
  | (TExpr -> Bool) -> [TExpr] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all (\TExpr
e -> TExpr -> HWType
ety TExpr
e HWType -> HWType -> Bool
forall a. Eq a => a -> a -> Bool
== TExpr -> HWType
ety TExpr
el) [TExpr]
els
  = TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HWType -> Expr -> TExpr
TExpr (Int -> HWType -> HWType
Vector ([TExpr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [TExpr]
els) (TExpr -> HWType
ety TExpr
el)) Expr
theVec)
  | Bool
otherwise
  = String -> State (BlockState backend) TExpr
forall a. HasCallStack => String -> a
error (String -> State (BlockState backend) TExpr)
-> String -> State (BlockState backend) TExpr
forall a b. (a -> b) -> a -> b
$ String
"vec: elements not of same type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [TExpr] -> String
forall a. Show a => a -> String
show [TExpr]
els
 where
  theVec :: Expr
theVec = Int -> HWType -> [Expr] -> Expr
mkVectorChain ([TExpr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [TExpr]
els) (TExpr -> HWType
ety TExpr
el) ((TExpr -> Expr) -> [TExpr] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map TExpr -> Expr
eex [TExpr]
els)
vec [] = String -> State (BlockState backend) TExpr
forall a. HasCallStack => String -> a
error String
"vec: can't be used on empty lists"

-- | Construct a product type given its type and fields
constructProduct :: HWType -> [TExpr] -> TExpr
constructProduct :: HWType -> [TExpr] -> TExpr
constructProduct HWType
ty [TExpr]
els =
  HWType -> Expr -> TExpr
TExpr HWType
ty (HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
ty ((HWType, Int) -> Modifier
DC (HWType
ty,Int
0)) ((TExpr -> Expr) -> [TExpr] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map TExpr -> Expr
eex [TExpr]
els))

-- | Create an n-tuple of 'TExpr'
tuple :: HasCallStack => [TExpr] -> TExpr
tuple :: [TExpr] -> TExpr
tuple [] = String -> TExpr
forall a. HasCallStack => String -> a
error (String -> TExpr) -> String -> TExpr
forall a b. (a -> b) -> a -> b
$ String
"nTuple: Cannot create empty tuple"
tuple [TExpr
_] =
  -- If we don't put this in: tuple . untuple /= id
  String -> TExpr
forall a. HasCallStack => String -> a
error (String -> TExpr) -> String -> TExpr
forall a b. (a -> b) -> a -> b
$ String
"nTuple: Cannot create 1-tuple"
tuple [TExpr]
els = HWType -> [TExpr] -> TExpr
constructProduct HWType
tupTy [TExpr]
els
 where
  commas :: Text
commas = Int -> Text -> Text
Text.replicate ([TExpr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [TExpr]
els Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text
","
  tupTy :: HWType
tupTy = Text -> Maybe [Text] -> [HWType] -> HWType
Product (Text
"GHC.Tuple.(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
commas Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")") Maybe [Text]
forall a. Maybe a
Nothing ((TExpr -> HWType) -> [TExpr] -> [HWType]
forall a b. (a -> b) -> [a] -> [b]
map TExpr -> HWType
ety [TExpr]
els)

-- | Try to get the literal string value of an expression.
getStr :: TExpr -> Maybe String
getStr :: TExpr -> Maybe String
getStr (TExpr HWType
_ Expr
e) = Expr -> Maybe String
exprToString Expr
e

-- | Try to get the literal bool value of an expression.
getBool :: TExpr -> Maybe Bool
getBool :: TExpr -> Maybe Bool
getBool (TExpr HWType
_ (Literal Maybe (HWType, Int)
_ (BoolLit Bool
b))) = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
b
getBool TExpr
_ = Maybe Bool
forall a. Maybe a
Nothing

-- | Try to get a Vector of expressions.
getVec :: TExpr -> Maybe [TExpr]
getVec :: TExpr -> Maybe [TExpr]
getVec (TExpr (Void (Just (Vector Int
0 HWType
_) )) Expr
_) =
  [TExpr] -> Maybe [TExpr]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
getVec (TExpr (Vector Int
1 HWType
elementTy) (DataCon HWType
_ Modifier
VecAppend [Expr
e])) =
  [TExpr] -> Maybe [TExpr]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [HWType -> Expr -> TExpr
TExpr HWType
elementTy Expr
e]
getVec (TExpr (Vector Int
n HWType
elementTy) (DataCon HWType
_ Modifier
VecAppend [Expr
e, Expr
es0])) = do
  [TExpr]
es1 <- TExpr -> Maybe [TExpr]
getVec (HWType -> Expr -> TExpr
TExpr (Int -> HWType -> HWType
Vector (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) HWType
elementTy) Expr
es0)
  [TExpr] -> Maybe [TExpr]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HWType -> Expr -> TExpr
TExpr HWType
elementTy Expr
eTExpr -> [TExpr] -> [TExpr]
forall a. a -> [a] -> [a]
:[TExpr]
es1)
getVec TExpr
_ = Maybe [TExpr]
forall a. Maybe a
Nothing

-- | Try to get the literal nat value of an expression.
tExprToInteger :: TExpr -> Maybe Integer
tExprToInteger :: TExpr -> Maybe Integer
tExprToInteger (TExpr HWType
_ Expr
e) = Expr -> Maybe Integer
exprToInteger Expr
e

exprToInteger :: Expr -> Maybe Integer
exprToInteger :: Expr -> Maybe Integer
exprToInteger (DataCon HWType
_ Modifier
_ [Expr
n]) = Expr -> Maybe Integer
exprToInteger Expr
n
exprToInteger (Literal Maybe (HWType, Int)
_ (NumLit Integer
n)) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
n
exprToInteger Expr
_ = Maybe Integer
forall a. Maybe a
Nothing

-- | Convert an expression from one type to another. Errors if result type and
-- given expression are sized differently.
bitCoerce ::
  (HasCallStack, Backend backend) =>
  -- | Name hints for intermediate variables
  Text ->
  -- | Type to convert to
  HWType ->
  -- | Expression to convert
  TExpr ->
  -- | Converted expression
  State (BlockState backend) TExpr
bitCoerce :: Text -> HWType -> TExpr -> State (BlockState backend) TExpr
bitCoerce Text
nameHint HWType
destType e :: TExpr
e@(TExpr HWType
ety Expr
_)
  | HWType -> Int
forall i. Num i => HWType -> i
tySize HWType
ety Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= HWType -> Int
forall i. Num i => HWType -> i
tySize @Int HWType
destType = String -> State (BlockState backend) TExpr
forall a. HasCallStack => String -> a
error String
"Size mismatch"
  | HWType
ety HWType -> HWType -> Bool
forall a. Eq a => a -> a -> Bool
== HWType
destType = TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
e
  | BitVector Int
_ <- HWType
ety = Text -> HWType -> TExpr -> State (BlockState backend) TExpr
forall backend.
(HasCallStack, Backend backend) =>
Text -> HWType -> TExpr -> State (BlockState backend) TExpr
fromBV Text
nameHint HWType
destType TExpr
e
  | Bool
otherwise = Text -> HWType -> TExpr -> State (BlockState backend) TExpr
forall backend.
(HasCallStack, Backend backend) =>
Text -> HWType -> TExpr -> State (BlockState backend) TExpr
bitCoerce Text
nameHint HWType
destType (TExpr -> State (BlockState backend) TExpr)
-> State (BlockState backend) TExpr
-> State (BlockState backend) TExpr
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
toBV Text
nameHint TExpr
e

-- | Convert an expression to a BitVector
toBV ::
  Backend backend =>
  -- | BitVector name hint
  Text ->
  -- | Expression to convert to BitVector
  TExpr ->
  -- | BitVector expression
  State (BlockState backend) TExpr
toBV :: Text -> TExpr -> State (BlockState backend) TExpr
toBV = [Attr Text] -> Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
[Attr Text] -> Text -> TExpr -> State (BlockState backend) TExpr
toBvWithAttrs []

-- | Convert an expression to a BitVector and add the given HDL attributes
toBvWithAttrs ::
  Backend backend =>
  [Attr Text] ->
  -- | BitVector name hint
  Text ->
  -- | Expression to convert to BitVector
  TExpr ->
  -- | BitVector expression
  State (BlockState backend) TExpr
toBvWithAttrs :: [Attr Text] -> Text -> TExpr -> State (BlockState backend) TExpr
toBvWithAttrs [Attr Text]
attrs Text
bvName (TExpr HWType
aTy Expr
aExpr) =
  Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
assign Text
bvName (TExpr -> State (BlockState backend) TExpr)
-> TExpr -> State (BlockState backend) TExpr
forall a b. (a -> b) -> a -> b
$
    HWType -> Expr -> TExpr
TExpr
      ([Attr Text] -> HWType -> HWType
annotated [Attr Text]
attrs (Int -> HWType
BitVector (HWType -> Int
forall i. Num i => HWType -> i
tySize HWType
aTy)))
      (Maybe Identifier -> HWType -> Expr -> Expr
ToBv Maybe Identifier
forall a. Maybe a
Nothing HWType
aTy Expr
aExpr)

-- | Convert an expression from a 'BitVector' into some type. If the expression
-- is 'Annotated', only convert the expression within.
fromBV
  :: (HasCallStack, Backend backend) =>
  -- | Result name hint
  Text ->
  -- | Type to convert to
  HWType ->
  -- | 'BitVector' expression
  TExpr ->
  -- | Converted 'BitVector' expression
  State (BlockState backend) TExpr
fromBV :: Text -> HWType -> TExpr -> State (BlockState backend) TExpr
fromBV Text
resultName HWType
resultType e :: TExpr
e@TExpr{Expr
eex :: Expr
eex :: TExpr -> Expr
eex, ety :: TExpr -> HWType
ety = BitVector Int
_} =
  case HWType
resultType of
    BitVector{} -> TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
e
    HWType
_ -> Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
assign Text
resultName (HWType -> Expr -> TExpr
TExpr HWType
resultType (Maybe Identifier -> HWType -> Expr -> Expr
FromBv Maybe Identifier
forall a. Maybe a
Nothing HWType
resultType Expr
eex))
fromBV Text
resultName HWType
resultType e :: TExpr
e@TExpr{ety :: TExpr -> HWType
ety = Annotated [Attr Text]
_ bv :: HWType
bv@(BitVector Int
_)} =
  case HWType
resultType of
    BitVector{} -> TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HWType -> Expr -> TExpr
TExpr HWType
bv (TExpr -> Expr
eex TExpr
e))
    HWType
_ -> Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
assign Text
resultName (HWType -> Expr -> TExpr
TExpr HWType
resultType (Maybe Identifier -> HWType -> Expr -> Expr
FromBv Maybe Identifier
forall a. Maybe a
Nothing HWType
resultType (TExpr -> Expr
eex TExpr
e)))
fromBV Text
_ HWType
_ TExpr{HWType
ety :: HWType
ety :: TExpr -> HWType
ety} = String -> State (BlockState backend) TExpr
forall a. HasCallStack => String -> a
error (String -> State (BlockState backend) TExpr)
-> String -> State (BlockState backend) TExpr
forall a b. (a -> b) -> a -> b
$ String
"fromBV: expected BitVector, got: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HWType -> String
forall a. Show a => a -> String
show HWType
ety

clog2 :: Num i => Integer -> i
clog2 :: Integer -> i
clog2 = Int -> i
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> i) -> (Integer -> Int) -> Integer -> i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> (Integer -> Maybe Int) -> Integer -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer -> Maybe Int
clogBase Integer
2

tySize :: Num i => HWType -> i
tySize :: HWType -> i
tySize = Int -> i
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> i) -> (HWType -> Int) -> HWType -> i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HWType -> Int
typeSize

-- | A literal that can be used for hdl attributes. It has a `Num` and
--   `IsString` instances for convenience.
data LitHDL
  = B Bool
  | S String
  | I Integer
  deriving Int -> LitHDL -> ShowS
[LitHDL] -> ShowS
LitHDL -> String
(Int -> LitHDL -> ShowS)
-> (LitHDL -> String) -> ([LitHDL] -> ShowS) -> Show LitHDL
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LitHDL] -> ShowS
$cshowList :: [LitHDL] -> ShowS
show :: LitHDL -> String
$cshow :: LitHDL -> String
showsPrec :: Int -> LitHDL -> ShowS
$cshowsPrec :: Int -> LitHDL -> ShowS
Show

instance Num LitHDL where
  + :: LitHDL -> LitHDL -> LitHDL
(+) = LitHDL -> LitHDL -> LitHDL
forall a. HasCallStack => a
undefined
  * :: LitHDL -> LitHDL -> LitHDL
(*) = LitHDL -> LitHDL -> LitHDL
forall a. HasCallStack => a
undefined
  abs :: LitHDL -> LitHDL
abs = LitHDL -> LitHDL
forall a. HasCallStack => a
undefined
  signum :: LitHDL -> LitHDL
signum = LitHDL -> LitHDL
forall a. HasCallStack => a
undefined
  negate :: LitHDL -> LitHDL
negate = LitHDL -> LitHDL
forall a. HasCallStack => a
undefined
  fromInteger :: Integer -> LitHDL
fromInteger = Integer -> LitHDL
I

instance IsString LitHDL where
  fromString :: String -> LitHDL
fromString = String -> LitHDL
S

-- | Instantiate/call a higher-order function.
instHO
  :: Backend backend
  => BlackBoxContext
  -- ^ BlackBoxContext, used for rendering higher-order function and error
  -- reporting
  -> Int
  -- ^ Position of HO-argument. For example:
  --
  --   fold :: forall n a . (a -> a -> a) -> Vec (n + 1) a -> a
  --
  -- would have its HO-argument at position 0, while
  --
  --  iterateI :: forall n a. KnownNat n => (a -> a) -> a -> Vec n a
  --
  -- would have it at position 1.
  -> (HWType, BlackBoxTemplate)
  -- ^ Result type of HO function
  -> [(TExpr, BlackBoxTemplate)]
  -- ^ Arguments and their types
  -> State (BlockState backend) TExpr
  -- ^ Result of the function
instHO :: BlackBoxContext
-> Int
-> (HWType, BlackBoxTemplate)
-> [(TExpr, BlackBoxTemplate)]
-> State (BlockState backend) TExpr
instHO BlackBoxContext
bbCtx Int
fPos (HWType
resTy, BlackBoxTemplate
bbResTy) [(TExpr, BlackBoxTemplate)]
argsWithTypes = do
  let ([TExpr]
args0, [BlackBoxTemplate]
argTypes) = [(TExpr, BlackBoxTemplate)] -> ([TExpr], [BlackBoxTemplate])
forall a b. [(a, b)] -> ([a], [b])
unzip [(TExpr, BlackBoxTemplate)]
argsWithTypes
  Int
fSubPos <- Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int)
-> (IntMap Int -> Maybe Int) -> IntMap Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IntMap Int -> Maybe Int
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
fPos (IntMap Int -> Int)
-> StateT (BlockState backend) Identity (IntMap Int)
-> StateT (BlockState backend) Identity Int
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (IntMap Int) (BlockState backend) (IntMap Int)
-> StateT (BlockState backend) Identity (IntMap Int)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use Getting (IntMap Int) (BlockState backend) (IntMap Int)
forall backend. Lens' (BlockState backend) (IntMap Int)
bsHigherOrderCalls
  (IntMap Int -> Identity (IntMap Int))
-> BlockState backend -> Identity (BlockState backend)
forall backend. Lens' (BlockState backend) (IntMap Int)
bsHigherOrderCalls ((IntMap Int -> Identity (IntMap Int))
 -> BlockState backend -> Identity (BlockState backend))
-> (IntMap Int -> IntMap Int)
-> StateT (BlockState backend) Identity ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Int -> Int -> IntMap Int -> IntMap Int
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
fPos (Int -> Int
forall a. Enum a => a -> a
succ Int
fSubPos)

  -- Create argument identifiers, example: fold_ho3_0_arg0
  let
    ctxName :: Text
ctxName = [Text] -> Text
forall a. [a] -> a
last ((Char -> Bool) -> Text -> [Text]
Text.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'.') (BlackBoxContext -> Text
bbName BlackBoxContext
bbCtx))
    baseArgName :: Text
baseArgName = Text
ctxName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"ho" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
fPos Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
fSubPos
    argName :: a -> Text
argName a
n = Text
baseArgName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_arg" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
showt a
n
  [Identifier]
args1 <- (Int -> TExpr -> StateT (BlockState backend) Identity Identifier)
-> [Int]
-> [TExpr]
-> StateT (BlockState backend) Identity [Identifier]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Int
argN -> Text -> TExpr -> StateT (BlockState backend) Identity Identifier
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) Identifier
toIdentifier' (Int -> Text
forall a. Show a => a -> Text
argName Int
argN)) [(Int
0::Int)..] [TExpr]
args0

  let
    args2 :: [BlackBoxTemplate]
args2 = (Identifier -> BlackBoxTemplate)
-> [Identifier] -> [BlackBoxTemplate]
forall a b. (a -> b) -> [a] -> [b]
map (Element -> BlackBoxTemplate
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Element -> BlackBoxTemplate)
-> (Identifier -> Element) -> Identifier -> BlackBoxTemplate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Element
Text (Text -> Element) -> (Identifier -> Text) -> Identifier -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> Text
Id.toLazyText) [Identifier]
args1

  Identifier
resName <- Text -> HWType -> StateT (BlockState backend) Identity Identifier
forall backend.
Backend backend =>
Text -> HWType -> State (BlockState backend) Identifier
declare' (Text
ctxName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"ho" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
fPos Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_"
                               Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
fSubPos Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_res") HWType
resTy
  let res :: (BlackBoxTemplate, BlackBoxTemplate)
res = ([Text -> Element
Text (Identifier -> Text
Id.toLazyText Identifier
resName)], BlackBoxTemplate
bbResTy)

  -- Render HO argument to plain text
  let component :: Element
component = Decl -> Element
Component (Int -> Int -> [(BlackBoxTemplate, BlackBoxTemplate)] -> Decl
Decl Int
fPos Int
fSubPos ((BlackBoxTemplate, BlackBoxTemplate)
res(BlackBoxTemplate, BlackBoxTemplate)
-> [(BlackBoxTemplate, BlackBoxTemplate)]
-> [(BlackBoxTemplate, BlackBoxTemplate)]
forall a. a -> [a] -> [a]
:[BlackBoxTemplate]
-> [BlackBoxTemplate] -> [(BlackBoxTemplate, BlackBoxTemplate)]
forall a b. [a] -> [b] -> [(a, b)]
zip [BlackBoxTemplate]
args2 [BlackBoxTemplate]
argTypes))
  Doc
rendered0 <-
    LensLike'
  (Zoomed (StateT backend Identity) Doc) (BlockState backend) backend
-> StateT backend Identity Doc
-> StateT (BlockState backend) Identity Doc
forall (m :: Type -> Type) (n :: Type -> Type) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike'
  (Zoomed (StateT backend Identity) Doc) (BlockState backend) backend
forall backend backend.
Lens (BlockState backend) (BlockState backend) backend backend
bsBackend (Text -> StateT backend Identity Doc
forall (f :: Type -> Type). Applicative f => Text -> f Doc
string (Text -> StateT backend Identity Doc)
-> StateT backend Identity Text -> StateT backend Identity Doc
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< (BlackBoxContext -> Element -> State backend (Int -> Text)
forall backend.
(HasCallStack, Backend backend) =>
BlackBoxContext -> Element -> State backend (Int -> Text)
renderElem BlackBoxContext
bbCtx Element
component State backend (Int -> Text)
-> StateT backend Identity Int -> StateT backend Identity Text
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Int -> StateT backend Identity Int
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Int
0))

  let
    layout :: LayoutOptions
layout = PageWidth -> LayoutOptions
LayoutOptions (Int -> Double -> PageWidth
AvailablePerLine Int
120 Double
0.4)
    rendered1 :: Text
rendered1 = SimpleDocStream () -> Text
forall ann. SimpleDocStream ann -> Text
renderLazy (LayoutOptions -> Doc -> SimpleDocStream ()
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
layout Doc
rendered0)

  Declaration -> StateT (BlockState backend) Identity ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Declaration -> StateT (BlockState backend) Identity ())
-> Declaration -> StateT (BlockState backend) Identity ()
forall a b. (a -> b) -> a -> b
$
    Text
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> BlackBoxContext
-> Declaration
BlackBoxD
      (Text
"__INST_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlackBoxContext -> Text
bbName BlackBoxContext
bbCtx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_BB_INTERNAL__") [] [] []
      (BlackBoxTemplate -> BlackBox
BBTemplate [Text -> Element
Text Text
rendered1])
      (Text -> BlackBoxContext
emptyBBContext (Text
"__INST_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlackBoxContext -> Text
bbName BlackBoxContext
bbCtx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_BB_INTERNAL__"))

  TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HWType -> Expr -> TExpr
TExpr HWType
resTy (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
resName Maybe Modifier
forall a. Maybe a
Nothing))

-- | This creates a component declaration (for VHDL) given in and out port
-- names, updating the 'BlockState backend' stored in the 'State' monad.
--
-- A typical result is that a
--
-- @
-- component fifo port
--    ( rst : in std_logic
--    ...
--    ; full : out std_logic
--    ; empty : out std_logic );
--  end component;
-- @
--
-- declaration would be added in the appropriate place.
compInBlock
  :: forall backend
   . Backend backend
  => Text
  -- ^ Component name
  -> [(Text, HWType)]
  -- ^ in ports
  -> [(Text, HWType)]
  -- ^ out ports
  -> State (BlockState backend) ()
compInBlock :: Text
-> [(Text, HWType)]
-> [(Text, HWType)]
-> State (BlockState backend) ()
compInBlock Text
compName [(Text, HWType)]
inPorts0 [(Text, HWType)]
outPorts0 =
  Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Text -> [(Text, PortDirection, HWType)] -> Declaration
CompDecl Text
compName ([(Text, PortDirection, HWType)]
inPorts1 [(Text, PortDirection, HWType)]
-> [(Text, PortDirection, HWType)]
-> [(Text, PortDirection, HWType)]
forall a. [a] -> [a] -> [a]
++ [(Text, PortDirection, HWType)]
outPorts1))
 where
  mkPort :: b -> (a, c) -> (a, b, c)
mkPort b
inOut (a
nm, c
ty) = (a
nm, b
inOut, c
ty)
  inPorts1 :: [(Text, PortDirection, HWType)]
inPorts1 = PortDirection -> (Text, HWType) -> (Text, PortDirection, HWType)
forall b a c. b -> (a, c) -> (a, b, c)
mkPort PortDirection
In ((Text, HWType) -> (Text, PortDirection, HWType))
-> [(Text, HWType)] -> [(Text, PortDirection, HWType)]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, HWType)]
inPorts0
  outPorts1 :: [(Text, PortDirection, HWType)]
outPorts1 = PortDirection -> (Text, HWType) -> (Text, PortDirection, HWType)
forall b a c. b -> (a, c) -> (a, b, c)
mkPort PortDirection
Out ((Text, HWType) -> (Text, PortDirection, HWType))
-> [(Text, HWType)] -> [(Text, PortDirection, HWType)]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, HWType)]
outPorts0

-- | Convert a 'LitHDL' to a 'TExpr'
--
-- __N.B.__: Clash 1.8 changed 'instDecl'\'s type signature. Where it would
--           previously accept 'LitHDL' in its generics/parameters argument, it
--           now accepts a 'TExpr'. This function is mostly there to ease this
--           transition.
litTExpr :: LitHDL -> TExpr
litTExpr :: LitHDL -> TExpr
litTExpr (B Bool
b) = HWType -> Expr -> TExpr
TExpr HWType
Bool    (Maybe (HWType, Int) -> Literal -> Expr
Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (Bool -> Literal
BoolLit Bool
b))
litTExpr (S String
s) = HWType -> Expr -> TExpr
TExpr HWType
String  (Maybe (HWType, Int) -> Literal -> Expr
Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (String -> Literal
StringLit String
s))
litTExpr (I Integer
i) = HWType -> Expr -> TExpr
TExpr HWType
Integer (Maybe (HWType, Int) -> Literal -> Expr
Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (Integer -> Literal
NumLit Integer
i))

-- | Instantiate a component/entity in a block state
instDecl
  :: forall backend
   . Backend backend
  => EntityOrComponent
  -- ^ Type of instantiation
  -> Identifier
  -- ^ Component/entity name
  -> Identifier
  -- ^ Instantiation label
  -> [(Text, TExpr)]
  -- ^ Generics / parameters
  -> [(Text, TExpr)]
  -- ^ In ports
  -> [(Text, TExpr)]
  -- ^ Out ports
  -> State (BlockState backend) ()
instDecl :: EntityOrComponent
-> Identifier
-> Identifier
-> [(Text, TExpr)]
-> [(Text, TExpr)]
-> [(Text, TExpr)]
-> State (BlockState backend) ()
instDecl EntityOrComponent
entOrComp Identifier
compName Identifier
instLbl [(Text, TExpr)]
params [(Text, TExpr)]
inPorts [(Text, TExpr)]
outPorts = do

  [(Expr, PortDirection, HWType, Expr)]
inPorts' <- ((Text, TExpr)
 -> StateT
      (BlockState backend) Identity (Expr, PortDirection, HWType, Expr))
-> [(Text, TExpr)]
-> StateT
     (BlockState backend) Identity [(Expr, PortDirection, HWType, Expr)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PortDirection
-> (Text, TExpr)
-> StateT
     (BlockState backend) Identity (Expr, PortDirection, HWType, Expr)
mkPort PortDirection
In) [(Text, TExpr)]
inPorts
  [(Expr, PortDirection, HWType, Expr)]
outPorts' <- ((Text, TExpr)
 -> StateT
      (BlockState backend) Identity (Expr, PortDirection, HWType, Expr))
-> [(Text, TExpr)]
-> StateT
     (BlockState backend) Identity [(Expr, PortDirection, HWType, Expr)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PortDirection
-> (Text, TExpr)
-> StateT
     (BlockState backend) Identity (Expr, PortDirection, HWType, Expr)
mkPort PortDirection
Out) [(Text, TExpr)]
outPorts

  Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Declaration -> State (BlockState backend) ())
-> Declaration -> State (BlockState backend) ()
forall a b. (a -> b) -> a -> b
$
    EntityOrComponent
-> Maybe Text
-> [Attr Text]
-> Identifier
-> Identifier
-> [(Expr, HWType, Expr)]
-> PortMap
-> Declaration
InstDecl
      EntityOrComponent
entOrComp Maybe Text
forall a. Maybe a
Nothing [] Identifier
compName Identifier
instLbl ([(Text, TExpr)] -> [(Expr, HWType, Expr)]
mkParams [(Text, TExpr)]
params)
      ([(Expr, PortDirection, HWType, Expr)] -> PortMap
NamedPortMap ([(Expr, PortDirection, HWType, Expr)]
inPorts' [(Expr, PortDirection, HWType, Expr)]
-> [(Expr, PortDirection, HWType, Expr)]
-> [(Expr, PortDirection, HWType, Expr)]
forall a. [a] -> [a] -> [a]
++ [(Expr, PortDirection, HWType, Expr)]
outPorts'))
   where
    mkPort
      :: PortDirection
      -> (Text, TExpr)
      -> StateT (BlockState backend) Identity (Expr, PortDirection, HWType, Expr)
    mkPort :: PortDirection
-> (Text, TExpr)
-> StateT
     (BlockState backend) Identity (Expr, PortDirection, HWType, Expr)
mkPort PortDirection
inOrOut (Text
nmText, TExpr
pExpr) = do
      TExpr HWType
ty Expr
pExpr' <- Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
toIdentifier (Text
nmText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_port")  TExpr
pExpr
      (Expr, PortDirection, HWType, Expr)
-> StateT
     (BlockState backend) Identity (Expr, PortDirection, HWType, Expr)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Identifier -> Maybe Modifier -> Expr
Identifier (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
nmText) Maybe Modifier
forall a. Maybe a
Nothing, PortDirection
inOrOut, HWType
ty, Expr
pExpr')

    -- Convert a list of name generics / parameters to the form clash wants
    mkParams :: [(Text.Text, TExpr)] -> [(Expr, HWType, Expr)]
    mkParams :: [(Text, TExpr)] -> [(Expr, HWType, Expr)]
mkParams = ((Text, TExpr) -> (Expr, HWType, Expr))
-> [(Text, TExpr)] -> [(Expr, HWType, Expr)]
forall a b. (a -> b) -> [a] -> [b]
map (((Text, TExpr) -> (Expr, HWType, Expr))
 -> [(Text, TExpr)] -> [(Expr, HWType, Expr)])
-> ((Text, TExpr) -> (Expr, HWType, Expr))
-> [(Text, TExpr)]
-> [(Expr, HWType, Expr)]
forall a b. (a -> b) -> a -> b
$ \(Text
paramName, TExpr
texpr) ->
      ( Identifier -> Maybe Modifier -> Expr
Identifier (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
paramName) Maybe Modifier
forall a. Maybe a
Nothing
      , TExpr -> HWType
ety TExpr
texpr
      , TExpr -> Expr
eex TExpr
texpr )

-- | Wires the two given `TExpr`s together using a newly declared
-- signal with (exactly) the given name `sigNm`. The new signal has an
-- annotated type, using the given attributes.
viaAnnotatedSignal
  :: (HasCallStack, Backend backend)
  => Identifier
  -- ^ Name given to signal
  -> TExpr
  -- ^ expression the signal is assigned to
  -> TExpr
  -- ^ expression (must be identifier) to which the signal is assigned
  -> [Attr Text]
  -- ^ the attributes to annotate the signal with
  -> State (BlockState backend) ()
viaAnnotatedSignal :: Identifier
-> TExpr -> TExpr -> [Attr Text] -> State (BlockState backend) ()
viaAnnotatedSignal Identifier
sigNm (TExpr HWType
fromTy Expr
fromExpr) (TExpr HWType
toTy (Identifier Identifier
outNm Maybe Modifier
Nothing)) [Attr Text]
attrs
  | HWType
fromTy HWType -> HWType -> Bool
forall a. Eq a => a -> a -> Bool
== HWType
toTy = do
      Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Maybe Text -> Identifier -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Identifier
sigNm ([Attr Text] -> HWType -> HWType
Annotated [Attr Text]
attrs HWType
fromTy))
      Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Identifier -> Usage -> Expr -> Declaration
Assignment Identifier
sigNm Usage
Cont Expr
fromExpr)
      Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Identifier -> Usage -> Expr -> Declaration
Assignment Identifier
outNm Usage
Cont (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
sigNm Maybe Modifier
forall a. Maybe a
Nothing))
viaAnnotatedSignal Identifier
_ TExpr
inTExpr outTExpr :: TExpr
outTExpr@(TExpr HWType
_ (Identifier Identifier
_ Maybe Modifier
_)) [Attr Text]
_ =
  String -> State (BlockState backend) ()
forall a. HasCallStack => String -> a
error (String -> State (BlockState backend) ())
-> String -> State (BlockState backend) ()
forall a b. (a -> b) -> a -> b
$ String
"viaAnnotatedSignal: The in and out expressions \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
inTExpr String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
  String
"\" and \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
outTExpr String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\" have non-matching types."
viaAnnotatedSignal Identifier
_ TExpr
_ TExpr
outTExpr [Attr Text]
_ =
  String -> State (BlockState backend) ()
forall a. HasCallStack => String -> a
error (String -> State (BlockState backend) ())
-> String -> State (BlockState backend) ()
forall a b. (a -> b) -> a -> b
$ String
"viaAnnotatedSignal: The out expression \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
outTExpr String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
  String
"\" must be an Identifier."

-- | The TExp inputs from a blackbox context.
tInputs :: BlackBoxContext -> [(TExpr, HWType)]
tInputs :: BlackBoxContext -> [(TExpr, HWType)]
tInputs = ((Expr, HWType, Bool) -> (TExpr, HWType))
-> [(Expr, HWType, Bool)] -> [(TExpr, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Expr
x, HWType
t, Bool
_) -> (HWType -> Expr -> TExpr
TExpr HWType
t Expr
x, HWType
t)) ([(Expr, HWType, Bool)] -> [(TExpr, HWType)])
-> (BlackBoxContext -> [(Expr, HWType, Bool)])
-> BlackBoxContext
-> [(TExpr, HWType)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlackBoxContext -> [(Expr, HWType, Bool)]
bbInputs

-- | The TExp result of a blackbox context.
tResults :: BlackBoxContext -> [TExpr]
tResults :: BlackBoxContext -> [TExpr]
tResults = ((Expr, HWType) -> TExpr) -> [(Expr, HWType)] -> [TExpr]
forall a b. (a -> b) -> [a] -> [b]
map (\(Expr
x,HWType
t) -> HWType -> Expr -> TExpr
TExpr HWType
t Expr
x) ([(Expr, HWType)] -> [TExpr])
-> (BlackBoxContext -> [(Expr, HWType)])
-> BlackBoxContext
-> [TExpr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlackBoxContext -> [(Expr, HWType)]
bbResults

-- | Get an identifier to an expression, creating a new assignment if
--   necessary.
toIdentifier'
  :: Backend backend
  => Text
  -- ^ desired new identifier name, will be made unique
  -> TExpr
  -- ^ expression to get identifier of
  -> State (BlockState backend) Identifier
  -- ^ identifier to expression
toIdentifier' :: Text -> TExpr -> State (BlockState backend) Identifier
toIdentifier' Text
_ (TExpr HWType
_ (Identifier Identifier
aExpr Maybe Modifier
Nothing)) = Identifier -> State (BlockState backend) Identifier
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Identifier
aExpr
toIdentifier' Text
nm TExpr
texp = do
  TExpr
t <- Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
assign Text
nm TExpr
texp
  let nm' :: Identifier
nm' = case TExpr
t of
              TExpr HWType
_ (Identifier Identifier
x Maybe Modifier
Nothing) -> Identifier
x
              TExpr
t' -> String -> Identifier
forall a. HasCallStack => String -> a
error (String
"toIdentifier' expected an Identifier, but got: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
t')
  Identifier -> State (BlockState backend) Identifier
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Identifier
nm'

-- | Get an identifier to an expression, creating a new assignment if
--   necessary.
toIdentifier
  :: Backend backend
  => Text
  -- ^ desired new identifier name, will be made unique
  -> TExpr
  -- ^ expression to get identifier of
  -> State (BlockState backend) TExpr
  -- ^ identifier to expression
toIdentifier :: Text -> TExpr -> State (BlockState backend) TExpr
toIdentifier Text
nm TExpr
texp = do
  Identifier
id' <- Text -> TExpr -> State (BlockState backend) Identifier
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) Identifier
toIdentifier' Text
nm TExpr
texp
  TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HWType -> Expr -> TExpr
TExpr (TExpr -> HWType
ety TExpr
texp) (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
id' Maybe Modifier
forall a. Maybe a
Nothing))

-- | And together @(&&)@ two expressions, assigning it to a new identifier.
andExpr
  :: Backend backend
  => Text
  -- ^ name hint
  -> TExpr
  -- ^ a
  -> TExpr
  -- ^ a
  -> State (BlockState backend) TExpr
  -- ^ a && b
andExpr :: Text -> TExpr -> TExpr -> State (BlockState backend) TExpr
andExpr Text
_ TExpr
T TExpr
bExpr = TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
bExpr
andExpr Text
_ TExpr
F TExpr
_     = TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
F
andExpr Text
_ TExpr
aExpr TExpr
T = TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
aExpr
andExpr Text
_ TExpr
_ TExpr
F     = TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
F
andExpr Text
nm TExpr
a TExpr
b = do
  Text
aIdent <- Identifier -> Text
Id.toText (Identifier -> Text)
-> StateT (BlockState backend) Identity Identifier
-> StateT (BlockState backend) Identity Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> TExpr -> StateT (BlockState backend) Identity Identifier
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) Identifier
toIdentifier' (Text
nm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_a") TExpr
a
  Text
bIdent <- Identifier -> Text
Id.toText (Identifier -> Text)
-> StateT (BlockState backend) Identity Identifier
-> StateT (BlockState backend) Identity Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> TExpr -> StateT (BlockState backend) Identity Identifier
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) Identifier
toIdentifier' (Text
nm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_b") TExpr
b
  -- This is somewhat hacky and relies on the fact that clash doesn't
  -- postprocess the text in Identifier. The alternative is to run
  -- this as a fully fledged @BlackBoxE@ but that involves a lot of
  -- faffing. It should be reasonably safe because we assign each side
  -- to an identifier if it isn't already.
  Text
andTxt <-
    LensLike' (Const HDL) (BlockState backend) backend
-> (backend -> HDL) -> StateT (BlockState backend) Identity HDL
forall s (m :: Type -> Type) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike' (Const HDL) (BlockState backend) backend
forall backend backend.
Lens (BlockState backend) (BlockState backend) backend backend
bsBackend backend -> HDL
forall state. Backend state => state -> HDL
hdlKind StateT (BlockState backend) Identity HDL
-> (HDL -> Text) -> StateT (BlockState backend) Identity Text
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
      HDL
VHDL          -> Text
aIdent Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bIdent
      HDL
Verilog       -> Text
aIdent Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" && " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bIdent
      HDL
SystemVerilog -> Text
aIdent Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" && " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bIdent
  Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
assign Text
nm (TExpr -> State (BlockState backend) TExpr)
-> TExpr -> State (BlockState backend) TExpr
forall a b. (a -> b) -> a -> b
$ HWType -> Expr -> TExpr
TExpr HWType
Bool (Identifier -> Maybe Modifier -> Expr
Identifier (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
andTxt) Maybe Modifier
forall a. Maybe a
Nothing)

-- | Massage a reset to work as active-high reset.
unsafeToActiveHigh
  :: Backend backend
  => Text
  -- ^ Name hint
  -> TExpr
  -- ^ Reset signal
  -> State (BlockState backend) TExpr
unsafeToActiveHigh :: Text -> TExpr -> State (BlockState backend) TExpr
unsafeToActiveHigh Text
nm TExpr
rExpr = do
  ResetPolarity
resetLevel <- VDomainConfiguration -> ResetPolarity
vResetPolarity (VDomainConfiguration -> ResetPolarity)
-> StateT (BlockState backend) Identity VDomainConfiguration
-> StateT (BlockState backend) Identity ResetPolarity
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> State backend VDomainConfiguration
-> StateT (BlockState backend) Identity VDomainConfiguration
forall backend a.
Backend backend =>
State backend a -> State (BlockState backend) a
liftToBlockState (HWType -> State backend VDomainConfiguration
forall backend.
(Backend backend, HasCallStack) =>
HWType -> State backend VDomainConfiguration
getDomainConf (TExpr -> HWType
ety TExpr
rExpr))
  case ResetPolarity
resetLevel of
    ResetPolarity
ActiveHigh -> TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
rExpr
    ResetPolarity
ActiveLow -> Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
notExpr Text
nm TExpr
rExpr

-- | Massage a reset to work as active-low reset.
unsafeToActiveLow
  :: Backend backend
  => Text
  -- ^ Name hint
  -> TExpr
  -- ^ Reset signal
  -> State (BlockState backend) TExpr
unsafeToActiveLow :: Text -> TExpr -> State (BlockState backend) TExpr
unsafeToActiveLow Text
nm TExpr
rExpr = do
  ResetPolarity
resetLevel <- VDomainConfiguration -> ResetPolarity
vResetPolarity (VDomainConfiguration -> ResetPolarity)
-> StateT (BlockState backend) Identity VDomainConfiguration
-> StateT (BlockState backend) Identity ResetPolarity
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> State backend VDomainConfiguration
-> StateT (BlockState backend) Identity VDomainConfiguration
forall backend a.
Backend backend =>
State backend a -> State (BlockState backend) a
liftToBlockState (HWType -> State backend VDomainConfiguration
forall backend.
(Backend backend, HasCallStack) =>
HWType -> State backend VDomainConfiguration
getDomainConf (TExpr -> HWType
ety TExpr
rExpr))
  case ResetPolarity
resetLevel of
    ResetPolarity
ActiveLow -> TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
rExpr
    ResetPolarity
ActiveHigh -> Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
notExpr Text
nm TExpr
rExpr

-- | Negate @(not)@ an expression, assigning it to a new identifier.
notExpr
  :: Backend backend
  => Text
  -- ^ name hint
  -> TExpr
  -- ^ a
  -> State (BlockState backend) TExpr
  -- ^ not a
notExpr :: Text -> TExpr -> State (BlockState backend) TExpr
notExpr Text
_ TExpr
T = TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
F
notExpr Text
_ TExpr
F = TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
T
notExpr Text
nm TExpr
aExpr = do
  Text
aIdent <- Identifier -> Text
Id.toText (Identifier -> Text)
-> StateT (BlockState backend) Identity Identifier
-> StateT (BlockState backend) Identity Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> TExpr -> StateT (BlockState backend) Identity Identifier
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) Identifier
toIdentifier' (Text
nm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_a") TExpr
aExpr
  -- See disclaimer in `andExpr` above.
  Text
notTxt <- LensLike' (Const HDL) (BlockState backend) backend
-> (backend -> HDL) -> StateT (BlockState backend) Identity HDL
forall s (m :: Type -> Type) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike' (Const HDL) (BlockState backend) backend
forall backend backend.
Lens (BlockState backend) (BlockState backend) backend backend
bsBackend backend -> HDL
forall state. Backend state => state -> HDL
hdlKind StateT (BlockState backend) Identity HDL
-> (HDL -> Text) -> StateT (BlockState backend) Identity Text
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    HDL
VHDL          -> Text
"not " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
aIdent
    HDL
Verilog       -> Text
"! " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
aIdent
    HDL
SystemVerilog -> Text
"! " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
aIdent
  Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
assign Text
nm (TExpr -> State (BlockState backend) TExpr)
-> TExpr -> State (BlockState backend) TExpr
forall a b. (a -> b) -> a -> b
$ HWType -> Expr -> TExpr
TExpr HWType
Bit (Identifier -> Maybe Modifier -> Expr
Identifier (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
notTxt) Maybe Modifier
forall a. Maybe a
Nothing)

-- | Creates a BV that produces the following vhdl:
--
-- @
--    (0 to n => ARG)
-- @
--
-- TODO: Implement for (System)Verilog
pureToBV
  :: Text
  -- ^ name hint
  -> Int
  -- ^ Size (n)
  -> TExpr
  -- ^ ARG
  -> State (BlockState VHDLState) TExpr
  -- ^ (0 to n => ARG)
pureToBV :: Text -> Int -> TExpr -> State (BlockState VHDLState) TExpr
pureToBV Text
nm Int
n TExpr
arg = do
  Text
arg' <- Identifier -> Text
Id.toText (Identifier -> Text)
-> StateT (BlockState VHDLState) Identity Identifier
-> StateT (BlockState VHDLState) Identity Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> TExpr -> StateT (BlockState VHDLState) Identity Identifier
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) Identifier
toIdentifier' Text
nm TExpr
arg
  -- This is very hard coded and hacky
  let text :: Text
text = Text
"(0 to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" => " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
arg' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  Text -> TExpr -> State (BlockState VHDLState) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
assign Text
nm (TExpr -> State (BlockState VHDLState) TExpr)
-> TExpr -> State (BlockState VHDLState) TExpr
forall a b. (a -> b) -> a -> b
$ HWType -> Expr -> TExpr
TExpr (Int -> HWType
BitVector (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) (Identifier -> Maybe Modifier -> Expr
Identifier (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
text) Maybe Modifier
forall a. Maybe a
Nothing)

-- | Creates a BV that produces the following vhdl:
--
-- @
--    std_logic_vector(resize(ARG, Size))
-- @
--
-- TODO: Implement for (System)Verilog
pureToBVResized
  :: Text
  -- ^ name hint
  -> Int
  -- ^ Size (n)
  -> TExpr
  -- ^ ARG
  -> State (BlockState VHDLState) TExpr
  -- ^ std_logic_vector(resize(ARG, Size))
pureToBVResized :: Text -> Int -> TExpr -> State (BlockState VHDLState) TExpr
pureToBVResized Text
nm Int
n TExpr
arg = do
  Text
arg' <- Identifier -> Text
Id.toText (Identifier -> Text)
-> StateT (BlockState VHDLState) Identity Identifier
-> StateT (BlockState VHDLState) Identity Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> TExpr -> StateT (BlockState VHDLState) Identity Identifier
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) Identifier
toIdentifier' Text
nm TExpr
arg
  -- This is very hard coded and hacky
  let text :: Text
text = Text
"std_logic_vector(resize(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
arg' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"))"
  Text -> TExpr -> State (BlockState VHDLState) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
assign Text
nm (TExpr -> State (BlockState VHDLState) TExpr)
-> TExpr -> State (BlockState VHDLState) TExpr
forall a b. (a -> b) -> a -> b
$ HWType -> Expr -> TExpr
TExpr (Int -> HWType
BitVector Int
n) (Identifier -> Maybe Modifier -> Expr
Identifier (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
text) Maybe Modifier
forall a. Maybe a
Nothing)

-- | Allows assignment of a port to be "open"
open
  :: Backend backend
  => HWType
  -> State (BlockState backend) TExpr
open :: HWType -> State (BlockState backend) TExpr
open HWType
hwType = TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TExpr -> State (BlockState backend) TExpr)
-> TExpr -> State (BlockState backend) TExpr
forall a b. (a -> b) -> a -> b
$ HWType -> Expr -> TExpr
TExpr HWType
hwType (Identifier -> Maybe Modifier -> Expr
Identifier (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"open") Maybe Modifier
forall a. Maybe a
Nothing)