{-|
  Copyright   :  (C) 2019, Myrtle Software Ltd.
                     2020-2022, QBayLogic B.V.
                     2021, Myrtle.ai
  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 LambdaCase        #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms   #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeApplications  #-}
{-# LANGUAGE ViewPatterns      #-}

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

  -- * Declarations
  , BlockState (..)
  , TExpr
  , declaration
  , declarationReturn
  , instDecl
  , instHO
  , viaAnnotatedSignal

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

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

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

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

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

import           Control.Lens                    hiding (Indexed, assign)
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.Backend                   hiding (fromBV, toBV)
import           Clash.Backend.VHDL              (VHDLState)
import           Clash.Core.Var                  (Attr')
import           Clash.Netlist.BlackBox.Util     (exprToString, 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           Data.String.Interpolate.Util    (unindent)
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{_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
InlinePrimitive [HDL]
bo_supportedHdls (String -> Primitive) -> String -> Primitive
forall a b. (a -> b) -> a -> b
$ String -> String
unindent [I.i|
  [ { "BlackBoxHaskell" :
      { "name" : "#{bb}"
      , "templateFunction" : "#{tf}"
      , "ignoredArguments" : #{show bo_ignoredArguments}
      , "multiResult" : #{toJsonBool bo_multiResult}
      }
    }
  ] |]
 where
  toJsonBool :: Bool -> String
  toJsonBool :: Bool -> String
toJsonBool Bool
True = String
"true"
  toJsonBool 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

-- | A typed expression.
data TExpr = TExpr
  { TExpr -> HWType
ety :: HWType
  , TExpr -> Expr
eex :: Expr
  } deriving Int -> TExpr -> String -> String
[TExpr] -> String -> String
TExpr -> String
(Int -> TExpr -> String -> String)
-> (TExpr -> String) -> ([TExpr] -> String -> String) -> Show TExpr
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [TExpr] -> String -> String
$cshowList :: [TExpr] -> String -> String
show :: TExpr -> String
$cshow :: TExpr -> String
showsPrec :: Int -> TExpr -> String -> String
$cshowsPrec :: Int -> TExpr -> String -> String
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) -> do
      let (Identifier Identifier
resultNm Maybe Modifier
Nothing, HWType
_) = (Expr, HWType)
rNm
      Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Identifier -> Expr -> Declaration
Assignment Identifier
resultNm (TExpr -> Expr
eex TExpr
r))

-- | 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) ()
s = do
  backend
backend0 <- StateT backend Identity backend
forall s (m :: Type -> Type). MonadState s m => m s
get
  let initState :: BlockState backend
initState = [Declaration] -> IntMap Int -> backend -> BlockState backend
forall backend.
[Declaration] -> IntMap Int -> backend -> BlockState backend
BlockState [] IntMap Int
forall a. IntMap a
IntMap.empty backend
backend0
      BlockState [Declaration]
decs IntMap Int
_hoCalls backend
backend1 = State (BlockState backend) ()
-> BlockState backend -> BlockState backend
forall s a. State s a -> s -> s
execState State (BlockState backend) ()
s BlockState backend
initState
  backend -> StateT backend Identity ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put backend
backend1
  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]
decs)

-- | 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
  -> WireOrReg
  -- ^ Should signal be declared as a wire or a reg
  -> HWType
  -- ^ Type of new signal
  -> State (BlockState backend) Identifier
  -- ^ Expression pointing the the new signal
declare' :: Text
-> WireOrReg -> HWType -> State (BlockState backend) Identifier
declare' Text
decName WireOrReg
wireOrReg 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
-> WireOrReg
-> Identifier
-> Either Text HWType
-> Maybe Expr
-> Declaration
NetDecl' Maybe Text
forall a. Maybe a
Nothing WireOrReg
wireOrReg Identifier
uniqueName (HWType -> Either Text HWType
forall a b. b -> Either a b
Right 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
  -> WireOrReg
  -- ^ Should signal be declared as a wire or a reg
  -> HWType
  -- ^ Type of new signal
  -> State (BlockState backend) TExpr
  -- ^ Expression pointing the the new signal
declare :: Text -> WireOrReg -> HWType -> State (BlockState backend) TExpr
declare Text
decName WireOrReg
wireOrReg HWType
ty = do
  Identifier
uniqueName <- Text
-> WireOrReg -> HWType -> State (BlockState backend) Identifier
forall backend.
Backend backend =>
Text
-> WireOrReg -> HWType -> State (BlockState backend) Identifier
declare' Text
decName WireOrReg
wireOrReg 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))

-- | 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
  -> 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
  texp :: TExpr
texp@(~(TExpr HWType
_ (Identifier Identifier
uniqueName Maybe Modifier
Nothing))) <- Text -> WireOrReg -> HWType -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> WireOrReg -> HWType -> State (BlockState backend) TExpr
declare Text
aName WireOrReg
Wire HWType
ty
  Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Identifier -> Expr -> Declaration
Assignment Identifier
uniqueName 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 HWType
_ (Identifier Identifier
vUniqueName Maybe Modifier
Nothing)) <- Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
toIdentifier Text
vName TExpr
v
  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 -> String -> String
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]
tys) (Identifier Identifier
resName Maybe Modifier
_)) [Text]
vals = do
  [TExpr]
newNames <- (Text -> HWType -> StateT (BlockState backend) Identity TExpr)
-> [Text] -> [HWType] -> State (BlockState backend) [TExpr]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM ((Text
 -> WireOrReg
 -> HWType
 -> StateT (BlockState backend) Identity TExpr)
-> WireOrReg
-> Text
-> HWType
-> StateT (BlockState backend) Identity TExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text
-> WireOrReg
-> HWType
-> StateT (BlockState backend) Identity TExpr
forall backend.
Backend backend =>
Text -> WireOrReg -> HWType -> State (BlockState backend) TExpr
declare WireOrReg
Wire) [Text]
vals [HWType]
tys
  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 -> Expr -> Declaration
Assignment Identifier
resName (Expr -> Declaration) -> Expr -> Declaration
forall a b. (a -> b) -> a -> b
$ HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
ty ((HWType, Int) -> Modifier
DC (HWType
ty, Int
0)) ((TExpr -> Expr) -> [TExpr] -> [Expr]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap TExpr -> Expr
eex [TExpr]
newNames)
  [TExpr] -> State (BlockState backend) [TExpr]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [TExpr]
newNames
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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
e String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
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
    texp :: TExpr
texp@(~(TExpr HWType
_ (Identifier Identifier
uniqueBitName Maybe Modifier
Nothing))) <- Text -> WireOrReg -> HWType -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> WireOrReg -> HWType -> State (BlockState backend) TExpr
declare Text
bitName WireOrReg
Wire HWType
Bit
    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))
        ]
    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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
tExpr String -> String -> String
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
    texp :: TExpr
texp@(~(TExpr HWType
_ (Identifier Identifier
uniqueBitName Maybe Modifier
Nothing))) <- Text -> WireOrReg -> HWType -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> WireOrReg -> HWType -> State (BlockState backend) TExpr
declare Text
bitName WireOrReg
Wire HWType
Bit
    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))
        ]
    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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
tExpr String -> String -> String
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
  :: Text
  -- ^ Name hint for intermediate signal
  -> TExpr
  -> State (BlockState VHDLState) TExpr
boolFromBit :: Text -> TExpr -> State (BlockState VHDLState) TExpr
boolFromBit = 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 HWType
Bit HWType
Bool (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = '1'")

-- | 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.
--
-- TODO: Implement for (System)Verilog
unsignedFromBitVector
  :: HasCallStack
  => Size
  -> Text
  -- ^ Name hint for intermediate signal
  -> TExpr
  -> State (BlockState VHDLState) TExpr
unsignedFromBitVector :: Int -> Text -> TExpr -> State (BlockState VHDLState) TExpr
unsignedFromBitVector 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) (Int -> HWType
Unsigned Int
n) (\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
")")

-- | 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 -> Expr -> Declaration
Assignment Identifier
outName 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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
texpr
                                  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" must be an Identifier with type " String -> String -> String
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 -> Expr -> Declaration
Assignment Identifier
outName 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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
texpr
  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" must be an Identifier with type " String -> String -> String
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 -> String -> String
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 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

-- | Assign an input bitvector to an expression. Declares a new
--   bitvector if the expression is not already a bitvector.
toBV
  :: Backend backend
  => Text
  -- ^ BitVector name hint
  -> TExpr
  -- ^ expression
  -> State (BlockState backend) TExpr
  -- ^ BitVector expression
toBV :: Text -> TExpr -> State (BlockState backend) TExpr
toBV Text
bvName TExpr
a = case TExpr
a of
  TExpr BitVector{} Expr
_ -> TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
a
  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 (Int -> HWType
BitVector (HWType -> Int
typeSize HWType
aTy)) (Maybe Identifier -> HWType -> Expr -> Expr
ToBv Maybe Identifier
forall a. Maybe a
Nothing HWType
aTy Expr
aExpr)

-- | Assign an output bitvector to an expression. Declares a new
--   bitvector if the expression is not already a bitvector.
fromBV
  :: (HasCallStack, Backend backend)
  => Text
  -- ^ BitVector name hint
  -> TExpr
  -- ^ expression
  -> State (BlockState backend) TExpr
  -- ^ bv expression
fromBV :: Text -> TExpr -> State (BlockState backend) TExpr
fromBV Text
_ a :: TExpr
a@(TExpr BitVector{} Expr
_) = TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
a
fromBV Text
bvName (TExpr HWType
aTy (Identifier Identifier
aName Maybe Modifier
Nothing)) = do
  Identifier
bvName' <- Text -> StateT (BlockState backend) Identity Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic Text
bvName
  let bvExpr :: Expr
bvExpr = Maybe Identifier -> HWType -> Expr -> Expr
FromBv Maybe Identifier
forall a. Maybe a
Nothing HWType
aTy (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
bvName' Maybe Modifier
forall a. Maybe a
Nothing)
      bvTy :: HWType
bvTy   = Int -> HWType
BitVector (HWType -> Int
typeSize HWType
aTy)
  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
bvName' HWType
bvTy)
  Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Identifier -> Expr -> Declaration
Assignment Identifier
aName Expr
bvExpr)
  TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HWType -> Expr -> TExpr
TExpr HWType
bvTy (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
bvName' Maybe Modifier
forall a. Maybe a
Nothing))
fromBV 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
"fromBV: the expression " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
texpr String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"must be an Identifier"

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 -> String -> String
[LitHDL] -> String -> String
LitHDL -> String
(Int -> LitHDL -> String -> String)
-> (LitHDL -> String)
-> ([LitHDL] -> String -> String)
-> Show LitHDL
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [LitHDL] -> String -> String
$cshowList :: [LitHDL] -> String -> String
show :: LitHDL -> String
$cshow :: LitHDL -> String
showsPrec :: Int -> LitHDL -> String -> String
$cshowsPrec :: Int -> LitHDL -> String -> String
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

    -- Create result identifier
    -- See https://github.com/clash-lang/clash-compiler/issues/919 for info on
    -- logic of 'resWireOrReg'
    resWireOrReg :: WireOrReg
resWireOrReg =
      case Int
-> IntMap
     [(Either BlackBox (Identifier, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext)]
-> Maybe
     [(Either BlackBox (Identifier, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext)]
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
fPos (BlackBoxContext
-> IntMap
     [(Either BlackBox (Identifier, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext)]
bbFunctions BlackBoxContext
bbCtx) of
        Just ((Either BlackBox (Identifier, [Declaration])
_,WireOrReg
rw,[BlackBoxTemplate]
_,[BlackBoxTemplate]
_,[((Text, Text), BlackBox)]
_,BlackBoxContext
_):[(Either BlackBox (Identifier, [Declaration]), WireOrReg,
  [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
  BlackBoxContext)]
_) -> WireOrReg
rw
        Maybe
  [(Either BlackBox (Identifier, [Declaration]), WireOrReg,
    [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
    BlackBoxContext)]
_ -> String -> WireOrReg
forall a. HasCallStack => String -> a
error String
"internal error"
  Identifier
resName <- Text
-> WireOrReg
-> HWType
-> StateT (BlockState backend) Identity Identifier
forall backend.
Backend backend =>
Text
-> WireOrReg -> 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") WireOrReg
resWireOrReg 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))

-- | 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, LitHDL)]
  -- ^ attributes
  -> [(Text, TExpr)]
  -- ^ in ports
  -> [(Text, TExpr)]
  -- ^ out ports
  -> State (BlockState backend) ()
instDecl :: EntityOrComponent
-> Identifier
-> Identifier
-> [(Text, LitHDL)]
-> [(Text, TExpr)]
-> [(Text, TExpr)]
-> State (BlockState backend) ()
instDecl EntityOrComponent
entOrComp Identifier
compName Identifier
instLbl [(Text, LitHDL)]
attrs [(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']
-> Identifier
-> Identifier
-> [(Expr, HWType, Expr)]
-> PortMap
-> Declaration
InstDecl
      EntityOrComponent
entOrComp Maybe Text
forall a. Maybe a
Nothing [] Identifier
compName Identifier
instLbl ([(Text, LitHDL)] -> [(Expr, HWType, Expr)]
mkAttrs [(Text, LitHDL)]
attrs)
      ([(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 attributes to the form clash wants
    mkAttrs :: [(Text.Text, LitHDL)] -> [(Expr, HWType, Expr)]
    mkAttrs :: [(Text, LitHDL)] -> [(Expr, HWType, Expr)]
mkAttrs = ((Text, LitHDL) -> (Expr, HWType, Expr))
-> [(Text, LitHDL)] -> [(Expr, HWType, Expr)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
s, LitHDL
ty) -> ( Identifier -> Maybe Modifier -> Expr
Identifier (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
s) Maybe Modifier
forall a. Maybe a
Nothing
                               , LitHDL -> HWType
hdlTy LitHDL
ty, LitHDL -> Expr
litExpr LitHDL
ty) )

    litExpr :: LitHDL -> Expr
    litExpr :: LitHDL -> Expr
litExpr (B Bool
b) = Maybe (HWType, Int) -> Literal -> Expr
Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (Bool -> Literal
BoolLit Bool
b)
    litExpr (S String
s) = Maybe (HWType, Int) -> Literal -> Expr
Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (String -> Literal
StringLit String
s)
    litExpr (I Integer
i) = Maybe (HWType, Int) -> Literal -> Expr
Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (Integer -> Literal
NumLit Integer
i)

    hdlTy :: LitHDL -> HWType
    hdlTy :: LitHDL -> HWType
hdlTy = \case
      B{} -> HWType
Bool
      S{} -> HWType
String
      I{} -> HWType
Integer

-- | 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']
  -- ^ the attributes to annotate the signal with
  -> State (BlockState backend) ()
viaAnnotatedSignal :: Identifier
-> TExpr -> TExpr -> [Attr'] -> State (BlockState backend) ()
viaAnnotatedSignal Identifier
sigNm (TExpr HWType
fromTy Expr
fromExpr) (TExpr HWType
toTy (Identifier Identifier
outNm Maybe Modifier
Nothing)) [Attr']
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'] -> HWType -> HWType
Annotated [Attr']
attrs HWType
fromTy))
      Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Identifier -> Expr -> Declaration
Assignment Identifier
sigNm Expr
fromExpr)
      Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Identifier -> Expr -> Declaration
Assignment Identifier
outNm (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']
_ =
  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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
inTExpr String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
  String
"\" and \"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
outTExpr String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" have non-matching types."
viaAnnotatedSignal Identifier
_ TExpr
_ TExpr
outTExpr [Attr']
_ =
  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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
outTExpr String -> String -> String
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 HWType
_ (Identifier Identifier
nm' Maybe Modifier
Nothing)) <- Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
assign Text
nm TExpr
texp
  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)

-- | 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)