{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
#if !MIN_VERSION_ghc(8,8,0)
{-# LANGUAGE MonadFailDesugaring #-}
#endif
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Clash.Netlist.Util where
import Data.Coerce (coerce)
import Control.Exception (throw)
import Control.Lens ((.=), (%=))
import qualified Control.Lens as Lens
import Control.Monad (when, zipWithM)
import Control.Monad.Extra (concatMapM)
import Control.Monad.Reader (ask, local)
import qualified Control.Monad.State as State
import Control.Monad.State.Strict
(State, evalState, get, modify, runState)
import Control.Monad.Trans.Except
(ExceptT (..), runExcept, runExceptT, throwE)
import Data.Bifunctor (second)
import Data.Either (partitionEithers)
import Data.Foldable (Foldable(toList))
import Data.Functor (($>))
import Data.Hashable (Hashable)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.IntSet as IntSet
import Control.Applicative (Alternative((<|>)))
import Data.List (unzip4, partition)
import qualified Data.List as List
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe
(catMaybes, fromMaybe, isNothing, mapMaybe, isJust, listToMaybe, maybeToList)
import Text.Printf (printf)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Extra (showt)
import Data.Text.Lazy (toStrict)
import Data.Text.Prettyprint.Doc.Extra
import GHC.Stack (HasCallStack)
#if MIN_VERSION_ghc(9,0,0)
import GHC.Utils.Monad (zipWith3M)
import GHC.Utils.Outputable (ppr, showSDocUnsafe)
#else
import MonadUtils (zipWith3M)
import Outputable (ppr, showSDocUnsafe)
#endif
import Clash.Annotations.TopEntity
(TopEntity(..), PortName(..), defSyn)
import Clash.Annotations.BitRepresentation.ClashLib
(coreToType')
import Clash.Annotations.BitRepresentation.Internal
(CustomReprs, ConstrRepr'(..), DataRepr'(..), getDataRepr,
uncheckedGetConstrRepr)
import Clash.Annotations.SynthesisAttributes (Attr)
import Clash.Annotations.Primitive (HDL(VHDL))
import Clash.Backend (HasUsageMap (..), HWKind(..), hdlHWTypeKind, hdlKind)
import Clash.Core.DataCon (DataCon (..))
import Clash.Core.EqSolver (typeEq)
import Clash.Core.FreeVars (typeFreeVars, typeFreeVars')
import Clash.Core.HasFreeVars (elemFreeVars)
import Clash.Core.HasType
import qualified Clash.Core.Literal as C
import Clash.Core.Name
(Name (..), appendToName, nameOcc)
import Clash.Core.Pretty (showPpr)
import Clash.Core.Subst
(Subst (..), extendIdSubst, extendIdSubstList, extendInScopeId,
extendInScopeIdList, mkSubst, substTm)
import Clash.Core.Term
(primMultiResult, MultiPrimInfo(..), Alt, LetBinding, Pat (..), Term (..), TickInfo (..), NameMod (..),
IsMultiPrim (..), collectArgsTicks, collectTicks, collectBndrs, PrimInfo(primName), mkTicks, stripTicks)
import Clash.Core.TermInfo
import Clash.Core.TyCon
(TyCon (FunTyCon), TyConName, TyConMap, tyConDataCons)
import Clash.Core.Type
(Type (..), TyVar, TypeView (..), coreView1, normalizeType, splitTyConAppM, tyView)
import Clash.Core.Util
(substArgTys, tyLitShow)
import Clash.Core.Var
(Id, Var (..), mkLocalId, modifyVarName)
import Clash.Core.VarEnv
(InScopeSet, extendInScopeSetList, uniqAway, lookupVarEnv)
import qualified Clash.Data.UniqMap as UniqMap
import {-# SOURCE #-} Clash.Netlist.BlackBox
import {-# SOURCE #-} Clash.Netlist.BlackBox.Util
import Clash.Netlist.BlackBox.Types
(bbResultNames, BlackBoxMeta(BlackBoxMeta))
import qualified Clash.Netlist.Id as Id
import Clash.Netlist.Types as HW
import Clash.Primitives.Types
import Clash.Util
import qualified Clash.Util.Interpolate as I
hmFindWithDefault :: (Eq k, Hashable k) => v -> k -> HashMap k v -> v
#if MIN_VERSION_unordered_containers(0,2,11)
hmFindWithDefault :: v -> k -> HashMap k v -> v
hmFindWithDefault = v -> k -> HashMap k v -> v
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
HashMap.findWithDefault
#else
hmFindWithDefault = HashMap.lookupDefault
#endif
instPort :: Text -> Expr
instPort :: Text -> Expr
instPort Text
pn = Identifier -> Maybe Modifier -> Expr
Identifier (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
pn) Maybe Modifier
forall a. Maybe a
Nothing
stripFiltered :: FilteredHWType -> HWType
stripFiltered :: FilteredHWType -> HWType
stripFiltered (FilteredHWType HWType
hwty [[(IsVoid, FilteredHWType)]]
_filtered) = HWType
hwty
stripVoid :: HWType -> HWType
stripVoid :: HWType -> HWType
stripVoid (Void (Just HWType
e)) = HWType -> HWType
stripVoid HWType
e
stripVoid HWType
e = HWType
e
flattenFiltered :: FilteredHWType -> [[Bool]]
flattenFiltered :: FilteredHWType -> [[IsVoid]]
flattenFiltered (FilteredHWType HWType
_hwty [[(IsVoid, FilteredHWType)]]
filtered) = ([(IsVoid, FilteredHWType)] -> [IsVoid])
-> [[(IsVoid, FilteredHWType)]] -> [[IsVoid]]
forall a b. (a -> b) -> [a] -> [b]
map (((IsVoid, FilteredHWType) -> IsVoid)
-> [(IsVoid, FilteredHWType)] -> [IsVoid]
forall a b. (a -> b) -> [a] -> [b]
map (IsVoid, FilteredHWType) -> IsVoid
forall a b. (a, b) -> a
fst) [[(IsVoid, FilteredHWType)]]
filtered
isVoidMaybe :: Bool -> Maybe HWType -> Bool
isVoidMaybe :: IsVoid -> Maybe HWType -> IsVoid
isVoidMaybe IsVoid
dflt Maybe HWType
Nothing = IsVoid
dflt
isVoidMaybe IsVoid
_dflt (Just HWType
t) = HWType -> IsVoid
isVoid HWType
t
isVoid :: HWType -> Bool
isVoid :: HWType -> IsVoid
isVoid Void {} = IsVoid
True
isVoid HWType
_ = IsVoid
False
isFilteredVoid :: FilteredHWType -> Bool
isFilteredVoid :: FilteredHWType -> IsVoid
isFilteredVoid = HWType -> IsVoid
isVoid (HWType -> IsVoid)
-> (FilteredHWType -> HWType) -> FilteredHWType -> IsVoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilteredHWType -> HWType
stripFiltered
squashLets :: Term -> Term
squashLets :: Term -> Term
squashLets (Letrec [LetBinding]
xs (Letrec [LetBinding]
ys Term
e)) =
Term -> Term
squashLets ([LetBinding] -> Term -> Term
Letrec ([LetBinding]
xs [LetBinding] -> [LetBinding] -> [LetBinding]
forall a. Semigroup a => a -> a -> a
<> [LetBinding]
ys) Term
e)
squashLets Term
e = Term
e
splitNormalized
:: TyConMap
-> Term
-> (Either String ([Id],[LetBinding],Id))
splitNormalized :: TyConMap -> Term -> Either String ([Id], [LetBinding], Id)
splitNormalized TyConMap
tcm Term
expr = case Term -> ([Either Id TyVar], Term)
collectBndrs Term
expr of
([Either Id TyVar]
args, Term -> (Term, [TickInfo])
collectTicks -> (Term -> Term
squashLets -> Letrec [LetBinding]
xes Term
e, [TickInfo]
ticks))
| ([Id]
tmArgs,[]) <- [Either Id TyVar] -> ([Id], [TyVar])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Id TyVar]
args -> case Term -> Term
stripTicks Term
e of
Var Id
v -> ([Id], [LetBinding], Id) -> Either String ([Id], [LetBinding], Id)
forall a b. b -> Either a b
Right ([Id]
tmArgs, (LetBinding -> LetBinding) -> [LetBinding] -> [LetBinding]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Term -> Term) -> LetBinding -> LetBinding
forall (p :: Type -> Type -> Type) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks)) [LetBinding]
xes,Id
v)
Term
t -> String -> Either String ([Id], [LetBinding], Id)
forall a b. a -> Either a b
Left ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Not in normal form: res not simple var: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
t)
| IsVoid
otherwise -> String -> Either String ([Id], [LetBinding], Id)
forall a b. a -> Either a b
Left ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Not in normal form: tyArgs")
([Either Id TyVar], Term)
_ ->
String -> Either String ([Id], [LetBinding], Id)
forall a b. a -> Either a b
Left ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Not in normal form: no Letrec:\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
expr String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"\n\nWhich has type:\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall p. PrettyPrec p => p -> String
showPpr Type
ty)
where
ty :: Type
ty = TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
expr
unsafeCoreTypeToHWType
:: SrcSpan
-> String
-> (CustomReprs -> TyConMap -> Type ->
State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> State HWMap FilteredHWType
unsafeCoreTypeToHWType :: SrcSpan
-> String
-> (CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> State HWMap FilteredHWType
unsafeCoreTypeToHWType SrcSpan
sp String
loc CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m Type
ty =
(String -> FilteredHWType)
-> (FilteredHWType -> FilteredHWType)
-> Either String FilteredHWType
-> FilteredHWType
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\String
msg -> ClashException -> FilteredHWType
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp (String
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg) Maybe String
forall a. Maybe a
Nothing)) FilteredHWType -> FilteredHWType
forall a. a -> a
id (Either String FilteredHWType -> FilteredHWType)
-> StateT HWMap Identity (Either String FilteredHWType)
-> State HWMap FilteredHWType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
(CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> StateT HWMap Identity (Either String FilteredHWType)
coreTypeToHWType CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m Type
ty
unsafeCoreTypeToHWTypeM'
:: String
-> Type
-> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' :: String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' String
loc Type
ty =
FilteredHWType -> HWType
stripFiltered (FilteredHWType -> HWType)
-> NetlistMonad FilteredHWType -> NetlistMonad HWType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Type -> NetlistMonad FilteredHWType
unsafeCoreTypeToHWTypeM String
loc Type
ty
unsafeCoreTypeToHWTypeM
:: String
-> Type
-> NetlistMonad FilteredHWType
unsafeCoreTypeToHWTypeM :: String -> Type -> NetlistMonad FilteredHWType
unsafeCoreTypeToHWTypeM String
loc Type
ty = do
(Identifier
_,SrcSpan
cmpNm) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
tt <- Getting
(CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
NetlistState
(CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
-> NetlistMonad
(CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
(CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
NetlistState
(CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
Lens'
NetlistState
(CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
typeTranslator
CustomReprs
reprs <- Getting CustomReprs NetlistEnv CustomReprs
-> NetlistMonad CustomReprs
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting CustomReprs NetlistEnv CustomReprs
Getter NetlistEnv CustomReprs
customReprs
TyConMap
tcm <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
HWMap
htm0 <- Getting HWMap NetlistState HWMap -> NetlistMonad HWMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting HWMap NetlistState HWMap
Lens' NetlistState HWMap
htyCache
let (FilteredHWType
hty,HWMap
htm1) = State HWMap FilteredHWType -> HWMap -> (FilteredHWType, HWMap)
forall s a. State s a -> s -> (a, s)
runState (SrcSpan
-> String
-> (CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> State HWMap FilteredHWType
unsafeCoreTypeToHWType SrcSpan
cmpNm String
loc CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
tt CustomReprs
reprs TyConMap
tcm Type
ty) HWMap
htm0
(HWMap -> Identity HWMap) -> NetlistState -> Identity NetlistState
Lens' NetlistState HWMap
htyCache ((HWMap -> Identity HWMap)
-> NetlistState -> Identity NetlistState)
-> HWMap -> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
Lens..= HWMap
htm1
FilteredHWType -> NetlistMonad FilteredHWType
forall (m :: Type -> Type) a. Monad m => a -> m a
return FilteredHWType
hty
coreTypeToHWTypeM'
:: Type
-> NetlistMonad (Maybe HWType)
coreTypeToHWTypeM' :: Type -> NetlistMonad (Maybe HWType)
coreTypeToHWTypeM' Type
ty =
(FilteredHWType -> HWType) -> Maybe FilteredHWType -> Maybe HWType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap FilteredHWType -> HWType
stripFiltered (Maybe FilteredHWType -> Maybe HWType)
-> NetlistMonad (Maybe FilteredHWType)
-> NetlistMonad (Maybe HWType)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> NetlistMonad (Maybe FilteredHWType)
coreTypeToHWTypeM Type
ty
coreTypeToHWTypeM
:: Type
-> NetlistMonad (Maybe FilteredHWType)
coreTypeToHWTypeM :: Type -> NetlistMonad (Maybe FilteredHWType)
coreTypeToHWTypeM Type
ty = do
CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
tt <- Getting
(CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
NetlistState
(CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
-> NetlistMonad
(CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
(CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
NetlistState
(CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
Lens'
NetlistState
(CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
typeTranslator
CustomReprs
reprs <- Getting CustomReprs NetlistEnv CustomReprs
-> NetlistMonad CustomReprs
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting CustomReprs NetlistEnv CustomReprs
Getter NetlistEnv CustomReprs
customReprs
TyConMap
tcm <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
HWMap
htm0 <- Getting HWMap NetlistState HWMap -> NetlistMonad HWMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting HWMap NetlistState HWMap
Lens' NetlistState HWMap
htyCache
let (Either String FilteredHWType
hty,HWMap
htm1) = StateT HWMap Identity (Either String FilteredHWType)
-> HWMap -> (Either String FilteredHWType, HWMap)
forall s a. State s a -> s -> (a, s)
runState ((CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> StateT HWMap Identity (Either String FilteredHWType)
coreTypeToHWType CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
tt CustomReprs
reprs TyConMap
tcm Type
ty) HWMap
htm0
(HWMap -> Identity HWMap) -> NetlistState -> Identity NetlistState
Lens' NetlistState HWMap
htyCache ((HWMap -> Identity HWMap)
-> NetlistState -> Identity NetlistState)
-> HWMap -> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
Lens..= HWMap
htm1
Maybe FilteredHWType -> NetlistMonad (Maybe FilteredHWType)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((String -> Maybe FilteredHWType)
-> (FilteredHWType -> Maybe FilteredHWType)
-> Either String FilteredHWType
-> Maybe FilteredHWType
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe FilteredHWType -> String -> Maybe FilteredHWType
forall a b. a -> b -> a
const Maybe FilteredHWType
forall a. Maybe a
Nothing) FilteredHWType -> Maybe FilteredHWType
forall a. a -> Maybe a
Just Either String FilteredHWType
hty)
unexpectedProjectionErrorMsg
:: DataRepr'
-> Int
-> Int
-> String
unexpectedProjectionErrorMsg :: DataRepr' -> Int -> Int -> String
unexpectedProjectionErrorMsg DataRepr'
dataRepr Int
cI Int
fI =
String
"Unexpected projection of zero-width type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type' -> String
forall a. Show a => a -> String
show (DataRepr' -> Type'
drType DataRepr'
dataRepr)
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". Tried to make a projection of field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
fI String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" of "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
constrNm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". Did you try to project a field marked as zero-width"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" by a custom bit representation annotation?"
where
constrNm :: String
constrNm = Text -> String
forall a. Show a => a -> String
show (ConstrRepr' -> Text
crName (DataRepr' -> [ConstrRepr']
drConstrs DataRepr'
dataRepr [ConstrRepr'] -> Int -> ConstrRepr'
forall a. [a] -> Int -> a
!! Int
cI))
convertToCustomRepr
:: HasCallStack
=> CustomReprs
-> DataRepr'
-> HWType
-> HWType
convertToCustomRepr :: CustomReprs -> DataRepr' -> HWType -> HWType
convertToCustomRepr CustomReprs
reprs dRepr :: DataRepr'
dRepr@(DataRepr' Type'
name' Int
size [ConstrRepr']
constrs) HWType
hwTy =
if [ConstrRepr'] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [ConstrRepr']
constrs Int -> Int -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Int
nConstrs then
if Int
size Int -> Int -> IsVoid
forall a. Ord a => a -> a -> IsVoid
<= Int
0 then
Maybe HWType -> HWType
Void (HWType -> Maybe HWType
forall a. a -> Maybe a
Just HWType
cs)
else
HWType
cs
else
String -> HWType
forall a. HasCallStack => String -> a
error ([String] -> String
unwords
[ String
"Type", Type' -> String
forall a. Show a => a -> String
show Type'
name', String
"has", Int -> String
forall a. Show a => a -> String
show Int
nConstrs, String
"constructor(s), "
, String
"but the custom bit representation only specified", Int -> String
forall a. Show a => a -> String
show ([ConstrRepr'] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [ConstrRepr']
constrs)
, String
"constructors."
])
where
cs :: HWType
cs = HWType -> HWType
insertVoids (HWType -> HWType) -> HWType -> HWType
forall a b. (a -> b) -> a -> b
$ case HWType
hwTy of
Sum Text
name [Text]
conIds ->
Text -> DataRepr' -> Int -> [(ConstrRepr', Text)] -> HWType
CustomSum Text
name DataRepr'
dRepr Int
size ((Text -> (ConstrRepr', Text)) -> [Text] -> [(ConstrRepr', Text)]
forall a b. (a -> b) -> [a] -> [b]
map Text -> (ConstrRepr', Text)
packSum [Text]
conIds)
SP Text
name [(Text, [HWType])]
conIdsAndFieldTys ->
Text
-> DataRepr' -> Int -> [(ConstrRepr', Text, [HWType])] -> HWType
CustomSP Text
name DataRepr'
dRepr Int
size (((Text, [HWType]) -> (ConstrRepr', Text, [HWType]))
-> [(Text, [HWType])] -> [(ConstrRepr', Text, [HWType])]
forall a b. (a -> b) -> [a] -> [b]
map (Text, [HWType]) -> (ConstrRepr', Text, [HWType])
forall c. (Text, c) -> (ConstrRepr', Text, c)
packSP [(Text, [HWType])]
conIdsAndFieldTys)
Product Text
name Maybe [Text]
maybeFieldNames [HWType]
fieldTys
| [ConstrRepr' Text
_cName Int
_pos BitMask
_mask BitMask
_val [BitMask]
fieldAnns] <- [ConstrRepr']
constrs ->
Text
-> DataRepr'
-> Int
-> Maybe [Text]
-> [(BitMask, HWType)]
-> HWType
CustomProduct Text
name DataRepr'
dRepr Int
size Maybe [Text]
maybeFieldNames ([BitMask] -> [HWType] -> [(BitMask, HWType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [BitMask]
fieldAnns [HWType]
fieldTys)
HWType
_ ->
String -> HWType
forall a. HasCallStack => String -> a
error
( String
"Found a custom bit representation annotation " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DataRepr' -> String
forall a. Show a => a -> String
show DataRepr'
dRepr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"but it was applied to an unsupported HWType: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ HWType -> String
forall a. Show a => a -> String
show HWType
hwTy String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".")
nConstrs :: Int
nConstrs :: Int
nConstrs = case HWType
hwTy of
(Sum Text
_name [Text]
conIds) -> [Text] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Text]
conIds
(SP Text
_name [(Text, [HWType])]
conIdsAndFieldTys) -> [(Text, [HWType])] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [(Text, [HWType])]
conIdsAndFieldTys
(Product {}) -> Int
1
HWType
_ -> String -> Int
forall a. HasCallStack => String -> a
error (String
"Unexpected HWType: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ HWType -> String
forall a. Show a => a -> String
show HWType
hwTy)
packSP :: (Text, c) -> (ConstrRepr', Text, c)
packSP (Text
name, c
tys) = (HasCallStack => Text -> CustomReprs -> ConstrRepr'
Text -> CustomReprs -> ConstrRepr'
uncheckedGetConstrRepr Text
name CustomReprs
reprs, Text
name, c
tys)
packSum :: Text -> (ConstrRepr', Text)
packSum Text
name = (HasCallStack => Text -> CustomReprs -> ConstrRepr'
Text -> CustomReprs -> ConstrRepr'
uncheckedGetConstrRepr Text
name CustomReprs
reprs, Text
name)
insertVoids :: HWType -> HWType
insertVoids :: HWType -> HWType
insertVoids (CustomSP Text
i DataRepr'
d Int
s [(ConstrRepr', Text, [HWType])]
constrs0) =
Text
-> DataRepr' -> Int -> [(ConstrRepr', Text, [HWType])] -> HWType
CustomSP Text
i DataRepr'
d Int
s (((ConstrRepr', Text, [HWType]) -> (ConstrRepr', Text, [HWType]))
-> [(ConstrRepr', Text, [HWType])]
-> [(ConstrRepr', Text, [HWType])]
forall a b. (a -> b) -> [a] -> [b]
map (ConstrRepr', Text, [HWType]) -> (ConstrRepr', Text, [HWType])
forall b. (ConstrRepr', b, [HWType]) -> (ConstrRepr', b, [HWType])
go0 [(ConstrRepr', Text, [HWType])]
constrs0)
where
go0 :: (ConstrRepr', b, [HWType]) -> (ConstrRepr', b, [HWType])
go0 (con :: ConstrRepr'
con@(ConstrRepr' Text
_ Int
_ BitMask
_ BitMask
_ [BitMask]
fieldAnns), b
i0, [HWType]
hwTys) =
(ConstrRepr'
con, b
i0, (BitMask -> HWType -> HWType) -> [BitMask] -> [HWType] -> [HWType]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith BitMask -> HWType -> HWType
forall a. (Eq a, Num a) => a -> HWType -> HWType
go1 [BitMask]
fieldAnns [HWType]
hwTys)
go1 :: a -> HWType -> HWType
go1 a
0 HWType
hwTy0 = Maybe HWType -> HWType
Void (HWType -> Maybe HWType
forall a. a -> Maybe a
Just HWType
hwTy0)
go1 a
_ HWType
hwTy0 = HWType
hwTy0
insertVoids (CustomProduct Text
i DataRepr'
d Int
s Maybe [Text]
f [(BitMask, HWType)]
fieldAnns) =
Text
-> DataRepr'
-> Int
-> Maybe [Text]
-> [(BitMask, HWType)]
-> HWType
CustomProduct Text
i DataRepr'
d Int
s Maybe [Text]
f (((BitMask, HWType) -> (BitMask, HWType))
-> [(BitMask, HWType)] -> [(BitMask, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (BitMask, HWType) -> (BitMask, HWType)
forall a. (Eq a, Num a) => (a, HWType) -> (a, HWType)
go [(BitMask, HWType)]
fieldAnns)
where
go :: (a, HWType) -> (a, HWType)
go (a
0, HWType
hwTy0) = (a
0, Maybe HWType -> HWType
Void (HWType -> Maybe HWType
forall a. a -> Maybe a
Just HWType
hwTy0))
go (a
n, HWType
hwTy0) = (a
n, HWType
hwTy0)
insertVoids HWType
hwTy0 = HWType
hwTy0
maybeConvertToCustomRepr
:: CustomReprs
-> Type
-> FilteredHWType
-> FilteredHWType
maybeConvertToCustomRepr :: CustomReprs -> Type -> FilteredHWType -> FilteredHWType
maybeConvertToCustomRepr CustomReprs
reprs (Type -> Either String Type'
coreToType' -> Right Type'
tyName) (FilteredHWType HWType
hwTy [[(IsVoid, FilteredHWType)]]
filtered)
| Just DataRepr'
dRepr <- Type' -> CustomReprs -> Maybe DataRepr'
getDataRepr Type'
tyName CustomReprs
reprs =
HWType -> [[(IsVoid, FilteredHWType)]] -> FilteredHWType
FilteredHWType
(HasCallStack => CustomReprs -> DataRepr' -> HWType -> HWType
CustomReprs -> DataRepr' -> HWType -> HWType
convertToCustomRepr CustomReprs
reprs DataRepr'
dRepr HWType
hwTy)
[ [ (BitMask
fieldAnn BitMask -> BitMask -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== BitMask
0, FilteredHWType
hwty) | ((IsVoid
_, FilteredHWType
hwty), BitMask
fieldAnn) <- [(IsVoid, FilteredHWType)]
-> [BitMask] -> [((IsVoid, FilteredHWType), BitMask)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(IsVoid, FilteredHWType)]
fields (ConstrRepr' -> [BitMask]
crFieldAnns ConstrRepr'
constr) ]
| ([(IsVoid, FilteredHWType)]
fields, ConstrRepr'
constr) <- [[(IsVoid, FilteredHWType)]]
-> [ConstrRepr'] -> [([(IsVoid, FilteredHWType)], ConstrRepr')]
forall a b. [a] -> [b] -> [(a, b)]
zip [[(IsVoid, FilteredHWType)]]
filtered (DataRepr' -> [ConstrRepr']
drConstrs DataRepr'
dRepr)]
maybeConvertToCustomRepr CustomReprs
_reprs Type
_ty FilteredHWType
hwTy = FilteredHWType
hwTy
coreTypeToHWType'
:: (CustomReprs -> TyConMap -> Type ->
State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> State HWMap (Either String HWType)
coreTypeToHWType' :: (CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> State HWMap (Either String HWType)
coreTypeToHWType' CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m Type
ty =
(FilteredHWType -> HWType)
-> Either String FilteredHWType -> Either String HWType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap FilteredHWType -> HWType
stripFiltered (Either String FilteredHWType -> Either String HWType)
-> StateT HWMap Identity (Either String FilteredHWType)
-> State HWMap (Either String HWType)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> StateT HWMap Identity (Either String FilteredHWType)
coreTypeToHWType CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m Type
ty
coreTypeToHWType
:: (CustomReprs -> TyConMap -> Type ->
State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> State HWMap (Either String FilteredHWType)
coreTypeToHWType :: (CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> StateT HWMap Identity (Either String FilteredHWType)
coreTypeToHWType CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m Type
ty = do
Maybe (Either String FilteredHWType)
htyM <- Type -> HWMap -> Maybe (Either String FilteredHWType)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Type
ty (HWMap -> Maybe (Either String FilteredHWType))
-> StateT HWMap Identity HWMap
-> State HWMap (Maybe (Either String FilteredHWType))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT HWMap Identity HWMap
forall s (m :: Type -> Type). MonadState s m => m s
get
case Maybe (Either String FilteredHWType)
htyM of
Just Either String FilteredHWType
hty -> Either String FilteredHWType
-> StateT HWMap Identity (Either String FilteredHWType)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Either String FilteredHWType
hty
Maybe (Either String FilteredHWType)
_ -> do
Maybe (Either String FilteredHWType)
hty0M <- CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m Type
ty
Either String FilteredHWType
hty1 <- Maybe (Either String FilteredHWType)
-> Type -> StateT HWMap Identity (Either String FilteredHWType)
go Maybe (Either String FilteredHWType)
hty0M Type
ty
(HWMap -> HWMap) -> StateT HWMap Identity ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify (Type -> Either String FilteredHWType -> HWMap -> HWMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Type
ty Either String FilteredHWType
hty1)
Either String FilteredHWType
-> StateT HWMap Identity (Either String FilteredHWType)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Either String FilteredHWType
hty1
where
go :: Maybe (Either String FilteredHWType)
-> Type
-> State (Map Type (Either String FilteredHWType))
(Either String FilteredHWType)
go :: Maybe (Either String FilteredHWType)
-> Type -> StateT HWMap Identity (Either String FilteredHWType)
go (Just Either String FilteredHWType
hwtyE) Type
_ = Either String FilteredHWType
-> StateT HWMap Identity (Either String FilteredHWType)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either String FilteredHWType
-> StateT HWMap Identity (Either String FilteredHWType))
-> Either String FilteredHWType
-> StateT HWMap Identity (Either String FilteredHWType)
forall a b. (a -> b) -> a -> b
$ CustomReprs -> Type -> FilteredHWType -> FilteredHWType
maybeConvertToCustomRepr CustomReprs
reprs Type
ty (FilteredHWType -> FilteredHWType)
-> Either String FilteredHWType -> Either String FilteredHWType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Either String FilteredHWType
hwtyE
go Maybe (Either String FilteredHWType)
_ (TyConMap -> Type -> Maybe Type
coreView1 TyConMap
m -> Just Type
ty') =
(CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> StateT HWMap Identity (Either String FilteredHWType)
coreTypeToHWType CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m Type
ty'
go Maybe (Either String FilteredHWType)
_ (Type -> TypeView
tyView -> TyConApp TyConName
tc [Type]
args) = ExceptT String (State HWMap) FilteredHWType
-> StateT HWMap Identity (Either String FilteredHWType)
forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String (State HWMap) FilteredHWType
-> StateT HWMap Identity (Either String FilteredHWType))
-> ExceptT String (State HWMap) FilteredHWType
-> StateT HWMap Identity (Either String FilteredHWType)
forall a b. (a -> b) -> a -> b
$ do
FilteredHWType
hwty <- (CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> String
-> TyConName
-> [Type]
-> ExceptT String (State HWMap) FilteredHWType
mkADT CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m (Type -> String
forall p. PrettyPrec p => p -> String
showPpr Type
ty) TyConName
tc [Type]
args
FilteredHWType -> ExceptT String (State HWMap) FilteredHWType
forall (m :: Type -> Type) a. Monad m => a -> m a
return (CustomReprs -> Type -> FilteredHWType -> FilteredHWType
maybeConvertToCustomRepr CustomReprs
reprs Type
ty FilteredHWType
hwty)
go Maybe (Either String FilteredHWType)
_ Type
_ = Either String FilteredHWType
-> StateT HWMap Identity (Either String FilteredHWType)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Either String FilteredHWType
-> StateT HWMap Identity (Either String FilteredHWType))
-> Either String FilteredHWType
-> StateT HWMap Identity (Either String FilteredHWType)
forall a b. (a -> b) -> a -> b
$ String -> Either String FilteredHWType
forall a b. a -> Either a b
Left (String -> Either String FilteredHWType)
-> String -> Either String FilteredHWType
forall a b. (a -> b) -> a -> b
$ String
"Can't translate non-tycon type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall p. PrettyPrec p => p -> String
showPpr Type
ty
originalIndices
:: [Bool]
-> [Int]
originalIndices :: [IsVoid] -> [Int]
originalIndices [IsVoid]
wereVoids =
[Int
i | (Int
i, IsVoid
void) <- [Int] -> [IsVoid] -> [(Int, IsVoid)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [IsVoid]
wereVoids, IsVoid -> IsVoid
not IsVoid
void]
mkADT
:: (CustomReprs -> TyConMap -> Type ->
State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> String
-> TyConName
-> [Type]
-> ExceptT String (State HWMap) FilteredHWType
mkADT :: (CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> String
-> TyConName
-> [Type]
-> ExceptT String (State HWMap) FilteredHWType
mkADT CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
_ CustomReprs
_ TyConMap
m String
tyString TyConName
tc [Type]
_
| TyConMap -> TyConName -> IsVoid
isRecursiveTy TyConMap
m TyConName
tc
= String -> ExceptT String (State HWMap) FilteredHWType
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (String -> ExceptT String (State HWMap) FilteredHWType)
-> String -> ExceptT String (State HWMap) FilteredHWType
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Can't translate recursive type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tyString
mkADT CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m String
tyString TyConName
tc [Type]
args = case TyCon -> [DataCon]
tyConDataCons (TyConName -> TyConMap -> TyCon
forall a b. Uniquable a => a -> UniqMap b -> b
UniqMap.find TyConName
tc TyConMap
m) of
[] -> FilteredHWType -> ExceptT String (State HWMap) FilteredHWType
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> [[(IsVoid, FilteredHWType)]] -> FilteredHWType
FilteredHWType (Maybe HWType -> HWType
Void Maybe HWType
forall a. Maybe a
Nothing) [])
[DataCon]
dcs -> do
let tcName :: Text
tcName = TyConName -> Text
forall a. Name a -> Text
nameOcc TyConName
tc
substArgTyss :: [[Type]]
substArgTyss = (DataCon -> [Type]) -> [DataCon] -> [[Type]]
forall a b. (a -> b) -> [a] -> [b]
map (DataCon -> [Type] -> [Type]
`substArgTys` [Type]
args) [DataCon]
dcs
[[FilteredHWType]]
argHTyss0 <- ([Type] -> ExceptT String (State HWMap) [FilteredHWType])
-> [[Type]] -> ExceptT String (State HWMap) [[FilteredHWType]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Type -> ExceptT String (State HWMap) FilteredHWType)
-> [Type] -> ExceptT String (State HWMap) [FilteredHWType]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (StateT HWMap Identity (Either String FilteredHWType)
-> ExceptT String (State HWMap) FilteredHWType
forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT (StateT HWMap Identity (Either String FilteredHWType)
-> ExceptT String (State HWMap) FilteredHWType)
-> (Type -> StateT HWMap Identity (Either String FilteredHWType))
-> Type
-> ExceptT String (State HWMap) FilteredHWType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> StateT HWMap Identity (Either String FilteredHWType)
coreTypeToHWType CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m)) [[Type]]
substArgTyss
let argHTyss1 :: [[(IsVoid, FilteredHWType)]]
argHTyss1 = ([FilteredHWType] -> [(IsVoid, FilteredHWType)])
-> [[FilteredHWType]] -> [[(IsVoid, FilteredHWType)]]
forall a b. (a -> b) -> [a] -> [b]
map (\[FilteredHWType]
tys -> [IsVoid] -> [FilteredHWType] -> [(IsVoid, FilteredHWType)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((FilteredHWType -> IsVoid) -> [FilteredHWType] -> [IsVoid]
forall a b. (a -> b) -> [a] -> [b]
map FilteredHWType -> IsVoid
isFilteredVoid [FilteredHWType]
tys) [FilteredHWType]
tys) [[FilteredHWType]]
argHTyss0
let areVoids :: [[IsVoid]]
areVoids = ([(IsVoid, FilteredHWType)] -> [IsVoid])
-> [[(IsVoid, FilteredHWType)]] -> [[IsVoid]]
forall a b. (a -> b) -> [a] -> [b]
map (((IsVoid, FilteredHWType) -> IsVoid)
-> [(IsVoid, FilteredHWType)] -> [IsVoid]
forall a b. (a -> b) -> [a] -> [b]
map (IsVoid, FilteredHWType) -> IsVoid
forall a b. (a, b) -> a
fst) [[(IsVoid, FilteredHWType)]]
argHTyss1
let filteredArgHTyss :: [[FilteredHWType]]
filteredArgHTyss = ([(IsVoid, FilteredHWType)] -> [FilteredHWType])
-> [[(IsVoid, FilteredHWType)]] -> [[FilteredHWType]]
forall a b. (a -> b) -> [a] -> [b]
map (((IsVoid, FilteredHWType) -> FilteredHWType)
-> [(IsVoid, FilteredHWType)] -> [FilteredHWType]
forall a b. (a -> b) -> [a] -> [b]
map (IsVoid, FilteredHWType) -> FilteredHWType
forall a b. (a, b) -> b
snd ([(IsVoid, FilteredHWType)] -> [FilteredHWType])
-> ([(IsVoid, FilteredHWType)] -> [(IsVoid, FilteredHWType)])
-> [(IsVoid, FilteredHWType)]
-> [FilteredHWType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((IsVoid, FilteredHWType) -> IsVoid)
-> [(IsVoid, FilteredHWType)] -> [(IsVoid, FilteredHWType)]
forall a. (a -> IsVoid) -> [a] -> [a]
filter (IsVoid -> IsVoid
not (IsVoid -> IsVoid)
-> ((IsVoid, FilteredHWType) -> IsVoid)
-> (IsVoid, FilteredHWType)
-> IsVoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IsVoid, FilteredHWType) -> IsVoid
forall a b. (a, b) -> a
fst)) [[(IsVoid, FilteredHWType)]]
argHTyss1
case ([DataCon]
dcs, [[FilteredHWType]]
filteredArgHTyss) of
([DataCon], [[FilteredHWType]])
_ | (DataCon -> IsVoid) -> [DataCon] -> IsVoid
forall (t :: Type -> Type) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
any (TyConMap -> DataCon -> IsVoid
hasUnconstrainedExistential TyConMap
m) [DataCon]
dcs ->
String -> ExceptT String (State HWMap) FilteredHWType
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (String -> ExceptT String (State HWMap) FilteredHWType)
-> String -> ExceptT String (State HWMap) FilteredHWType
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"Can't translate data types with unconstrained existentials: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
tyString
(DataCon
_:[],[[FilteredHWType
elemTy]]) ->
FilteredHWType -> ExceptT String (State HWMap) FilteredHWType
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> [[(IsVoid, FilteredHWType)]] -> FilteredHWType
FilteredHWType (FilteredHWType -> HWType
stripFiltered FilteredHWType
elemTy) [[(IsVoid, FilteredHWType)]]
argHTyss1)
([DataCon -> [Text]
dcFieldLabels -> [Text]
labels0],[elemTys :: [FilteredHWType]
elemTys@(FilteredHWType
_:[FilteredHWType]
_)]) -> do
Maybe [Text]
labelsM <-
if [Text] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Text]
labels0 then
Maybe [Text] -> ExceptT String (State HWMap) (Maybe [Text])
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe [Text]
forall a. Maybe a
Nothing
else
let areNotVoids :: [IsVoid]
areNotVoids = case [[IsVoid]]
areVoids of
[IsVoid]
areVoid:[[IsVoid]]
_ -> (IsVoid -> IsVoid) -> [IsVoid] -> [IsVoid]
forall a b. (a -> b) -> [a] -> [b]
map IsVoid -> IsVoid
not [IsVoid]
areVoid
[[IsVoid]]
_ -> String -> [IsVoid]
forall a. HasCallStack => String -> a
error String
"internal error: insufficient areVoids"
labels1 :: [(IsVoid, Text)]
labels1 = ((IsVoid, Text) -> IsVoid) -> [(IsVoid, Text)] -> [(IsVoid, Text)]
forall a. (a -> IsVoid) -> [a] -> [a]
filter (IsVoid, Text) -> IsVoid
forall a b. (a, b) -> a
fst ([IsVoid] -> [Text] -> [(IsVoid, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [IsVoid]
areNotVoids [Text]
labels0)
labels2 :: [Text]
labels2 = ((IsVoid, Text) -> Text) -> [(IsVoid, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (IsVoid, Text) -> Text
forall a b. (a, b) -> b
snd [(IsVoid, Text)]
labels1
in Maybe [Text] -> ExceptT String (State HWMap) (Maybe [Text])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text]
labels2)
let hwty :: HWType
hwty = Text -> Maybe [Text] -> [HWType] -> HWType
Product Text
tcName Maybe [Text]
labelsM ((FilteredHWType -> HWType) -> [FilteredHWType] -> [HWType]
forall a b. (a -> b) -> [a] -> [b]
map FilteredHWType -> HWType
stripFiltered [FilteredHWType]
elemTys)
FilteredHWType -> ExceptT String (State HWMap) FilteredHWType
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> [[(IsVoid, FilteredHWType)]] -> FilteredHWType
FilteredHWType HWType
hwty [[(IsVoid, FilteredHWType)]]
argHTyss1)
([DataCon]
_, [[FilteredHWType]] -> [FilteredHWType]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat -> [])
| [DataCon] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [DataCon]
dcs Int -> Int -> IsVoid
forall a. Ord a => a -> a -> IsVoid
<= Int
1 -> case [[FilteredHWType]]
argHTyss0 of
[[FilteredHWType]
argHTys0] ->
let argHTys1 :: [HWType]
argHTys1 = (FilteredHWType -> HWType) -> [FilteredHWType] -> [HWType]
forall a b. (a -> b) -> [a] -> [b]
map (HWType -> HWType
stripVoid (HWType -> HWType)
-> (FilteredHWType -> HWType) -> FilteredHWType -> HWType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilteredHWType -> HWType
stripFiltered) [FilteredHWType]
argHTys0
in FilteredHWType -> ExceptT String (State HWMap) FilteredHWType
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> [[(IsVoid, FilteredHWType)]] -> FilteredHWType
FilteredHWType
(Maybe HWType -> HWType
Void (HWType -> Maybe HWType
forall a. a -> Maybe a
Just (Text -> Maybe [Text] -> [HWType] -> HWType
Product Text
tcName Maybe [Text]
forall a. Maybe a
Nothing [HWType]
argHTys1)))
[[(IsVoid, FilteredHWType)]]
argHTyss1)
[[FilteredHWType]]
_ -> FilteredHWType -> ExceptT String (State HWMap) FilteredHWType
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> [[(IsVoid, FilteredHWType)]] -> FilteredHWType
FilteredHWType (Maybe HWType -> HWType
Void Maybe HWType
forall a. Maybe a
Nothing) [[(IsVoid, FilteredHWType)]]
argHTyss1)
| IsVoid
otherwise ->
FilteredHWType -> ExceptT String (State HWMap) FilteredHWType
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> [[(IsVoid, FilteredHWType)]] -> FilteredHWType
FilteredHWType (Text -> [Text] -> HWType
Sum Text
tcName ([Text] -> HWType) -> [Text] -> HWType
forall a b. (a -> b) -> a -> b
$ (DataCon -> Text) -> [DataCon] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Name DataCon -> Text
forall a. Name a -> Text
nameOcc (Name DataCon -> Text)
-> (DataCon -> Name DataCon) -> DataCon -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> Name DataCon
dcName) [DataCon]
dcs) [[(IsVoid, FilteredHWType)]]
argHTyss1)
([DataCon]
_,[[FilteredHWType]]
elemHTys) ->
FilteredHWType -> ExceptT String (State HWMap) FilteredHWType
forall (m :: Type -> Type) a. Monad m => a -> m a
return (FilteredHWType -> ExceptT String (State HWMap) FilteredHWType)
-> FilteredHWType -> ExceptT String (State HWMap) FilteredHWType
forall a b. (a -> b) -> a -> b
$ HWType -> [[(IsVoid, FilteredHWType)]] -> FilteredHWType
FilteredHWType (Text -> [(Text, [HWType])] -> HWType
SP Text
tcName ([(Text, [HWType])] -> HWType) -> [(Text, [HWType])] -> HWType
forall a b. (a -> b) -> a -> b
$ (DataCon -> [HWType] -> (Text, [HWType]))
-> [DataCon] -> [[HWType]] -> [(Text, [HWType])]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
(\DataCon
dc [HWType]
tys -> ( Name DataCon -> Text
forall a. Name a -> Text
nameOcc (DataCon -> Name DataCon
dcName DataCon
dc), [HWType]
tys))
[DataCon]
dcs ((FilteredHWType -> HWType) -> [FilteredHWType] -> [HWType]
forall a b. (a -> b) -> [a] -> [b]
map FilteredHWType -> HWType
stripFiltered ([FilteredHWType] -> [HWType]) -> [[FilteredHWType]] -> [[HWType]]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [[FilteredHWType]]
elemHTys)) [[(IsVoid, FilteredHWType)]]
argHTyss1
hasUnconstrainedExistential
:: TyConMap
-> DataCon
-> Bool
hasUnconstrainedExistential :: TyConMap -> DataCon -> IsVoid
hasUnconstrainedExistential TyConMap
tcm DataCon
dc =
let eTVs :: [TyVar]
eTVs = DataCon -> [TyVar]
dcExtTyVars DataCon
dc
uTVs :: [TyVar]
uTVs = DataCon -> [TyVar]
dcUnivTyVars DataCon
dc
constraints :: [(Type, Type)]
constraints = (Type -> Maybe (Type, Type)) -> [Type] -> [(Type, Type)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TyConMap -> Type -> Maybe (Type, Type)
typeEq TyConMap
tcm) (DataCon -> [Type]
dcArgTys DataCon
dc)
isConstrainedBy :: TyVar -> (Type, Type) -> IsVoid
isConstrainedBy TyVar
eTV (Type
ty1,Type
ty2) =
let
ty1FEVs :: [Var a]
ty1FEVs = Getting (Endo [Var a]) Type (Var a) -> Type -> [Var a]
forall a s. Getting (Endo [a]) s a -> s -> [a]
Lens.toListOf ((forall b. Var b -> IsVoid)
-> IntSet -> Getting (Endo [Var a]) Type (Var a)
forall (f :: Type -> Type) a.
(Contravariant f, Applicative f) =>
(forall b. Var b -> IsVoid)
-> IntSet -> (Var a -> f (Var a)) -> Type -> f Type
typeFreeVars' ((TyVar -> [TyVar] -> IsVoid
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> IsVoid
`notElem` [TyVar]
uTVs) (TyVar -> IsVoid) -> (Var b -> TyVar) -> Var b -> IsVoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var b -> TyVar
coerce)
IntSet
IntSet.empty)
Type
ty1
ty2FEVs :: [Var a]
ty2FEVs = Getting (Endo [Var a]) Type (Var a) -> Type -> [Var a]
forall a s. Getting (Endo [a]) s a -> s -> [a]
Lens.toListOf ((forall b. Var b -> IsVoid)
-> IntSet -> Getting (Endo [Var a]) Type (Var a)
forall (f :: Type -> Type) a.
(Contravariant f, Applicative f) =>
(forall b. Var b -> IsVoid)
-> IntSet -> (Var a -> f (Var a)) -> Type -> f Type
typeFreeVars' ((TyVar -> [TyVar] -> IsVoid
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> IsVoid
`notElem` [TyVar]
uTVs) (TyVar -> IsVoid) -> (Var b -> TyVar) -> Var b -> IsVoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var b -> TyVar
coerce)
IntSet
IntSet.empty)
Type
ty2
isGenerative ::
Type ->
[TyVar] ->
Bool
isGenerative :: Type -> [TyVar] -> IsVoid
isGenerative Type
t [TyVar]
efvs = case Type -> TypeView
tyView Type
t of
TyConApp TyConName
tcNm [Type]
_
| Just (FunTyCon {}) <- TyConName -> TyConMap -> Maybe TyCon
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
UniqMap.lookup TyConName
tcNm TyConMap
tcm
-> [TyVar
eTV] [TyVar] -> [TyVar] -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== [TyVar]
efvs
| IsVoid
otherwise
-> TyVar
eTV TyVar -> [TyVar] -> IsVoid
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> IsVoid
`elem` [TyVar]
efvs
FunTy {}
-> TyVar
eTV TyVar -> [TyVar] -> IsVoid
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> IsVoid
`elem` [TyVar]
efvs
OtherType Type
other -> case Type
other of
VarTy TyVar
v -> TyVar
v TyVar -> TyVar -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== TyVar
eTV
LitTy LitTy
_ -> IsVoid
False
Type
_ -> IsVoid
False
onlyTy1 :: IsVoid
onlyTy1 = Type -> [TyVar] -> IsVoid
isGenerative Type
ty1 [TyVar]
forall a. [Var a]
ty1FEVs IsVoid -> IsVoid -> IsVoid
&& [Var Any] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Var Any]
forall a. [Var a]
ty2FEVs
onlyTy2 :: IsVoid
onlyTy2 = Type -> [TyVar] -> IsVoid
isGenerative Type
ty2 [TyVar]
forall a. [Var a]
ty2FEVs IsVoid -> IsVoid -> IsVoid
&& [Var Any] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Var Any]
forall a. [Var a]
ty1FEVs
in IsVoid
onlyTy1 IsVoid -> IsVoid -> IsVoid
|| IsVoid
onlyTy2
unconstrainedETVs :: [TyVar]
unconstrainedETVs =
(TyVar -> IsVoid) -> [TyVar] -> [TyVar]
forall a. (a -> IsVoid) -> [a] -> [a]
filter (\TyVar
v -> IsVoid -> IsVoid
not (((Type, Type) -> IsVoid) -> [(Type, Type)] -> IsVoid
forall (t :: Type -> Type) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
any (TyVar -> (Type, Type) -> IsVoid
isConstrainedBy TyVar
v) [(Type, Type)]
constraints)) [TyVar]
eTVs
in IsVoid -> IsVoid
not ([TyVar] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [TyVar]
unconstrainedETVs)
isRecursiveTy :: TyConMap -> TyConName -> Bool
isRecursiveTy :: TyConMap -> TyConName -> IsVoid
isRecursiveTy TyConMap
m TyConName
tc = case TyCon -> [DataCon]
tyConDataCons (TyConName -> TyConMap -> TyCon
forall a b. Uniquable a => a -> UniqMap b -> b
UniqMap.find TyConName
tc TyConMap
m) of
[] -> IsVoid
False
[DataCon]
dcs -> let argTyss :: [[Type]]
argTyss = (DataCon -> [Type]) -> [DataCon] -> [[Type]]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> [Type]
dcArgTys [DataCon]
dcs
argTycons :: [TyConName]
argTycons = (((TyConName, [Type]) -> TyConName)
-> [(TyConName, [Type])] -> [TyConName]
forall a b. (a -> b) -> [a] -> [b]
map (TyConName, [Type]) -> TyConName
forall a b. (a, b) -> a
fst ([(TyConName, [Type])] -> [TyConName])
-> ([Maybe (TyConName, [Type])] -> [(TyConName, [Type])])
-> [Maybe (TyConName, [Type])]
-> [TyConName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (TyConName, [Type])] -> [(TyConName, [Type])]
forall a. [Maybe a] -> [a]
catMaybes)
([Maybe (TyConName, [Type])] -> [TyConName])
-> [Maybe (TyConName, [Type])] -> [TyConName]
forall a b. (a -> b) -> a -> b
$ (([Type] -> [Maybe (TyConName, [Type])])
-> [[Type]] -> [Maybe (TyConName, [Type])]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (([Type] -> [Maybe (TyConName, [Type])])
-> [[Type]] -> [Maybe (TyConName, [Type])])
-> ((Type -> Maybe (TyConName, [Type]))
-> [Type] -> [Maybe (TyConName, [Type])])
-> (Type -> Maybe (TyConName, [Type]))
-> [[Type]]
-> [Maybe (TyConName, [Type])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Maybe (TyConName, [Type]))
-> [Type] -> [Maybe (TyConName, [Type])]
forall a b. (a -> b) -> [a] -> [b]
map)
(Type -> Maybe (TyConName, [Type])
splitTyConAppM (Type -> Maybe (TyConName, [Type]))
-> (Type -> Type) -> Type -> Maybe (TyConName, [Type])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyConMap -> Type -> Type
normalizeType TyConMap
m)
[[Type]]
argTyss
in TyConName
tc TyConName -> [TyConName] -> IsVoid
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> IsVoid
`elem` [TyConName]
argTycons
representableType
:: (CustomReprs -> TyConMap -> Type ->
State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> Bool
-> TyConMap
-> Type
-> Bool
representableType :: (CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs -> IsVoid -> TyConMap -> Type -> IsVoid
representableType CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs IsVoid
stringRepresentable TyConMap
m =
(String -> IsVoid)
-> (HWType -> IsVoid) -> Either String HWType -> IsVoid
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IsVoid -> String -> IsVoid
forall a b. a -> b -> a
const IsVoid
False) HWType -> IsVoid
isRepresentable (Either String HWType -> IsVoid)
-> (Type -> Either String HWType) -> Type -> IsVoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(State HWMap (Either String HWType)
-> HWMap -> Either String HWType)
-> HWMap
-> State HWMap (Either String HWType)
-> Either String HWType
forall a b c. (a -> b -> c) -> b -> a -> c
flip State HWMap (Either String HWType) -> HWMap -> Either String HWType
forall s a. State s a -> s -> a
evalState HWMap
forall a. Monoid a => a
mempty (State HWMap (Either String HWType) -> Either String HWType)
-> (Type -> State HWMap (Either String HWType))
-> Type
-> Either String HWType
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> State HWMap (Either String HWType)
coreTypeToHWType' CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m
where
isRepresentable :: HWType -> IsVoid
isRepresentable HWType
hty = case HWType
hty of
HWType
String -> IsVoid
stringRepresentable
Vector Int
_ HWType
elTy -> HWType -> IsVoid
isRepresentable HWType
elTy
RTree Int
_ HWType
elTy -> HWType -> IsVoid
isRepresentable HWType
elTy
Product Text
_ Maybe [Text]
_ [HWType]
elTys -> (HWType -> IsVoid) -> [HWType] -> IsVoid
forall (t :: Type -> Type) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
all HWType -> IsVoid
isRepresentable [HWType]
elTys
SP Text
_ [(Text, [HWType])]
elTyss -> ((Text, [HWType]) -> IsVoid) -> [(Text, [HWType])] -> IsVoid
forall (t :: Type -> Type) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
all ((HWType -> IsVoid) -> [HWType] -> IsVoid
forall (t :: Type -> Type) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
all HWType -> IsVoid
isRepresentable ([HWType] -> IsVoid)
-> ((Text, [HWType]) -> [HWType]) -> (Text, [HWType]) -> IsVoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, [HWType]) -> [HWType]
forall a b. (a, b) -> b
snd) [(Text, [HWType])]
elTyss
BiDirectional PortDirection
_ HWType
t -> HWType -> IsVoid
isRepresentable HWType
t
Annotated [Attr Text]
_ HWType
ty -> HWType -> IsVoid
isRepresentable HWType
ty
HWType
_ -> IsVoid
True
typeSize :: HWType
-> Int
typeSize :: HWType -> Int
typeSize (Void {}) = Int
0
typeSize HWType
FileType = Int
32
typeSize HWType
String = Int
0
typeSize HWType
Integer = Int
0
typeSize (KnownDomain {}) = Int
0
typeSize HWType
Bool = Int
1
typeSize HWType
Bit = Int
1
typeSize (Clock Text
_) = Int
1
typeSize (ClockN Text
_) = Int
1
typeSize (Reset Text
_) = Int
1
typeSize (Enable Text
_) = Int
1
typeSize (BitVector Int
i) = Int
i
typeSize (Index BitMask
0) = Int
0
typeSize (Index BitMask
1) = Int
1
typeSize (Index BitMask
u) = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (BitMask -> BitMask -> Maybe Int
clogBase BitMask
2 BitMask
u)
typeSize (Signed Int
i) = Int
i
typeSize (Unsigned Int
i) = Int
i
typeSize (Vector Int
n HWType
el) = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* HWType -> Int
typeSize HWType
el
typeSize (MemBlob Int
n Int
m) = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
m
typeSize (RTree Int
d HWType
el) = (Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Int
d) Int -> Int -> Int
forall a. Num a => a -> a -> a
* HWType -> Int
typeSize HWType
el
typeSize t :: HWType
t@(SP Text
_ [(Text, [HWType])]
cons) = HWType -> Int
conSize HWType
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+
[Int] -> Int
forall (t :: Type -> Type) a. (Foldable t, Ord a) => t a -> a
maximum (((Text, [HWType]) -> Int) -> [(Text, [HWType])] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> Int
forall (t :: Type -> Type) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int)
-> ((Text, [HWType]) -> [Int]) -> (Text, [HWType]) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HWType -> Int) -> [HWType] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map HWType -> Int
typeSize ([HWType] -> [Int])
-> ((Text, [HWType]) -> [HWType]) -> (Text, [HWType]) -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, [HWType]) -> [HWType]
forall a b. (a, b) -> b
snd) [(Text, [HWType])]
cons)
typeSize (Sum Text
_ [Text]
dcs) = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> (Int -> Maybe Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitMask -> BitMask -> Maybe Int
clogBase BitMask
2 (BitMask -> Maybe Int) -> (Int -> BitMask) -> Int -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> BitMask
forall a. Integral a => a -> BitMask
toInteger (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Text] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Text]
dcs
typeSize (Product Text
_ Maybe [Text]
_ [HWType]
tys) = [Int] -> Int
forall (t :: Type -> Type) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (HWType -> Int) -> [HWType] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map HWType -> Int
typeSize [HWType]
tys
typeSize (BiDirectional PortDirection
In HWType
h) = HWType -> Int
typeSize HWType
h
typeSize (BiDirectional PortDirection
Out HWType
_) = Int
0
typeSize (CustomSP Text
_ DataRepr'
_ Int
size [(ConstrRepr', Text, [HWType])]
_) = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size
typeSize (CustomSum Text
_ DataRepr'
_ Int
size [(ConstrRepr', Text)]
_) = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size
typeSize (CustomProduct Text
_ DataRepr'
_ Int
size Maybe [Text]
_ [(BitMask, HWType)]
_) = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size
typeSize (Annotated [Attr Text]
_ HWType
ty) = HWType -> Int
typeSize HWType
ty
conSize :: HWType
-> Int
conSize :: HWType -> Int
conSize (SP Text
_ [(Text, [HWType])]
cons) = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> (Int -> Maybe Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitMask -> BitMask -> Maybe Int
clogBase BitMask
2 (BitMask -> Maybe Int) -> (Int -> BitMask) -> Int -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> BitMask
forall a. Integral a => a -> BitMask
toInteger (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [(Text, [HWType])] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [(Text, [HWType])]
cons
conSize HWType
t = HWType -> Int
typeSize HWType
t
termHWType :: String
-> Term
-> NetlistMonad HWType
termHWType :: String -> Term -> NetlistMonad HWType
termHWType String
loc Term
e = do
TyConMap
m <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
let ty :: Type
ty = TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
m Term
e
FilteredHWType -> HWType
stripFiltered (FilteredHWType -> HWType)
-> NetlistMonad FilteredHWType -> NetlistMonad HWType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Type -> NetlistMonad FilteredHWType
unsafeCoreTypeToHWTypeM String
loc Type
ty
termHWTypeM
:: Term
-> NetlistMonad (Maybe FilteredHWType)
termHWTypeM :: Term -> NetlistMonad (Maybe FilteredHWType)
termHWTypeM Term
e = do
TyConMap
m <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
let ty :: Type
ty = TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
m Term
e
Type -> NetlistMonad (Maybe FilteredHWType)
coreTypeToHWTypeM Type
ty
isBiSignalIn :: HWType -> Bool
isBiSignalIn :: HWType -> IsVoid
isBiSignalIn (BiDirectional PortDirection
In HWType
_) = IsVoid
True
isBiSignalIn (Annotated [Attr Text]
_ HWType
ty) = HWType -> IsVoid
isBiSignalIn HWType
ty
isBiSignalIn HWType
_ = IsVoid
False
isBiSignalOut :: HWType -> Bool
isBiSignalOut :: HWType -> IsVoid
isBiSignalOut (BiDirectional PortDirection
Out HWType
_) = IsVoid
True
isBiSignalOut (Annotated [Attr Text]
_ HWType
ty) = HWType -> IsVoid
isBiSignalOut HWType
ty
isBiSignalOut HWType
_ = IsVoid
False
containsBiSignalIn
:: HWType
-> Bool
containsBiSignalIn :: HWType -> IsVoid
containsBiSignalIn (BiDirectional PortDirection
In HWType
_) = IsVoid
True
containsBiSignalIn (Product Text
_ Maybe [Text]
_ [HWType]
tys) = (HWType -> IsVoid) -> [HWType] -> IsVoid
forall (t :: Type -> Type) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
any HWType -> IsVoid
containsBiSignalIn [HWType]
tys
containsBiSignalIn (SP Text
_ [(Text, [HWType])]
tyss) = ((Text, [HWType]) -> IsVoid) -> [(Text, [HWType])] -> IsVoid
forall (t :: Type -> Type) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
any ((HWType -> IsVoid) -> [HWType] -> IsVoid
forall (t :: Type -> Type) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
any HWType -> IsVoid
containsBiSignalIn ([HWType] -> IsVoid)
-> ((Text, [HWType]) -> [HWType]) -> (Text, [HWType]) -> IsVoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, [HWType]) -> [HWType]
forall a b. (a, b) -> b
snd) [(Text, [HWType])]
tyss
containsBiSignalIn (Vector Int
_ HWType
ty) = HWType -> IsVoid
containsBiSignalIn HWType
ty
containsBiSignalIn (RTree Int
_ HWType
ty) = HWType -> IsVoid
containsBiSignalIn HWType
ty
containsBiSignalIn (Annotated [Attr Text]
_ HWType
ty) = HWType -> IsVoid
containsBiSignalIn HWType
ty
containsBiSignalIn HWType
_ = IsVoid
False
mkUniqueNormalized
:: HasCallStack
=> InScopeSet
-> Maybe (Maybe TopEntity)
-> ( [Id]
, [LetBinding]
, Id
)
-> NetlistMonad
([Bool]
,[(Identifier,HWType)]
,[Declaration]
,[(Identifier,HWType)]
,[Declaration]
,[LetBinding]
,Maybe Id)
mkUniqueNormalized :: InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
([IsVoid], [(Identifier, HWType)], [Declaration],
[(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
mkUniqueNormalized InScopeSet
is0 Maybe (Maybe TopEntity)
topMM ([Id]
args, [LetBinding]
binds, Id
res) = do
[FilteredHWType]
argHwtys <- (Id -> NetlistMonad FilteredHWType)
-> [Id] -> NetlistMonad [FilteredHWType]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Type -> NetlistMonad FilteredHWType
unsafeCoreTypeToHWTypeM $(String
curLoc) (Type -> NetlistMonad FilteredHWType)
-> (Id -> Type) -> Id -> NetlistMonad FilteredHWType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
forall a. HasType a => a -> Type
coreTypeOf) [Id]
args
FilteredHWType
resHwty <- String -> Type -> NetlistMonad FilteredHWType
unsafeCoreTypeToHWTypeM $(String
curLoc) (Id -> Type
forall a. HasType a => a -> Type
coreTypeOf Id
res)
Maybe (ExpandedTopEntity Identifier)
etopM <-
(Maybe TopEntity -> NetlistMonad (ExpandedTopEntity Identifier))
-> Maybe (Maybe TopEntity)
-> NetlistMonad (Maybe (ExpandedTopEntity Identifier))
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
(HasCallStack =>
[(Maybe Id, FilteredHWType)]
-> (Maybe Id, FilteredHWType)
-> Maybe TopEntity
-> NetlistMonad (ExpandedTopEntity Identifier)
[(Maybe Id, FilteredHWType)]
-> (Maybe Id, FilteredHWType)
-> Maybe TopEntity
-> NetlistMonad (ExpandedTopEntity Identifier)
expandTopEntityOrErrM ([Maybe Id] -> [FilteredHWType] -> [(Maybe Id, FilteredHWType)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Id -> Maybe Id) -> [Id] -> [Maybe Id]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Maybe Id
forall a. a -> Maybe a
Just [Id]
args) [FilteredHWType]
argHwtys) (Id -> Maybe Id
forall a. a -> Maybe a
Just Id
res, FilteredHWType
resHwty))
Maybe (Maybe TopEntity)
topMM
let ([Id]
bndrs, [Term]
exprs) = [LetBinding] -> ([Id], [Term])
forall a b. [(a, b)] -> ([a], [b])
unzip [LetBinding]
binds
let is1 :: InScopeSet
is1 = InScopeSet
is0 InScopeSet -> [Id] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
`extendInScopeSetList` ([Id]
args [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
bndrs)
([IsVoid]
wereVoids, [(Identifier, HWType)]
iports, [Declaration]
iwrappers, Subst
substArgs) <-
Subst
-> Maybe (ExpandedTopEntity Identifier)
-> [Id]
-> NetlistMonad
([IsVoid], [(Identifier, HWType)], [Declaration], Subst)
mkUniqueArguments (InScopeSet -> Subst
mkSubst InScopeSet
is1) Maybe (ExpandedTopEntity Identifier)
etopM [Id]
args
Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
resM <- Subst
-> Maybe (ExpandedTopEntity Identifier)
-> Id
-> NetlistMonad
(Maybe ([(Identifier, HWType)], [Declaration], Id, Subst))
mkUniqueResult Subst
substArgs Maybe (ExpandedTopEntity Identifier)
etopM Id
res
case Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
resM of
Just ([(Identifier, HWType)]
oports, [Declaration]
owrappers, Id
res1, Subst
subst0) -> do
([(Id, Id)] -> Maybe (Id, Id)
forall a. [a] -> Maybe a
listToMaybe -> Maybe (Id, Id)
resRenameM0, [(Id, Id)] -> HashMap Id Id
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList -> HashMap Id Id
renames0) <-
((Id, Id) -> IsVoid) -> [(Id, Id)] -> ([(Id, Id)], [(Id, Id)])
forall a. (a -> IsVoid) -> [a] -> ([a], [a])
partition ((Id -> Id -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Id
res) (Id -> IsVoid) -> ((Id, Id) -> Id) -> (Id, Id) -> IsVoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, Id) -> Id
forall a b. (a, b) -> a
fst) ([(Id, Id)] -> ([(Id, Id)], [(Id, Id)]))
-> NetlistMonad [(Id, Id)] -> NetlistMonad ([(Id, Id)], [(Id, Id)])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (LetBinding -> NetlistMonad [(Id, Id)])
-> [LetBinding] -> NetlistMonad [(Id, Id)]
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m [b]) -> [a] -> m [b]
concatMapM LetBinding -> NetlistMonad [(Id, Id)]
renameBinder [LetBinding]
binds
let
resultRead :: IsVoid
resultRead = (Term -> IsVoid) -> [Term] -> IsVoid
forall (t :: Type -> Type) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
any (Id -> Term -> IsVoid
forall a. HasFreeVars a => Var a -> a -> IsVoid
elemFreeVars Id
res) [Term]
exprs
recResult :: Id
recResult = (Name Term -> Name Term) -> Id -> Id
forall a. (Name a -> Name a) -> Var a -> Var a
modifyVarName (Name Term -> Text -> Name Term
forall a. Name a -> Text -> Name a
`appendToName` Text
"_rec") Id
res
resRenameM1 :: Maybe (Id, Id)
resRenameM1 = Maybe (Id, Id)
resRenameM0 Maybe (Id, Id) -> Maybe (Id, Id) -> Maybe (Id, Id)
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> IsVoid -> (Id, Id) -> Maybe (Id, Id)
forall a. IsVoid -> a -> Maybe a
orNothing IsVoid
resultRead (Id
res, Id
recResult)
(Id
resN, Maybe LetBinding
extraBind, Subst
subst1) <-
case Maybe (Id, Id)
resRenameM1 of
Maybe (Id, Id)
Nothing ->
(Id, Maybe LetBinding, Subst)
-> NetlistMonad (Id, Maybe LetBinding, Subst)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Id
res1, Maybe LetBinding
forall a. Maybe a
Nothing, Subst
subst0)
Just (Id
_, Id
newName0) -> do
([Id
newName1], Subst
s) <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique Subst
subst0 [Id
newName0]
(Id, Maybe LetBinding, Subst)
-> NetlistMonad (Id, Maybe LetBinding, Subst)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Id
newName1, LetBinding -> Maybe LetBinding
forall a. a -> Maybe a
Just (Id
res1, Id -> Term
Var Id
newName1), Subst
s)
let
renames1 :: [(Id, Id)]
renames1 = [(Id
b, Id -> Id -> HashMap Id Id -> Id
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
hmFindWithDefault Id
b Id
b HashMap Id Id
renames0) | Id
b <- [Id]
bndrs]
([(Id, Id)]
renamesL0, [(Id, Id)]
renamesR0) = case ((Id, Id) -> IsVoid) -> [(Id, Id)] -> ([(Id, Id)], [(Id, Id)])
forall a. (a -> IsVoid) -> [a] -> ([a], [a])
break ((Id -> Id -> IsVoid
forall a. Eq a => a -> a -> IsVoid
==Id
res) (Id -> IsVoid) -> ((Id, Id) -> Id) -> (Id, Id) -> IsVoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, Id) -> Id
forall a b. (a, b) -> a
fst) [(Id, Id)]
renames1 of
([(Id, Id)]
ls,(Id, Id)
_:[(Id, Id)]
rs) -> ([(Id, Id)]
ls,[(Id, Id)]
rs)
([(Id, Id)], [(Id, Id)])
_ -> String -> ([(Id, Id)], [(Id, Id)])
forall a. HasCallStack => String -> a
error ([String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [ String
"internal error: unable to find: "
, Id -> String
forall a. Show a => a -> String
show Id
res , String
" in: "
, [(Id, Id)] -> String
forall a. Show a => a -> String
show [(Id, Id)]
renames1 ])
([Id]
renamesL1, Subst
subst2) <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique Subst
subst1 (((Id, Id) -> Id) -> [(Id, Id)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, Id) -> Id
forall a b. (a, b) -> b
snd [(Id, Id)]
renamesL0)
([Id]
renamesR1, Subst
subst3) <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique Subst
subst2 (((Id, Id) -> Id) -> [(Id, Id)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, Id) -> Id
forall a b. (a, b) -> b
snd [(Id, Id)]
renamesR0)
let
exprs1 :: [Term]
exprs1 = (Term -> Term) -> [Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm Doc ()
"mkUniqueNormalized1" Subst
subst3) [Term]
exprs
binds0 :: [LetBinding]
binds0 = [Id] -> [Term] -> [LetBinding]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Id]
renamesL1 [Id] -> [Id] -> [Id]
forall a. Semigroup a => a -> a -> a
<> [Id
resN] [Id] -> [Id] -> [Id]
forall a. Semigroup a => a -> a -> a
<> [Id]
renamesR1) [Term]
exprs1
binds1 :: [LetBinding]
binds1 = [LetBinding]
binds0 [LetBinding] -> [LetBinding] -> [LetBinding]
forall a. Semigroup a => a -> a -> a
<> Maybe LetBinding -> [LetBinding]
forall a. Maybe a -> [a]
maybeToList Maybe LetBinding
extraBind
([IsVoid], [(Identifier, HWType)], [Declaration],
[(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
-> NetlistMonad
([IsVoid], [(Identifier, HWType)], [Declaration],
[(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([IsVoid]
wereVoids, [(Identifier, HWType)]
iports, [Declaration]
iwrappers, [(Identifier, HWType)]
oports, [Declaration]
owrappers, [LetBinding]
binds1, Id -> Maybe Id
forall a. a -> Maybe a
Just Id
res1)
Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
Nothing -> do
([Id]
bndrs1, Subst
substArgs1) <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique Subst
substArgs [Id]
bndrs
let binds1 :: [LetBinding]
binds1 = [Id] -> [Term] -> [LetBinding]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
bndrs1 ((Term -> Term) -> [Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm Doc ()
"mkUniqueNormalized2" Subst
substArgs1) [Term]
exprs)
([IsVoid], [(Identifier, HWType)], [Declaration],
[(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
-> NetlistMonad
([IsVoid], [(Identifier, HWType)], [Declaration],
[(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([IsVoid]
wereVoids, [(Identifier, HWType)]
iports, [Declaration]
iwrappers, [], [], [LetBinding]
binds1, Maybe Id
forall a. Maybe a
Nothing)
orNothing :: Bool -> a -> Maybe a
orNothing :: IsVoid -> a -> Maybe a
orNothing IsVoid
True a
a = a -> Maybe a
forall a. a -> Maybe a
Just a
a
orNothing IsVoid
False a
_ = Maybe a
forall a. Maybe a
Nothing
renameBinder :: (Id, Term) -> NetlistMonad [(Id, Id)]
renameBinder :: LetBinding -> NetlistMonad [(Id, Id)]
renameBinder (Id
i, Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks -> (Term
k, [Either Term Type]
args, [TickInfo]
ticks)) = [TickInfo]
-> ([Declaration] -> NetlistMonad [(Id, Id)])
-> NetlistMonad [(Id, Id)]
forall a.
[TickInfo] -> ([Declaration] -> NetlistMonad a) -> NetlistMonad a
withTicks [TickInfo]
ticks (([Declaration] -> NetlistMonad [(Id, Id)])
-> NetlistMonad [(Id, Id)])
-> ([Declaration] -> NetlistMonad [(Id, Id)])
-> NetlistMonad [(Id, Id)]
forall a b. (a -> b) -> a -> b
$ \[Declaration]
_ -> do
case Term
k of
Prim PrimInfo
p ->
case PrimInfo -> IsMultiPrim
primMultiResult PrimInfo
p of
IsMultiPrim
SingleResult -> HasCallStack => Text -> NetlistMonad CompiledPrimitive
Text -> NetlistMonad CompiledPrimitive
extractPrimWarnOrFail (PrimInfo -> Text
primName PrimInfo
p) NetlistMonad CompiledPrimitive
-> (CompiledPrimitive -> NetlistMonad [(Id, Id)])
-> NetlistMonad [(Id, Id)]
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= PrimInfo -> CompiledPrimitive -> NetlistMonad [(Id, Id)]
goSingle PrimInfo
p
IsMultiPrim
MultiResult -> HasCallStack => Text -> NetlistMonad CompiledPrimitive
Text -> NetlistMonad CompiledPrimitive
extractPrimWarnOrFail (PrimInfo -> Text
primName PrimInfo
p) NetlistMonad CompiledPrimitive
-> (CompiledPrimitive -> NetlistMonad [(Id, Id)])
-> NetlistMonad [(Id, Id)]
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= PrimInfo -> CompiledPrimitive -> NetlistMonad [(Id, Id)]
goMulti PrimInfo
p
Term
_ -> [(Id, Id)] -> NetlistMonad [(Id, Id)]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
where
goMulti :: PrimInfo -> CompiledPrimitive -> NetlistMonad [(Id, Id)]
goMulti :: PrimInfo -> CompiledPrimitive -> NetlistMonad [(Id, Id)]
goMulti PrimInfo
pInfo (BlackBoxHaskell{function :: forall a b c d. Primitive a b c d -> d
function=(Int
_, BlackBoxFunction
function)}) = do
TyConMap
tcm <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
let mpInfo :: MultiPrimInfo
mpInfo@MultiPrimInfo{[Type]
mpi_resultTypes :: MultiPrimInfo -> [Type]
mpi_resultTypes :: [Type]
mpi_resultTypes} = HasCallStack => TyConMap -> PrimInfo -> MultiPrimInfo
TyConMap -> PrimInfo -> MultiPrimInfo
multiPrimInfo' TyConMap
tcm PrimInfo
pInfo
let ([Either Term Type]
args1, [Id]
resIds) = HasCallStack =>
MultiPrimInfo -> [Either Term Type] -> ([Either Term Type], [Id])
MultiPrimInfo -> [Either Term Type] -> ([Either Term Type], [Id])
splitMultiPrimArgs MultiPrimInfo
mpInfo [Either Term Type]
args
Either String (BlackBoxMeta, BlackBox)
funRes <- NetlistMonad (Either String (BlackBoxMeta, BlackBox))
-> NetlistMonad (Either String (BlackBoxMeta, BlackBox))
forall a. NetlistMonad a -> NetlistMonad a
preserveVarEnv (BlackBoxFunction
function IsVoid
False (PrimInfo -> Text
primName PrimInfo
pInfo) [Either Term Type]
args1 [Type]
mpi_resultTypes)
let BlackBoxMeta{[BlackBox]
bbResultNames :: [BlackBox]
bbResultNames :: BlackBoxMeta -> [BlackBox]
bbResultNames} = (String -> BlackBoxMeta)
-> ((BlackBoxMeta, BlackBox) -> BlackBoxMeta)
-> Either String (BlackBoxMeta, BlackBox)
-> BlackBoxMeta
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> BlackBoxMeta
forall a. HasCallStack => String -> a
error (BlackBoxMeta, BlackBox) -> BlackBoxMeta
forall a b. (a, b) -> a
fst Either String (BlackBoxMeta, BlackBox)
funRes
Text
-> [Id]
-> [Either Term Type]
-> [BlackBox]
-> NetlistMonad [(Id, Id)]
go (PrimInfo -> Text
primName PrimInfo
pInfo) [Id]
resIds [Either Term Type]
args1 [BlackBox]
bbResultNames
goMulti PrimInfo
_ CompiledPrimitive
_ = [(Id, Id)] -> NetlistMonad [(Id, Id)]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
goSingle :: PrimInfo -> CompiledPrimitive -> NetlistMonad [(Id, Id)]
goSingle :: PrimInfo -> CompiledPrimitive -> NetlistMonad [(Id, Id)]
goSingle PrimInfo
pInfo (BlackBoxHaskell{function :: forall a b c d. Primitive a b c d -> d
function=(Int
_, BlackBoxFunction
function)}) = do
Either String (BlackBoxMeta, BlackBox)
funRes <- NetlistMonad (Either String (BlackBoxMeta, BlackBox))
-> NetlistMonad (Either String (BlackBoxMeta, BlackBox))
forall a. NetlistMonad a -> NetlistMonad a
preserveVarEnv (BlackBoxFunction
function IsVoid
False (PrimInfo -> Text
primName PrimInfo
pInfo) [Either Term Type]
args [Id -> Type
forall a. HasType a => a -> Type
coreTypeOf Id
i])
case (String -> BlackBoxMeta)
-> ((BlackBoxMeta, BlackBox) -> BlackBoxMeta)
-> Either String (BlackBoxMeta, BlackBox)
-> BlackBoxMeta
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> BlackBoxMeta
forall a. HasCallStack => String -> a
error (BlackBoxMeta, BlackBox) -> BlackBoxMeta
forall a b. (a, b) -> a
fst Either String (BlackBoxMeta, BlackBox)
funRes of
BlackBoxMeta{bbResultNames :: BlackBoxMeta -> [BlackBox]
bbResultNames=[BlackBox
bbResultName]} ->
Text
-> [Id]
-> [Either Term Type]
-> [BlackBox]
-> NetlistMonad [(Id, Id)]
go (PrimInfo -> Text
primName PrimInfo
pInfo) [Id
i] [Either Term Type]
args [BlackBox
bbResultName]
BlackBoxMeta
_ -> [(Id, Id)] -> NetlistMonad [(Id, Id)]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
goSingle PrimInfo
pInfo (BlackBox{resultNames :: forall a b c d. Primitive a b c d -> [b]
resultNames=[BlackBox
resultName]}) = do
Text
-> [Id]
-> [Either Term Type]
-> [BlackBox]
-> NetlistMonad [(Id, Id)]
go (PrimInfo -> Text
primName PrimInfo
pInfo) [Id
i] [Either Term Type]
args [BlackBox
resultName]
goSingle PrimInfo
_ CompiledPrimitive
_ = [(Id, Id)] -> NetlistMonad [(Id, Id)]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
go :: Text -> [Id] -> [Either Term Type] -> [BlackBox] -> NetlistMonad [(Id, Id)]
go :: Text
-> [Id]
-> [Either Term Type]
-> [BlackBox]
-> NetlistMonad [(Id, Id)]
go Text
nm [Id]
is0 [Either Term Type]
bbArgs [BlackBox]
bbResultTemplates = do
(BlackBoxContext
bbCtx, [Declaration]
_) <- NetlistMonad (BlackBoxContext, [Declaration])
-> NetlistMonad (BlackBoxContext, [Declaration])
forall a. NetlistMonad a -> NetlistMonad a
preserveVarEnv (HasCallStack =>
Text
-> [Id]
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
Text
-> [Id]
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext Text
nm [Id]
is0 [Either Term Type]
bbArgs)
SomeBackend
be <- Getting SomeBackend NetlistState SomeBackend
-> NetlistMonad SomeBackend
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting SomeBackend NetlistState SomeBackend
Lens' NetlistState SomeBackend
backend
let
_sameName :: Var a -> Var a -> IsVoid
_sameName Var a
i0 Var a
i1 = Name a -> Text
forall a. Name a -> Text
nameOcc (Var a -> Name a
forall a. Var a -> Name a
varName Var a
i0) Text -> Text -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Name a -> Text
forall a. Name a -> Text
nameOcc (Var a -> Name a
forall a. Var a -> Name a
varName Var a
i1)
newNames :: [Text]
newNames = (BlackBox -> Text) -> [BlackBox] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (HasCallStack => SomeBackend -> BlackBoxContext -> BlackBox -> Text
SomeBackend -> BlackBoxContext -> BlackBox -> Text
evalBlackBox SomeBackend
be BlackBoxContext
bbCtx) [BlackBox]
bbResultTemplates
modName :: Text -> Var a -> Var a
modName Text
newRetName = (Name a -> Name a) -> Var a -> Var a
forall a. (Name a -> Name a) -> Var a -> Var a
modifyVarName (\Name a
n -> Name a
n {nameOcc :: Text
nameOcc = Text
newRetName})
is1 :: [Id]
is1 = (Text -> Id -> Id) -> [Text] -> [Id] -> [Id]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Text -> Id -> Id
forall a. Text -> Var a -> Var a
modName [Text]
newNames [Id]
is0
[(Id, Id)] -> NetlistMonad [(Id, Id)]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
is0 [Id]
is1)
evalBlackBox :: HasCallStack => SomeBackend -> BlackBoxContext -> BlackBox -> Text
evalBlackBox :: SomeBackend -> BlackBoxContext -> BlackBox -> Text
evalBlackBox (SomeBackend backend
s) BlackBoxContext
bbCtx BlackBox
bb
| BBFunction String
_bbName Int
_bbHash (TemplateFunction [Int]
_usedArgs BlackBoxContext -> IsVoid
_verifFunc forall s. Backend s => BlackBoxContext -> State s (Doc ())
func) <- BlackBox
bb =
let layout :: LayoutOptions
layout = PageWidth -> LayoutOptions
LayoutOptions (Int -> Double -> PageWidth
AvailablePerLine Int
120 Double
0.4) in
Text -> Text
toStrict (SimpleDocStream () -> Text
forall ann. SimpleDocStream ann -> Text
renderLazy (LayoutOptions -> Doc () -> SimpleDocStream ()
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
layout (State backend (Doc ()) -> backend -> Doc ()
forall s a. State s a -> s -> a
State.evalState (BlackBoxContext -> State backend (Doc ())
forall s. Backend s => BlackBoxContext -> State s (Doc ())
func BlackBoxContext
bbCtx) backend
s)))
| BBTemplate BlackBoxTemplate
bbt <- BlackBox
bb =
Text -> Text
toStrict ((State backend (Int -> Text) -> backend -> Int -> Text
forall s a. State s a -> s -> a
State.evalState (BlackBoxContext -> BlackBoxTemplate -> State backend (Int -> Text)
forall backend.
Backend backend =>
BlackBoxContext -> BlackBoxTemplate -> State backend (Int -> Text)
renderTemplate BlackBoxContext
bbCtx BlackBoxTemplate
bbt) backend
s) Int
0)
mkUniqueArguments
:: Subst
-> Maybe (ExpandedTopEntity Identifier)
-> [Id]
-> NetlistMonad
( [Bool]
, [(Identifier,HWType)]
, [Declaration]
, Subst
)
mkUniqueArguments :: Subst
-> Maybe (ExpandedTopEntity Identifier)
-> [Id]
-> NetlistMonad
([IsVoid], [(Identifier, HWType)], [Declaration], Subst)
mkUniqueArguments Subst
subst0 Maybe (ExpandedTopEntity Identifier)
Nothing [Id]
args = do
([Id]
args', Subst
subst1) <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique Subst
subst0 [Id]
args
[Maybe (Identifier, HWType)]
ports <- (Id -> NetlistMonad (Maybe (Identifier, HWType)))
-> [Id] -> NetlistMonad [Maybe (Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Id -> NetlistMonad (Maybe (Identifier, HWType))
idToInPort [Id]
args'
([IsVoid], [(Identifier, HWType)], [Declaration], Subst)
-> NetlistMonad
([IsVoid], [(Identifier, HWType)], [Declaration], Subst)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Maybe (Identifier, HWType) -> IsVoid)
-> [Maybe (Identifier, HWType)] -> [IsVoid]
forall a b. (a -> b) -> [a] -> [b]
map Maybe (Identifier, HWType) -> IsVoid
forall a. Maybe a -> IsVoid
isNothing [Maybe (Identifier, HWType)]
ports, [Maybe (Identifier, HWType)] -> [(Identifier, HWType)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Identifier, HWType)]
ports, [], Subst
subst1)
mkUniqueArguments Subst
subst0 (Just (ExpandedTopEntity{[Maybe (ExpandedPortName Identifier)]
Maybe (ExpandedPortName Identifier)
et_output :: forall a. ExpandedTopEntity a -> Maybe (ExpandedPortName a)
et_inputs :: forall a. ExpandedTopEntity a -> [Maybe (ExpandedPortName a)]
et_output :: Maybe (ExpandedPortName Identifier)
et_inputs :: [Maybe (ExpandedPortName Identifier)]
..})) [Id]
args = do
([[(Identifier, HWType)]]
ports, [[Declaration]]
decls, [(Id, LetBinding)]
subst1) <- ([([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
-> ([[(Identifier, HWType)]], [[Declaration]], [(Id, LetBinding)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
-> ([[(Identifier, HWType)]], [[Declaration]], [(Id, LetBinding)]))
-> ([Maybe
([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
-> [([(Identifier, HWType)], [Declaration], (Id, LetBinding))])
-> [Maybe
([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
-> ([[(Identifier, HWType)]], [[Declaration]], [(Id, LetBinding)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
-> [([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
forall a. [Maybe a] -> [a]
catMaybes) ([Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
-> ([[(Identifier, HWType)]], [[Declaration]], [(Id, LetBinding)]))
-> NetlistMonad
[Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
-> NetlistMonad
([[(Identifier, HWType)]], [[Declaration]], [(Id, LetBinding)])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe (ExpandedPortName Identifier)
-> Id
-> NetlistMonad
(Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))))
-> [Maybe (ExpandedPortName Identifier)]
-> [Id]
-> NetlistMonad
[Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Maybe (ExpandedPortName Identifier)
-> Id
-> NetlistMonad
(Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding)))
go [Maybe (ExpandedPortName Identifier)]
et_inputs [Id]
args
([IsVoid], [(Identifier, HWType)], [Declaration], Subst)
-> NetlistMonad
([IsVoid], [(Identifier, HWType)], [Declaration], Subst)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ( (Maybe (ExpandedPortName Identifier) -> IsVoid)
-> [Maybe (ExpandedPortName Identifier)] -> [IsVoid]
forall a b. (a -> b) -> [a] -> [b]
map Maybe (ExpandedPortName Identifier) -> IsVoid
forall a. Maybe a -> IsVoid
isNothing [Maybe (ExpandedPortName Identifier)]
et_inputs
, [[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports
, [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls
, Subst -> [Id] -> Subst
extendInScopeIdList (Subst -> [LetBinding] -> Subst
extendIdSubstList Subst
subst0 (((Id, LetBinding) -> LetBinding)
-> [(Id, LetBinding)] -> [LetBinding]
forall a b. (a -> b) -> [a] -> [b]
map (Id, LetBinding) -> LetBinding
forall a b. (a, b) -> b
snd [(Id, LetBinding)]
subst1))
(((Id, LetBinding) -> Id) -> [(Id, LetBinding)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, LetBinding) -> Id
forall a b. (a, b) -> a
fst [(Id, LetBinding)]
subst1))
where
go :: Maybe (ExpandedPortName Identifier)
-> Id
-> NetlistMonad
(Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding)))
go Maybe (ExpandedPortName Identifier)
Nothing Id
_var =
Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))
-> NetlistMonad
(Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding)))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))
forall a. Maybe a
Nothing
go (Just ExpandedPortName Identifier
port) Id
var = do
([(Identifier, HWType)]
ports, [Declaration]
decls, Expr
_, Identifier
portI) <- ExpandedPortName Identifier
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkTopInput ExpandedPortName Identifier
port
let portName :: Text
portName = Identifier -> Text
Id.toText Identifier
portI
pId :: Id
pId = Type -> Name Term -> Id
mkLocalId (Id -> Type
forall a. HasType a => a -> Type
coreTypeOf Id
var) (Text -> Name Term -> Name Term
forall a. Text -> Name a -> Name a
setRepName Text
portName (Id -> Name Term
forall a. Var a -> Name a
varName Id
var))
Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))
-> NetlistMonad
(Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (([(Identifier, HWType)], [Declaration], (Id, LetBinding))
-> Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))
forall a. a -> Maybe a
Just ([(Identifier, HWType)]
ports, [Declaration]
decls, (Id
pId, (Id
var, Id -> Term
Var Id
pId))))
mkUniqueResult
:: Subst
-> Maybe (ExpandedTopEntity Identifier)
-> Id
-> NetlistMonad (Maybe ([(Identifier,HWType)],[Declaration],Id,Subst))
mkUniqueResult :: Subst
-> Maybe (ExpandedTopEntity Identifier)
-> Id
-> NetlistMonad
(Maybe ([(Identifier, HWType)], [Declaration], Id, Subst))
mkUniqueResult Subst
subst0 Maybe (ExpandedTopEntity Identifier)
Nothing Id
res = do
([Id
res'],Subst
subst1) <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique Subst
subst0 [Id
res]
Maybe (Identifier, HWType)
portM <- Id -> NetlistMonad (Maybe (Identifier, HWType))
idToOutPort Id
res'
case Maybe (Identifier, HWType)
portM of
Just (Identifier, HWType)
port -> Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
-> NetlistMonad
(Maybe ([(Identifier, HWType)], [Declaration], Id, Subst))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (([(Identifier, HWType)], [Declaration], Id, Subst)
-> Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
forall a. a -> Maybe a
Just ([(Identifier, HWType)
port],[],Id
res',Subst
subst1))
Maybe (Identifier, HWType)
_ -> Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
-> NetlistMonad
(Maybe ([(Identifier, HWType)], [Declaration], Id, Subst))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
forall a. Maybe a
Nothing
mkUniqueResult Subst
_subst0 (Just (ExpandedTopEntity{et_output :: forall a. ExpandedTopEntity a -> Maybe (ExpandedPortName a)
et_output=Maybe (ExpandedPortName Identifier)
Nothing})) Id
_res =
Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
-> NetlistMonad
(Maybe ([(Identifier, HWType)], [Declaration], Id, Subst))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
forall a. Maybe a
Nothing
mkUniqueResult Subst
subst0 (Just (ExpandedTopEntity{et_output :: forall a. ExpandedTopEntity a -> Maybe (ExpandedPortName a)
et_output=Just ExpandedPortName Identifier
iPort})) Id
res = do
(Identifier
_, SrcSpan
sp) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
(FilteredHWType HWType
hwty [[(IsVoid, FilteredHWType)]]
_) <- String -> Type -> NetlistMonad FilteredHWType
unsafeCoreTypeToHWTypeM $(String
curLoc) (Id -> Type
forall a. HasType a => a -> Type
coreTypeOf Id
res)
IsVoid -> NetlistMonad () -> NetlistMonad ()
forall (f :: Type -> Type). Applicative f => IsVoid -> f () -> f ()
when (HWType -> IsVoid
containsBiSignalIn HWType
hwty)
(ClashException -> NetlistMonad ()
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"BiSignalIn cannot be part of a function's result. Use 'readFromBiSignal'.") Maybe String
forall a. Maybe a
Nothing))
([(Identifier, HWType)]
ports, [Declaration]
decls, Identifier
portI) <- ExpandedPortName Identifier
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkTopOutput ExpandedPortName Identifier
iPort
let pO :: Name Term
pO = Text -> Name Term -> Name Term
forall a. Text -> Name a -> Name a
setRepName (Identifier -> Text
Id.toText Identifier
portI) (Id -> Name Term
forall a. Var a -> Name a
varName Id
res)
pOId :: Id
pOId = Type -> Name Term -> Id
mkLocalId (Id -> Type
forall a. HasType a => a -> Type
coreTypeOf Id
res) Name Term
pO
subst1 :: Subst
subst1 = Subst -> Id -> Subst
extendInScopeId (Subst -> Id -> Term -> Subst
extendIdSubst Subst
subst0 Id
res (Id -> Term
Var Id
pOId)) Id
pOId
Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
-> NetlistMonad
(Maybe ([(Identifier, HWType)], [Declaration], Id, Subst))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (([(Identifier, HWType)], [Declaration], Id, Subst)
-> Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
forall a. a -> Maybe a
Just ([(Identifier, HWType)]
ports, [Declaration]
decls, Id
pOId, Subst
subst1))
idToInPort :: Id -> NetlistMonad (Maybe (Identifier, HWType))
idToInPort :: Id -> NetlistMonad (Maybe (Identifier, HWType))
idToInPort Id
var = do
(Identifier
_, SrcSpan
sp) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
Maybe (Identifier, HWType)
portM <- Id -> NetlistMonad (Maybe (Identifier, HWType))
idToPort Id
var
case Maybe (Identifier, HWType)
portM of
Just (Identifier
_,HWType
hty) -> do
IsVoid -> NetlistMonad () -> NetlistMonad ()
forall (f :: Type -> Type). Applicative f => IsVoid -> f () -> f ()
when (HWType -> IsVoid
containsBiSignalIn HWType
hty IsVoid -> IsVoid -> IsVoid
&& IsVoid -> IsVoid
not (HWType -> IsVoid
isBiSignalIn HWType
hty))
(ClashException -> NetlistMonad ()
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"BiSignalIn currently cannot be part of a composite type when it's a function's argument") Maybe String
forall a. Maybe a
Nothing))
Maybe (Identifier, HWType)
-> NetlistMonad (Maybe (Identifier, HWType))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (Identifier, HWType)
portM
Maybe (Identifier, HWType)
_ -> Maybe (Identifier, HWType)
-> NetlistMonad (Maybe (Identifier, HWType))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (Identifier, HWType)
forall a. Maybe a
Nothing
idToOutPort :: Id -> NetlistMonad (Maybe (Identifier,HWType))
idToOutPort :: Id -> NetlistMonad (Maybe (Identifier, HWType))
idToOutPort Id
var = do
(Identifier
_, SrcSpan
srcspan) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
Maybe (Identifier, HWType)
portM <- Id -> NetlistMonad (Maybe (Identifier, HWType))
idToPort Id
var
case Maybe (Identifier, HWType)
portM of
Just (Identifier
_,HWType
hty) -> do
IsVoid -> NetlistMonad () -> NetlistMonad ()
forall (f :: Type -> Type). Applicative f => IsVoid -> f () -> f ()
when (HWType -> IsVoid
containsBiSignalIn HWType
hty)
(ClashException -> NetlistMonad ()
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
srcspan ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"BiSignalIn cannot be part of a function's result. Use 'readFromBiSignal'.") Maybe String
forall a. Maybe a
Nothing))
Maybe (Identifier, HWType)
-> NetlistMonad (Maybe (Identifier, HWType))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (Identifier, HWType)
portM
Maybe (Identifier, HWType)
_ -> Maybe (Identifier, HWType)
-> NetlistMonad (Maybe (Identifier, HWType))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (Identifier, HWType)
forall a. Maybe a
Nothing
idToPort :: Id -> NetlistMonad (Maybe (Identifier, HWType))
idToPort :: Id -> NetlistMonad (Maybe (Identifier, HWType))
idToPort Id
var = do
HWType
hwTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(String
curLoc) (Id -> Type
forall a. HasType a => a -> Type
coreTypeOf Id
var)
if HWType -> IsVoid
isVoid HWType
hwTy
then Maybe (Identifier, HWType)
-> NetlistMonad (Maybe (Identifier, HWType))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (Identifier, HWType)
forall a. Maybe a
Nothing
else Maybe (Identifier, HWType)
-> NetlistMonad (Maybe (Identifier, HWType))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Identifier, HWType) -> Maybe (Identifier, HWType)
forall a. a -> Maybe a
Just (HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId Id
var, HWType
hwTy))
setRepName :: Text -> Name a -> Name a
setRepName :: Text -> Name a -> Name a
setRepName Text
s (Name NameSort
sort' Text
_ Int
i SrcSpan
loc) = NameSort -> Text -> Int -> SrcSpan -> Name a
forall a. NameSort -> Text -> Int -> SrcSpan -> Name a
Name NameSort
sort' Text
s Int
i SrcSpan
loc
mkUnique
:: Subst
-> [Id]
-> NetlistMonad ([Id],Subst)
mkUnique :: Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique = [Id] -> Subst -> [Id] -> NetlistMonad ([Id], Subst)
go []
where
go :: [Id] -> Subst -> [Id] -> NetlistMonad ([Id],Subst)
go :: [Id] -> Subst -> [Id] -> NetlistMonad ([Id], Subst)
go [Id]
processed Subst
subst [] = ([Id], Subst) -> NetlistMonad ([Id], Subst)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
processed,Subst
subst)
go [Id]
processed subst :: Subst
subst@(Subst InScopeSet
isN IdSubstEnv
_ TvSubstEnv
_ IdSubstEnv
_) (Id
i:[Id]
is) = do
Text
iN <- Identifier -> Text
Id.toText (Identifier -> Text)
-> NetlistMonad Identifier -> NetlistMonad Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Id -> m Identifier
Id.fromCoreId Id
i
let i' :: Id
i' = InScopeSet -> Id -> Id
forall a. (Uniquable a, ClashPretty a) => InScopeSet -> a -> a
uniqAway InScopeSet
isN ((Name Term -> Name Term) -> Id -> Id
forall a. (Name a -> Name a) -> Var a -> Var a
modifyVarName (Text -> Name Term -> Name Term
forall a. Text -> Name a -> Name a
setRepName Text
iN) Id
i)
subst' :: Subst
subst' = Subst -> Id -> Subst
extendInScopeId (Subst -> Id -> Term -> Subst
extendIdSubst Subst
subst Id
i (Id -> Term
Var Id
i')) Id
i'
[Id] -> Subst -> [Id] -> NetlistMonad ([Id], Subst)
go (Id
i'Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
processed)
Subst
subst'
[Id]
is
preserveState
:: NetlistMonad a
-> NetlistMonad a
preserveState :: NetlistMonad a -> NetlistMonad a
preserveState NetlistMonad a
action = do
NetlistState
state <- NetlistMonad NetlistState
forall s (m :: Type -> Type). MonadState s m => m s
State.get
a
val <- NetlistMonad a
action
NetlistState -> NetlistMonad ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
State.put NetlistState
state
a -> NetlistMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
val
preserveVarEnv
:: NetlistMonad a
-> NetlistMonad a
preserveVarEnv :: NetlistMonad a -> NetlistMonad a
preserveVarEnv NetlistMonad a
action = do
(Identifier, SrcSpan)
vComp <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
IdentifierSet
vSeen <- Getting IdentifierSet NetlistState IdentifierSet
-> NetlistMonad IdentifierSet
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting IdentifierSet NetlistState IdentifierSet
Lens' NetlistState IdentifierSet
seenIds
UsageMap
vUses <- Getting UsageMap NetlistState UsageMap -> NetlistMonad UsageMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting UsageMap NetlistState UsageMap
forall s. HasUsageMap s => Lens' s UsageMap
usageMap
a
val <- NetlistMonad a
action
((Identifier, SrcSpan) -> Identity (Identifier, SrcSpan))
-> NetlistState -> Identity NetlistState
Lens' NetlistState (Identifier, SrcSpan)
curCompNm (((Identifier, SrcSpan) -> Identity (Identifier, SrcSpan))
-> NetlistState -> Identity NetlistState)
-> (Identifier, SrcSpan) -> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= (Identifier, SrcSpan)
vComp
(IdentifierSet -> Identity IdentifierSet)
-> NetlistState -> Identity NetlistState
Lens' NetlistState IdentifierSet
seenIds ((IdentifierSet -> Identity IdentifierSet)
-> NetlistState -> Identity NetlistState)
-> IdentifierSet -> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= IdentifierSet
vSeen
(UsageMap -> Identity UsageMap)
-> NetlistState -> Identity NetlistState
forall s. HasUsageMap s => Lens' s UsageMap
usageMap ((UsageMap -> Identity UsageMap)
-> NetlistState -> Identity NetlistState)
-> UsageMap -> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= UsageMap
vUses
a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return a
val
dcToLiteral :: HWType -> Int -> Literal
dcToLiteral :: HWType -> Int -> Literal
dcToLiteral HWType
Bool Int
1 = IsVoid -> Literal
BoolLit IsVoid
False
dcToLiteral HWType
Bool Int
2 = IsVoid -> Literal
BoolLit IsVoid
True
dcToLiteral HWType
_ Int
i = BitMask -> Literal
NumLit (Int -> BitMask
forall a. Integral a => a -> BitMask
toInteger Int
iBitMask -> BitMask -> BitMask
forall a. Num a => a -> a -> a
-BitMask
1)
extendPorts :: [PortName] -> [Maybe PortName]
extendPorts :: [PortName] -> [Maybe PortName]
extendPorts [PortName]
ps = (PortName -> Maybe PortName) -> [PortName] -> [Maybe PortName]
forall a b. (a -> b) -> [a] -> [b]
map PortName -> Maybe PortName
forall a. a -> Maybe a
Just [PortName]
ps [Maybe PortName] -> [Maybe PortName] -> [Maybe PortName]
forall a. [a] -> [a] -> [a]
++ Maybe PortName -> [Maybe PortName]
forall a. a -> [a]
repeat Maybe PortName
forall a. Maybe a
Nothing
prefixParent :: String -> PortName -> PortName
prefixParent :: String -> PortName -> PortName
prefixParent String
"" PortName
p = PortName
p
prefixParent String
parent (PortName String
p) = String -> PortName
PortName (String
parent String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
p)
prefixParent String
parent (PortProduct String
"" [PortName]
ps) = String -> [PortName] -> PortName
PortProduct String
parent [PortName]
ps
prefixParent String
parent (PortProduct String
p [PortName]
ps) = String -> [PortName] -> PortName
PortProduct (String
parent String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
p) [PortName]
ps
mkInit
:: HasCallStack
=> DeclarationType
-> Usage
-> Identifier
-> HWType
-> Expr
-> NetlistMonad [Declaration]
mkInit :: DeclarationType
-> Usage
-> Identifier
-> HWType
-> Expr
-> NetlistMonad [Declaration]
mkInit DeclarationType
_ Usage
_ Identifier
i HWType
ty Expr
e
| Expr -> IsVoid
isConstExpr Expr
e
= [Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [Maybe Text -> Identifier -> HWType -> Maybe Expr -> Declaration
NetDecl' Maybe Text
forall a. Maybe a
Nothing Identifier
i HWType
ty (Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
e)]
mkInit DeclarationType
Concurrent Usage
Cont Identifier
i HWType
ty Expr
e = do
(UsageMap -> Identity UsageMap)
-> NetlistState -> Identity NetlistState
forall s. HasUsageMap s => Lens' s UsageMap
usageMap ((UsageMap -> Identity UsageMap)
-> NetlistState -> Identity NetlistState)
-> (UsageMap -> UsageMap) -> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Text -> Usage -> UsageMap -> UsageMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Identifier -> Text
Id.toText Identifier
i) Usage
Cont
[Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [Maybe Text -> Identifier -> HWType -> Maybe Expr -> Declaration
NetDecl' Maybe Text
forall a. Maybe a
Nothing Identifier
i HWType
ty Maybe Expr
forall a. Maybe a
Nothing, Identifier -> Usage -> Expr -> Declaration
Assignment Identifier
i Usage
Cont Expr
e]
mkInit DeclarationType
Concurrent Usage
proc Identifier
i HWType
ty Expr
e = do
(UsageMap -> Identity UsageMap)
-> NetlistState -> Identity NetlistState
forall s. HasUsageMap s => Lens' s UsageMap
usageMap ((UsageMap -> Identity UsageMap)
-> NetlistState -> Identity NetlistState)
-> (UsageMap -> UsageMap) -> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Text -> Usage -> UsageMap -> UsageMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Identifier -> Text
Id.toText Identifier
i) Usage
proc
[Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure
[ Maybe Text -> Identifier -> HWType -> Maybe Expr -> Declaration
NetDecl' Maybe Text
forall a. Maybe a
Nothing Identifier
i HWType
ty Maybe Expr
forall a. Maybe a
Nothing
, [Seq] -> Declaration
Seq [[Seq] -> Seq
Initial [Declaration -> Seq
SeqDecl (Identifier -> Usage -> Expr -> Declaration
Assignment Identifier
i Usage
proc Expr
e)]]
]
mkInit DeclarationType
Sequential Usage
Cont Identifier
_ HWType
_ Expr
_ =
String -> NetlistMonad [Declaration]
forall a. HasCallStack => String -> a
error String
"mkInit: Cannot continuously assign in a sequential block"
mkInit DeclarationType
Sequential Usage
proc Identifier
i HWType
ty Expr
e = do
(UsageMap -> Identity UsageMap)
-> NetlistState -> Identity NetlistState
forall s. HasUsageMap s => Lens' s UsageMap
usageMap ((UsageMap -> Identity UsageMap)
-> NetlistState -> Identity NetlistState)
-> (UsageMap -> UsageMap) -> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Text -> Usage -> UsageMap -> UsageMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Identifier -> Text
Id.toText Identifier
i) Usage
proc
[Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure
[ Maybe Text -> Identifier -> HWType -> Maybe Expr -> Declaration
NetDecl' Maybe Text
forall a. Maybe a
Nothing Identifier
i HWType
ty Maybe Expr
forall a. Maybe a
Nothing
, [Seq] -> Declaration
Seq [Declaration -> Seq
SeqDecl (Identifier -> Usage -> Expr -> Declaration
Assignment Identifier
i Usage
proc Expr
e)]
]
canUse :: HDL -> Usage -> Usage -> Bool
canUse :: HDL -> Usage -> Usage -> IsVoid
canUse HDL
VHDL (Proc Blocking
Blocking) = \case
Proc Blocking
Blocking -> IsVoid
True
Usage
_ -> IsVoid
False
canUse HDL
VHDL Usage
_ = \case
Proc Blocking
Blocking -> IsVoid
False
Usage
_ -> IsVoid
True
canUse HDL
_ Usage
Cont = \case
Usage
Cont -> IsVoid
True
Usage
_ -> IsVoid
False
canUse HDL
_ Usage
_ = \case
Usage
Cont -> IsVoid
False
Usage
_ -> IsVoid
True
declareUse :: Usage -> Identifier -> NetlistMonad ()
declareUse :: Usage -> Identifier -> NetlistMonad ()
declareUse Usage
u Identifier
i = (UsageMap -> Identity UsageMap)
-> NetlistState -> Identity NetlistState
forall s. HasUsageMap s => Lens' s UsageMap
usageMap ((UsageMap -> Identity UsageMap)
-> NetlistState -> Identity NetlistState)
-> (UsageMap -> UsageMap) -> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Usage -> Usage -> Usage) -> Text -> Usage -> UsageMap -> UsageMap
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Usage -> Usage -> Usage
forall a. Semigroup a => a -> a -> a
(<>) (Identifier -> Text
Id.toText Identifier
i) Usage
u
declareUseOnce :: HasUsageMap s => Usage -> Identifier -> State.State s ()
declareUseOnce :: Usage -> Identifier -> State s ()
declareUseOnce Usage
u Identifier
i = (UsageMap -> Identity UsageMap) -> s -> Identity s
forall s. HasUsageMap s => Lens' s UsageMap
usageMap ((UsageMap -> Identity UsageMap) -> s -> Identity s)
-> (UsageMap -> UsageMap) -> State s ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Maybe Usage -> Maybe Usage) -> Text -> UsageMap -> UsageMap
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe Usage -> Maybe Usage
forall a. Maybe a -> Maybe Usage
go (Identifier -> Text
Id.toText Identifier
i)
where
go :: Maybe a -> Maybe Usage
go Maybe a
Nothing = Usage -> Maybe Usage
forall a. a -> Maybe a
Just Usage
u
go Just{} = String -> Maybe Usage
forall a. HasCallStack => String -> a
error (String
"Internal error: unexpected re-declaration of usage for" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Identifier -> String
forall a. Show a => a -> String
show Identifier
i)
declareInstUses
:: [(Expr, PortDirection, HWType, Expr)]
-> NetlistMonad ()
declareInstUses :: [(Expr, PortDirection, HWType, Expr)] -> NetlistMonad ()
declareInstUses =
((Expr, PortDirection, HWType, Expr) -> NetlistMonad ())
-> [(Expr, PortDirection, HWType, Expr)] -> NetlistMonad ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Expr, PortDirection, HWType, Expr) -> NetlistMonad ()
forall c.
Show c =>
(Expr, PortDirection, c, Expr) -> NetlistMonad ()
declare
where
declare :: (Expr, PortDirection, c, Expr) -> NetlistMonad ()
declare (Identifier Identifier
_ Maybe Modifier
_, PortDirection
Out, c
_, Identifier Identifier
n Maybe Modifier
_) =
Usage -> Identifier -> NetlistMonad ()
declareUse Usage
Cont Identifier
n
declare (Expr
_, PortDirection
In, c
_, Expr
_) =
() -> NetlistMonad ()
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
declare (Expr, PortDirection, c, Expr)
portMapping =
String -> NetlistMonad ()
forall a. HasCallStack => String -> a
error (String
"declareInstUses: Unexpected port mapping: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Expr, PortDirection, c, Expr) -> String
forall a. Show a => a -> String
show (Expr, PortDirection, c, Expr)
portMapping)
assignmentWith
:: HasCallStack
=> (Identifier -> Declaration)
-> Usage
-> Identifier
-> NetlistMonad Declaration
assignmentWith :: (Identifier -> Declaration)
-> Usage -> Identifier -> NetlistMonad Declaration
assignmentWith Identifier -> Declaration
assign Usage
new Identifier
i = do
UsageMap
u <- Getting UsageMap NetlistState UsageMap -> NetlistMonad UsageMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting UsageMap NetlistState UsageMap
forall s. HasUsageMap s => Lens' s UsageMap
usageMap
SomeBackend backend
b <- Getting SomeBackend NetlistState SomeBackend
-> NetlistMonad SomeBackend
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting SomeBackend NetlistState SomeBackend
Lens' NetlistState SomeBackend
backend
case Identifier -> UsageMap -> Maybe Usage
lookupUsage Identifier
i UsageMap
u of
Just Usage
old | IsVoid -> IsVoid
not (IsVoid -> IsVoid) -> IsVoid -> IsVoid
forall a b. (a -> b) -> a -> b
$ HDL -> Usage -> Usage -> IsVoid
canUse (backend -> HDL
forall state. Backend state => state -> HDL
hdlKind backend
b) Usage
new Usage
old ->
String -> NetlistMonad Declaration
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Declaration)
-> String -> NetlistMonad Declaration
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
[ String
"assignmentWith: Cannot assign as "
, Usage -> String
forall a. Show a => a -> String
show Usage
new
, String
" after "
, Usage -> String
forall a. Show a => a -> String
show Usage
old
, String
" for "
, Identifier -> String
forall a. Show a => a -> String
show Identifier
i
]
Maybe Usage
_ ->
Usage -> Identifier -> NetlistMonad ()
declareUse Usage
new Identifier
i NetlistMonad () -> Declaration -> NetlistMonad Declaration
forall (f :: Type -> Type) a b. Functor f => f a -> b -> f b
$> Identifier -> Declaration
assign Identifier
i
contAssign
:: HasCallStack
=> Identifier
-> Expr
-> NetlistMonad Declaration
contAssign :: Identifier -> Expr -> NetlistMonad Declaration
contAssign Identifier
dst Expr
expr =
HasCallStack =>
(Identifier -> Declaration)
-> Usage -> Identifier -> NetlistMonad Declaration
(Identifier -> Declaration)
-> Usage -> Identifier -> NetlistMonad Declaration
assignmentWith (\Identifier
i -> Identifier -> Usage -> Expr -> Declaration
Assignment Identifier
i Usage
Cont Expr
expr) Usage
Cont Identifier
dst
procAssign
:: HasCallStack
=> Blocking
-> Identifier
-> Expr
-> NetlistMonad Declaration
procAssign :: Blocking -> Identifier -> Expr -> NetlistMonad Declaration
procAssign Blocking
block Identifier
dst Expr
expr =
HasCallStack =>
(Identifier -> Declaration)
-> Usage -> Identifier -> NetlistMonad Declaration
(Identifier -> Declaration)
-> Usage -> Identifier -> NetlistMonad Declaration
assignmentWith (\Identifier
i -> Identifier -> Usage -> Expr -> Declaration
Assignment Identifier
i (Blocking -> Usage
Proc Blocking
block) Expr
expr) (Blocking -> Usage
Proc Blocking
block) Identifier
dst
condAssign
:: Identifier
-> HWType
-> Expr
-> HWType
-> [(Maybe Literal, Expr)]
-> NetlistMonad Declaration
condAssign :: Identifier
-> HWType
-> Expr
-> HWType
-> [(Maybe Literal, Expr)]
-> NetlistMonad Declaration
condAssign Identifier
dst HWType
dstTy Expr
scrut HWType
scrutTy [(Maybe Literal, Expr)]
alts = do
SomeBackend backend
b <- Getting SomeBackend NetlistState SomeBackend
-> NetlistMonad SomeBackend
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting SomeBackend NetlistState SomeBackend
Lens' NetlistState SomeBackend
backend
let use :: Usage
use = case backend -> HDL
forall state. Backend state => state -> HDL
hdlKind backend
b of { HDL
VHDL -> Usage
Cont ; HDL
_ -> Blocking -> Usage
Proc Blocking
Blocking }
HasCallStack =>
(Identifier -> Declaration)
-> Usage -> Identifier -> NetlistMonad Declaration
(Identifier -> Declaration)
-> Usage -> Identifier -> NetlistMonad Declaration
assignmentWith (\Identifier
i -> Identifier
-> HWType
-> Expr
-> HWType
-> [(Maybe Literal, Expr)]
-> Declaration
CondAssignment Identifier
i HWType
dstTy Expr
scrut HWType
scrutTy [(Maybe Literal, Expr)]
alts) Usage
use Identifier
dst
convPrimitiveType :: HWType -> a -> NetlistMonad a -> NetlistMonad a
convPrimitiveType :: HWType -> a -> NetlistMonad a -> NetlistMonad a
convPrimitiveType HWType
hwty a
a NetlistMonad a
action = do
SomeBackend
b <- Getting SomeBackend NetlistState SomeBackend
-> NetlistMonad SomeBackend
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting SomeBackend NetlistState SomeBackend
Lens' NetlistState SomeBackend
backend
let kind :: HWKind
kind = case SomeBackend
b of {SomeBackend backend
s -> State backend HWKind -> backend -> HWKind
forall s a. State s a -> s -> a
State.evalState (HWType -> State backend HWKind
forall state. Backend state => HWType -> State state HWKind
hdlHWTypeKind HWType
hwty) backend
s}
case HWKind
kind of
HWKind
UserType -> NetlistMonad a
action
HWKind
SynonymType -> a -> NetlistMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
a
HWKind
PrimitiveType -> a -> NetlistMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
a
toPrimitiveType
:: Identifier
-> HWType
-> NetlistMonad ([Declaration], Identifier, Expr, HWType)
toPrimitiveType :: Identifier
-> HWType -> NetlistMonad ([Declaration], Identifier, Expr, HWType)
toPrimitiveType Identifier
id0 HWType
hwty0 = HWType
-> ([Declaration], Identifier, Expr, HWType)
-> NetlistMonad ([Declaration], Identifier, Expr, HWType)
-> NetlistMonad ([Declaration], Identifier, Expr, HWType)
forall a. HWType -> a -> NetlistMonad a -> NetlistMonad a
convPrimitiveType HWType
hwty0 ([Declaration], Identifier, Expr, HWType)
forall a. ([a], Identifier, Expr, HWType)
dflt (NetlistMonad ([Declaration], Identifier, Expr, HWType)
-> NetlistMonad ([Declaration], Identifier, Expr, HWType))
-> NetlistMonad ([Declaration], Identifier, Expr, HWType)
-> NetlistMonad ([Declaration], Identifier, Expr, HWType)
forall a b. (a -> b) -> a -> b
$ do
Identifier
id1 <- Identifier -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Identifier -> m Identifier
Id.next Identifier
id0
[Declaration]
ds <- HasCallStack =>
DeclarationType
-> Usage
-> Identifier
-> HWType
-> Expr
-> NetlistMonad [Declaration]
DeclarationType
-> Usage
-> Identifier
-> HWType
-> Expr
-> NetlistMonad [Declaration]
mkInit DeclarationType
Concurrent Usage
Cont Identifier
id1 HWType
hwty1 Expr
expr
([Declaration], Identifier, Expr, HWType)
-> NetlistMonad ([Declaration], Identifier, Expr, HWType)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Declaration]
ds, Identifier
id1, Expr
expr, HWType
hwty1)
where
dflt :: ([a], Identifier, Expr, HWType)
dflt = ([], Identifier
id0, Identifier -> Maybe Modifier -> Expr
Identifier Identifier
id0 Maybe Modifier
forall a. Maybe a
Nothing, HWType
hwty0)
hwty1 :: HWType
hwty1 = Int -> HWType
BitVector (HWType -> Int
typeSize HWType
hwty0)
expr :: Expr
expr = Maybe Identifier -> HWType -> Expr -> Expr
ToBv Maybe Identifier
forall a. Maybe a
Nothing HWType
hwty0 (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
id0 Maybe Modifier
forall a. Maybe a
Nothing)
fromPrimitiveType
:: Identifier
-> HWType
-> NetlistMonad ([Declaration], Identifier, Expr, HWType)
fromPrimitiveType :: Identifier
-> HWType -> NetlistMonad ([Declaration], Identifier, Expr, HWType)
fromPrimitiveType Identifier
id0 HWType
hwty0 = HWType
-> ([Declaration], Identifier, Expr, HWType)
-> NetlistMonad ([Declaration], Identifier, Expr, HWType)
-> NetlistMonad ([Declaration], Identifier, Expr, HWType)
forall a. HWType -> a -> NetlistMonad a -> NetlistMonad a
convPrimitiveType HWType
hwty0 ([Declaration], Identifier, Expr, HWType)
forall a. ([a], Identifier, Expr, HWType)
dflt (NetlistMonad ([Declaration], Identifier, Expr, HWType)
-> NetlistMonad ([Declaration], Identifier, Expr, HWType))
-> NetlistMonad ([Declaration], Identifier, Expr, HWType)
-> NetlistMonad ([Declaration], Identifier, Expr, HWType)
forall a b. (a -> b) -> a -> b
$ do
Identifier
id1 <- Identifier -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Identifier -> m Identifier
Id.next Identifier
id0
[Declaration]
ds <- HasCallStack =>
DeclarationType
-> Usage
-> Identifier
-> HWType
-> Expr
-> NetlistMonad [Declaration]
DeclarationType
-> Usage
-> Identifier
-> HWType
-> Expr
-> NetlistMonad [Declaration]
mkInit DeclarationType
Concurrent Usage
Cont Identifier
id1 HWType
hwty0 Expr
expr
([Declaration], Identifier, Expr, HWType)
-> NetlistMonad ([Declaration], Identifier, Expr, HWType)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Declaration]
ds, Identifier
id1, Expr
expr, HWType
hwty1)
where
dflt :: ([a], Identifier, Expr, HWType)
dflt = ([], Identifier
id0, Identifier -> Maybe Modifier -> Expr
Identifier Identifier
id0 Maybe Modifier
forall a. Maybe a
Nothing, HWType
hwty0)
hwty1 :: HWType
hwty1 = Int -> HWType
BitVector (HWType -> Int
typeSize HWType
hwty0)
expr :: Expr
expr = Maybe Identifier -> HWType -> Expr -> Expr
FromBv Maybe Identifier
forall a. Maybe a
Nothing HWType
hwty0 (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
id0 Maybe Modifier
forall a. Maybe a
Nothing)
mkTopInput
:: ExpandedPortName Identifier
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkTopInput :: ExpandedPortName Identifier
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkTopInput (ExpandedPortName HWType
hwty0 Identifier
i0) = do
([Declaration]
decls, Identifier
i1, Expr
expr, HWType
hwty1) <- Identifier
-> HWType -> NetlistMonad ([Declaration], Identifier, Expr, HWType)
fromPrimitiveType Identifier
i0 HWType
hwty0
([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier
i0, HWType
hwty1)], [Declaration]
decls, Expr
expr, Identifier
i1)
mkTopInput epp :: ExpandedPortName Identifier
epp@(ExpandedPortProduct Text
p HWType
hwty [ExpandedPortName Identifier]
ps) = do
Identifier
pN <- Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic Text
p
case HWType
hwty of
Vector Int
sz HWType
eHwty -> do
([[(Identifier, HWType)]]
ports, [[Declaration]]
_, [Expr]
exprs, [Identifier]
_) <- [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
[Identifier])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 ([([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
[Identifier]))
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> NetlistMonad
([[(Identifier, HWType)]], [[Declaration]], [Expr], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Expr, Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkTopInput [ExpandedPortName Identifier]
ps
let vecExpr :: Expr
vecExpr = Int -> HWType -> [Expr] -> Expr
mkVectorChain Int
sz HWType
eHwty [Expr]
exprs
[Declaration]
decls <- HasCallStack =>
DeclarationType
-> Usage
-> Identifier
-> HWType
-> Expr
-> NetlistMonad [Declaration]
DeclarationType
-> Usage
-> Identifier
-> HWType
-> Expr
-> NetlistMonad [Declaration]
mkInit DeclarationType
Concurrent Usage
Cont Identifier
pN HWType
hwty Expr
vecExpr
([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports, [Declaration]
decls, Expr
vecExpr, Identifier
pN)
RTree Int
d HWType
eHwty -> do
([[(Identifier, HWType)]]
ports, [[Declaration]]
_, [Expr]
exprs, [Identifier]
_) <- [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
[Identifier])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 ([([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
[Identifier]))
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> NetlistMonad
([[(Identifier, HWType)]], [[Declaration]], [Expr], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Expr, Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkTopInput [ExpandedPortName Identifier]
ps
let trExpr :: Expr
trExpr = Int -> HWType -> [Expr] -> Expr
mkRTreeChain Int
d HWType
eHwty [Expr]
exprs
[Declaration]
decls <- HasCallStack =>
DeclarationType
-> Usage
-> Identifier
-> HWType
-> Expr
-> NetlistMonad [Declaration]
DeclarationType
-> Usage
-> Identifier
-> HWType
-> Expr
-> NetlistMonad [Declaration]
mkInit DeclarationType
Concurrent Usage
Cont Identifier
pN HWType
hwty Expr
trExpr
([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports, [Declaration]
decls, Expr
trExpr, Identifier
pN)
Product Text
_ Maybe [Text]
_ [HWType]
_ -> do
([[(Identifier, HWType)]]
ports, [[Declaration]]
_, [Expr]
exprs, [Identifier]
_) <- [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
[Identifier])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 ([([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
[Identifier]))
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> NetlistMonad
([[(Identifier, HWType)]], [[Declaration]], [Expr], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Expr, Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkTopInput [ExpandedPortName Identifier]
ps
case [Expr]
exprs of
[Expr
expr] -> do
[Declaration]
decls <- HasCallStack =>
DeclarationType
-> Usage
-> Identifier
-> HWType
-> Expr
-> NetlistMonad [Declaration]
DeclarationType
-> Usage
-> Identifier
-> HWType
-> Expr
-> NetlistMonad [Declaration]
mkInit DeclarationType
Concurrent Usage
Cont Identifier
pN HWType
hwty Expr
expr
([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports, [Declaration]
decls, Expr
expr, Identifier
pN)
[Expr]
_ -> do
let dcExpr :: Expr
dcExpr = HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
hwty ((HWType, Int) -> Modifier
DC (HWType
hwty, Int
0)) [Expr]
exprs
[Declaration]
decls <- HasCallStack =>
DeclarationType
-> Usage
-> Identifier
-> HWType
-> Expr
-> NetlistMonad [Declaration]
DeclarationType
-> Usage
-> Identifier
-> HWType
-> Expr
-> NetlistMonad [Declaration]
mkInit DeclarationType
Concurrent Usage
Cont Identifier
pN HWType
hwty Expr
dcExpr
([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports, [Declaration]
decls, Expr
dcExpr, Identifier
pN)
SP Text
_ (([[HWType]] -> [HWType]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[HWType]] -> [HWType])
-> ([(Text, [HWType])] -> [[HWType]])
-> [(Text, [HWType])]
-> [HWType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, [HWType]) -> [HWType]) -> [(Text, [HWType])] -> [[HWType]]
forall a b. (a -> b) -> [a] -> [b]
map (Text, [HWType]) -> [HWType]
forall a b. (a, b) -> b
snd) -> [HWType
elTy]) -> do
([[(Identifier, HWType)]]
ports, [[Declaration]]
_, [Expr]
exprs, [Identifier]
_) <- [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
[Identifier])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 ([([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
[Identifier]))
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> NetlistMonad
([[(Identifier, HWType)]], [[Declaration]], [Expr], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Expr, Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkTopInput [ExpandedPortName Identifier]
ps
case [Expr]
exprs of
[Expr
conExpr, Expr
elExpr] -> do
let dcExpr :: Expr
dcExpr = HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
hwty ((HWType, Int) -> Modifier
DC (Int -> HWType
BitVector (HWType -> Int
typeSize HWType
hwty), Int
0))
[Expr
conExpr, Maybe Identifier -> HWType -> Expr -> Expr
ToBv Maybe Identifier
forall a. Maybe a
Nothing HWType
elTy Expr
elExpr]
[Declaration]
decls <- HasCallStack =>
DeclarationType
-> Usage
-> Identifier
-> HWType
-> Expr
-> NetlistMonad [Declaration]
DeclarationType
-> Usage
-> Identifier
-> HWType
-> Expr
-> NetlistMonad [Declaration]
mkInit DeclarationType
Concurrent Usage
Cont Identifier
pN HWType
hwty Expr
dcExpr
([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports, [Declaration]
decls, Expr
dcExpr, Identifier
pN)
[Expr]
_ -> String
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall a. HasCallStack => String -> a
error (String
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> String
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Internal error"
HWType
_ ->
String
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall a. HasCallStack => String -> a
error (String
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> String
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Internal error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExpandedPortName Identifier -> String
forall a. Show a => a -> String
show ExpandedPortName Identifier
epp
portProductError :: String -> HWType -> ExpandedPortName Identifier -> a
portProductError :: String -> HWType -> ExpandedPortName Identifier -> a
portProductError String
loc HWType
hwty ExpandedPortName Identifier
portProduct = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ [I.i|
#{loc}PortProduct used, but did not see Vector, RTree, or Product. Saw the
following instead:
#{hwty}
PortProduct used:
#{portProduct}
Note that the PortProduct as shown above might is only indicative, and might
not correspond exactly to the one given in the Clash design. |]
mkVectorChain :: Int
-> HWType
-> [Expr]
-> Expr
mkVectorChain :: Int -> HWType -> [Expr] -> Expr
mkVectorChain Int
_ HWType
elTy [] = HWType -> Modifier -> [Expr] -> Expr
DataCon (Int -> HWType -> HWType
Vector Int
0 HWType
elTy) Modifier
VecAppend []
mkVectorChain Int
_ HWType
elTy [Expr
e] = HWType -> Modifier -> [Expr] -> Expr
DataCon (Int -> HWType -> HWType
Vector Int
1 HWType
elTy) Modifier
VecAppend
[Expr
e]
mkVectorChain Int
sz HWType
elTy (Expr
e:[Expr]
es) = HWType -> Modifier -> [Expr] -> Expr
DataCon (Int -> HWType -> HWType
Vector Int
sz HWType
elTy) Modifier
VecAppend
[ Expr
e
, Int -> HWType -> [Expr] -> Expr
mkVectorChain (Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) HWType
elTy [Expr]
es
]
mkRTreeChain :: Int
-> HWType
-> [Expr]
-> Expr
mkRTreeChain :: Int -> HWType -> [Expr] -> Expr
mkRTreeChain Int
_ HWType
elTy [Expr
e] = HWType -> Modifier -> [Expr] -> Expr
DataCon (Int -> HWType -> HWType
RTree Int
0 HWType
elTy) Modifier
RTreeAppend
[Expr
e]
mkRTreeChain Int
d HWType
elTy [Expr]
es =
let ([Expr]
esL,[Expr]
esR) = Int -> [Expr] -> ([Expr], [Expr])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Expr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Expr]
es Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) [Expr]
es
in HWType -> Modifier -> [Expr] -> Expr
DataCon (Int -> HWType -> HWType
RTree Int
d HWType
elTy) Modifier
RTreeAppend
[ Int -> HWType -> [Expr] -> Expr
mkRTreeChain (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) HWType
elTy [Expr]
esL
, Int -> HWType -> [Expr] -> Expr
mkRTreeChain (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) HWType
elTy [Expr]
esR
]
genComponentName
:: Bool
-> Maybe Text
-> Id
-> Text
genComponentName :: IsVoid -> Maybe Text -> Id -> Text
genComponentName IsVoid
newInlineStrat Maybe Text
prefixM Id
nm =
Text -> [Text] -> Text
Text.intercalate Text
"_" ([Text]
prefix [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
fn1])
where
nm0 :: [Text]
nm0 = Text -> Text -> [Text]
Text.splitOn Text
"." (Name Term -> Text
forall a. Name a -> Text
nameOcc (Id -> Name Term
forall a. Var a -> Name a
varName Id
nm))
fn0 :: Text
fn0 = Text -> Text
Id.stripDollarPrefixes ([Text] -> Text
forall a. [a] -> a
last [Text]
nm0)
fn1 :: Text
fn1 = if Text -> IsVoid
Text.null Text
fn0 then Text
"Component" else Text
fn0
prefix :: [Text]
prefix = [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe (if IsVoid
newInlineStrat then [] else [Text] -> [Text]
forall a. [a] -> [a]
init [Text]
nm0) (Text -> [Text]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Text -> [Text]) -> Maybe Text -> Maybe [Text]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
prefixM)
genTopName
:: IdentifierSetMonad m
=> Maybe Text
-> TopEntity
-> m Identifier
genTopName :: Maybe Text -> TopEntity -> m Identifier
genTopName Maybe Text
prefixM TopEntity
ann =
case Maybe Text
prefixM of
Just Text
prefix | IsVoid -> IsVoid
not (Text -> IsVoid
Text.null Text
prefix) ->
Text -> m Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.addRaw ([Text] -> Text
Text.concat [Text
prefix, Text
"_", String -> Text
Text.pack (TopEntity -> String
t_name TopEntity
ann)])
Maybe Text
_ ->
Text -> m Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.addRaw (String -> Text
Text.pack (TopEntity -> String
t_name TopEntity
ann))
stripAttributes
:: HWType
-> ([Attr Text], HWType)
stripAttributes :: HWType -> ([Attr Text], HWType)
stripAttributes (Annotated [Attr Text]
attrs HWType
typ) =
let ([Attr Text]
attrs', HWType
typ') = HWType -> ([Attr Text], HWType)
stripAttributes HWType
typ
in ([Attr Text]
attrs [Attr Text] -> [Attr Text] -> [Attr Text]
forall a. [a] -> [a] -> [a]
++ [Attr Text]
attrs', HWType
typ')
stripAttributes HWType
typ = ([], HWType
typ)
mkTopOutput
:: ExpandedPortName Identifier
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkTopOutput :: ExpandedPortName Identifier
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkTopOutput (ExpandedPortName HWType
hwty0 Identifier
i0) = do
Identifier
i1 <- Identifier -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Identifier -> m Identifier
Id.next Identifier
i0
([Declaration]
_, Identifier
_, Expr
bvExpr, HWType
hwty1) <- Identifier
-> HWType -> NetlistMonad ([Declaration], Identifier, Expr, HWType)
toPrimitiveType Identifier
i1 HWType
hwty0
if HWType
hwty0 HWType -> HWType -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== HWType
hwty1 then
([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier
i0, HWType
hwty0)], [], Identifier
i0)
else do
Declaration
assn <- HasCallStack => Identifier -> Expr -> NetlistMonad Declaration
Identifier -> Expr -> NetlistMonad Declaration
contAssign Identifier
i0 Expr
bvExpr
([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ( [(Identifier
i0, HWType
hwty1)], [Maybe Text -> Identifier -> HWType -> Maybe Expr -> Declaration
NetDecl' Maybe Text
forall a. Maybe a
Nothing Identifier
i1 HWType
hwty0 Maybe Expr
forall a. Maybe a
Nothing, Declaration
assn], Identifier
i1)
mkTopOutput epp :: ExpandedPortName Identifier
epp@(ExpandedPortProduct Text
p HWType
hwty [ExpandedPortName Identifier]
ps) = do
Identifier
pN <- Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic Text
p
let netdecl :: Declaration
netdecl = Maybe Text -> Identifier -> HWType -> Maybe Expr -> Declaration
NetDecl' Maybe Text
forall a. Maybe a
Nothing Identifier
pN HWType
hwty Maybe Expr
forall a. Maybe a
Nothing
case HWType
hwty of
Vector {} -> do
([[(Identifier, HWType)]]
ports, [[Declaration]]
decls, [Identifier]
ids) <- [([(Identifier, HWType)], [Declaration], Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([(Identifier, HWType)], [Declaration], Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Identifier]))
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Identifier)]
-> NetlistMonad
([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkTopOutput [ExpandedPortName Identifier]
ps
[Declaration]
assigns <- (Identifier -> Int -> NetlistMonad Declaration)
-> [Identifier] -> [Int] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Identifier
i Int
n -> Identifier
-> HWType -> Int -> Identifier -> Int -> NetlistMonad Declaration
assignId Identifier
pN HWType
hwty Int
10 Identifier
i Int
n) [Identifier]
ids [Int
0..]
([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports, Declaration
netdecl Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: [Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls, Identifier
pN)
RTree {} -> do
([[(Identifier, HWType)]]
ports, [[Declaration]]
decls, [Identifier]
ids) <- [([(Identifier, HWType)], [Declaration], Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([(Identifier, HWType)], [Declaration], Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Identifier]))
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Identifier)]
-> NetlistMonad
([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkTopOutput [ExpandedPortName Identifier]
ps
[Declaration]
assigns <- (Identifier -> Int -> NetlistMonad Declaration)
-> [Identifier] -> [Int] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Identifier
i Int
n -> Identifier
-> HWType -> Int -> Identifier -> Int -> NetlistMonad Declaration
assignId Identifier
pN HWType
hwty Int
10 Identifier
i Int
n) [Identifier]
ids [Int
0..]
([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports, Declaration
netdecl Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: [Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls, Identifier
pN)
Product {} -> do
([[(Identifier, HWType)]]
ports, [[Declaration]]
decls, [Identifier]
ids) <- [([(Identifier, HWType)], [Declaration], Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([(Identifier, HWType)], [Declaration], Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Identifier]))
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Identifier)]
-> NetlistMonad
([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkTopOutput [ExpandedPortName Identifier]
ps
case [Identifier]
ids of
[Identifier
i] -> do
Declaration
assn <- HasCallStack => Identifier -> Expr -> NetlistMonad Declaration
Identifier -> Expr -> NetlistMonad Declaration
contAssign Identifier
i (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pN Maybe Modifier
forall a. Maybe a
Nothing)
([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports, Declaration
netdecl Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: Declaration
assn Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls, Identifier
pN)
[Identifier]
_ -> do
[Declaration]
assigns <- (Identifier -> Int -> NetlistMonad Declaration)
-> [Identifier] -> [Int] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Identifier
i Int
n -> Identifier
-> HWType -> Int -> Identifier -> Int -> NetlistMonad Declaration
assignId Identifier
pN HWType
hwty Int
0 Identifier
i Int
n) [Identifier]
ids [Int
0..]
([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports, Declaration
netdecl Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: [Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls, Identifier
pN)
SP Text
_ (([[HWType]] -> [HWType]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[HWType]] -> [HWType])
-> ([(Text, [HWType])] -> [[HWType]])
-> [(Text, [HWType])]
-> [HWType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, [HWType]) -> [HWType]) -> [(Text, [HWType])] -> [[HWType]]
forall a b. (a -> b) -> [a] -> [b]
map (Text, [HWType]) -> [HWType]
forall a b. (a, b) -> b
snd) -> [HWType
elTy]) -> do
([[(Identifier, HWType)]]
ports, [[Declaration]]
decls, [Identifier]
ids) <- [([(Identifier, HWType)], [Declaration], Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([(Identifier, HWType)], [Declaration], Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Identifier]))
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Identifier)]
-> NetlistMonad
([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkTopOutput [ExpandedPortName Identifier]
ps
case [Identifier]
ids of
[Identifier
conId, Identifier
elId] -> do
let conIx :: Modifier
conIx = (HWType, Int, Int) -> Modifier
Sliced ( Int -> HWType
BitVector (HWType -> Int
typeSize HWType
hwty)
, HWType -> Int
typeSize HWType
hwty Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
, HWType -> Int
typeSize HWType
elTy )
elIx :: Modifier
elIx = (HWType, Int, Int) -> Modifier
Sliced ( Int -> HWType
BitVector (HWType -> Int
typeSize HWType
hwty)
, HWType -> Int
typeSize HWType
elTy Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
, Int
0 )
Declaration
conAssgn <- HasCallStack => Identifier -> Expr -> NetlistMonad Declaration
Identifier -> Expr -> NetlistMonad Declaration
contAssign Identifier
conId (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pN (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just Modifier
conIx))
Declaration
elAssgn <- HasCallStack => Identifier -> Expr -> NetlistMonad Declaration
Identifier -> Expr -> NetlistMonad Declaration
contAssign Identifier
elId (Maybe Identifier -> HWType -> Expr -> Expr
FromBv Maybe Identifier
forall a. Maybe a
Nothing HWType
elTy (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pN (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just Modifier
elIx)))
([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports, Declaration
netdeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:Declaration
conAssgnDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:Declaration
elAssgnDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls, Identifier
pN)
[Identifier]
_ -> String
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall a. HasCallStack => String -> a
error (String
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Identifier))
-> String
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Internal error"
HWType
_ -> String
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall a. HasCallStack => String -> a
error (String
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Identifier))
-> String
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Internal error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExpandedPortName Identifier -> String
forall a. Show a => a -> String
show ExpandedPortName Identifier
epp
where
assignId :: Identifier
-> HWType -> Int -> Identifier -> Int -> NetlistMonad Declaration
assignId Identifier
p_ HWType
hwty_ Int
con Identifier
i Int
n =
HasCallStack => Identifier -> Expr -> NetlistMonad Declaration
Identifier -> Expr -> NetlistMonad Declaration
contAssign Identifier
i (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
p_ (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Indexed (HWType
hwty_, Int
con, Int
n))))
mkTopCompDecl
:: Maybe Text
-> [Attr Text]
-> Identifier
-> Identifier
-> [(Expr, HWType, Expr)]
-> [InstancePort]
-> [InstancePort]
-> Declaration
mkTopCompDecl :: Maybe Text
-> [Attr Text]
-> Identifier
-> Identifier
-> [(Expr, HWType, Expr)]
-> [InstancePort]
-> [InstancePort]
-> Declaration
mkTopCompDecl Maybe Text
lib [Attr Text]
attrs Identifier
name Identifier
instName [(Expr, HWType, Expr)]
params [InstancePort]
inputs [InstancePort]
outputs =
EntityOrComponent
-> Maybe Text
-> [Attr Text]
-> Identifier
-> Identifier
-> [(Expr, HWType, Expr)]
-> PortMap
-> Declaration
InstDecl EntityOrComponent
Entity Maybe Text
lib [Attr Text]
attrs Identifier
name Identifier
instName [(Expr, HWType, Expr)]
params ([(PortDirection, HWType, Expr)] -> PortMap
IndexedPortMap [(PortDirection, HWType, Expr)]
ports)
where
ports :: [(PortDirection, HWType, Expr)]
ports = (InstancePort -> (PortDirection, HWType, Expr))
-> [InstancePort] -> [(PortDirection, HWType, Expr)]
forall a b. (a -> b) -> [a] -> [b]
map (PortDirection -> InstancePort -> (PortDirection, HWType, Expr)
forall a. a -> InstancePort -> (a, HWType, Expr)
toPort PortDirection
In) [InstancePort]
inputs [(PortDirection, HWType, Expr)]
-> [(PortDirection, HWType, Expr)]
-> [(PortDirection, HWType, Expr)]
forall a. [a] -> [a] -> [a]
++ (InstancePort -> (PortDirection, HWType, Expr))
-> [InstancePort] -> [(PortDirection, HWType, Expr)]
forall a b. (a -> b) -> [a] -> [b]
map (PortDirection -> InstancePort -> (PortDirection, HWType, Expr)
forall a. a -> InstancePort -> (a, HWType, Expr)
toPort PortDirection
Out) [InstancePort]
outputs
toExpr :: Identifier -> Expr
toExpr Identifier
id_ = Identifier -> Maybe Modifier -> Expr
Identifier Identifier
id_ Maybe Modifier
forall a. Maybe a
Nothing
toPort :: a -> InstancePort -> (a, HWType, Expr)
toPort a
dir InstancePort
ip = (a
dir, (InstancePort -> HWType
ip_type InstancePort
ip), Identifier -> Expr
toExpr (InstancePort -> Identifier
ip_id InstancePort
ip))
mkTopUnWrapper
:: Id
-> ExpandedTopEntity Identifier
-> (Identifier, HWType)
-> [(Expr,HWType)]
-> [Declaration]
-> NetlistMonad [Declaration]
mkTopUnWrapper :: Id
-> ExpandedTopEntity Identifier
-> (Identifier, HWType)
-> [(Expr, HWType)]
-> [Declaration]
-> NetlistMonad [Declaration]
mkTopUnWrapper Id
topEntity ExpandedTopEntity Identifier
annM (Identifier, HWType)
dstId [(Expr, HWType)]
args [Declaration]
tickDecls = do
Maybe Identifier
compNameM <- Id -> VarEnv Identifier -> Maybe Identifier
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
topEntity (VarEnv Identifier -> Maybe Identifier)
-> NetlistMonad (VarEnv Identifier)
-> NetlistMonad (Maybe Identifier)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (VarEnv Identifier) NetlistState (VarEnv Identifier)
-> NetlistMonad (VarEnv Identifier)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (VarEnv Identifier) NetlistState (VarEnv Identifier)
Lens' NetlistState (VarEnv Identifier)
componentNames
let
topName :: Text
topName = Identifier -> Text
Id.toText Identifier
topIdentifier
topIdentifier :: Identifier
topIdentifier = (Identifier -> Maybe Identifier -> Identifier)
-> Maybe Identifier -> Identifier -> Identifier
forall a b c. (a -> b -> c) -> b -> a -> c
flip Identifier -> Maybe Identifier -> Identifier
forall a. a -> Maybe a -> a
fromMaybe Maybe Identifier
compNameM (String -> Identifier
forall a. HasCallStack => String -> a
error [I.i|
Internal error in 'mkTopUnWrapper': tried to lookup (netlist) name
of #{showPpr (varName topEntity)}, but couldn't find it in NetlistState's
'componentNames'. This should have been put there by 'runNetlistMonad' /
'genNames'. |])
([[InstancePort]]
iports, [[Declaration]]
wrappers, [Identifier]
idsI) <- [([InstancePort], [Declaration], Identifier)]
-> ([[InstancePort]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([InstancePort], [Declaration], Identifier)]
-> ([[InstancePort]], [[Declaration]], [Identifier]))
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
-> NetlistMonad ([[InstancePort]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
mkTopInstInput ([Maybe (ExpandedPortName Identifier)]
-> [ExpandedPortName Identifier]
forall a. [Maybe a] -> [a]
catMaybes (ExpandedTopEntity Identifier
-> [Maybe (ExpandedPortName Identifier)]
forall a. ExpandedTopEntity a -> [Maybe (ExpandedPortName a)]
et_inputs ExpandedTopEntity Identifier
annM))
[Declaration]
inpAssigns <- (Identifier -> Expr -> NetlistMonad Declaration)
-> [Identifier] -> [Expr] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Identifier
i Expr
e -> HasCallStack => Identifier -> Expr -> NetlistMonad Declaration
Identifier -> Expr -> NetlistMonad Declaration
contAssign Identifier
i Expr
e) [Identifier]
idsI ((Expr, HWType) -> Expr
forall a b. (a, b) -> a
fst ((Expr, HWType) -> Expr) -> [(Expr, HWType)] -> [Expr]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Expr, HWType)]
args)
let
iResult :: [[Declaration]]
iResult = [Declaration]
inpAssigns [Declaration] -> [[Declaration]] -> [[Declaration]]
forall a. a -> [a] -> [a]
: [[Declaration]]
wrappers
instLabel0 :: Text
instLabel0 = [Text] -> Text
Text.concat [Text
topName, Text
"_", Identifier -> Text
Id.toText ((Identifier, HWType) -> Identifier
forall a b. (a, b) -> a
fst (Identifier, HWType)
dstId)]
Text
instLabel1 <- Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
instLabel0 (Maybe Text -> Text)
-> NetlistMonad (Maybe Text) -> NetlistMonad Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Maybe Text) NetlistEnv (Maybe Text)
-> NetlistMonad (Maybe Text)
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting (Maybe Text) NetlistEnv (Maybe Text)
Lens' NetlistEnv (Maybe Text)
setName
Text
instLabel2 <- Text -> NetlistMonad Text
affixName Text
instLabel1
Identifier
instLabel3 <- Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic Text
instLabel2
Maybe ([InstancePort], [Declaration], Identifier)
topOutputM <- (ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier))
-> Maybe (ExpandedPortName Identifier)
-> NetlistMonad (Maybe ([InstancePort], [Declaration], Identifier))
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse HasCallStack =>
ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
mkTopInstOutput (ExpandedTopEntity Identifier -> Maybe (ExpandedPortName Identifier)
forall a. ExpandedTopEntity a -> Maybe (ExpandedPortName a)
et_output ExpandedTopEntity Identifier
annM)
let topDecl :: [InstancePort] -> Declaration
topDecl = Maybe Text
-> [Attr Text]
-> Identifier
-> Identifier
-> [(Expr, HWType, Expr)]
-> [InstancePort]
-> [InstancePort]
-> Declaration
mkTopCompDecl (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
topName) [] Identifier
topIdentifier Identifier
instLabel3 [] ([[InstancePort]] -> [InstancePort]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[InstancePort]]
iports)
case Maybe ([InstancePort], [Declaration], Identifier)
topOutputM of
Maybe ([InstancePort], [Declaration], Identifier)
Nothing ->
[Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([InstancePort] -> Declaration
topDecl [] Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
iResult)
Just ([InstancePort]
oports, [Declaration]
unwrappers, Identifier
id0) -> do
Declaration
outpAssign <- HasCallStack => Identifier -> Expr -> NetlistMonad Declaration
Identifier -> Expr -> NetlistMonad Declaration
contAssign ((Identifier, HWType) -> Identifier
forall a b. (a, b) -> a
fst (Identifier, HWType)
dstId) (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
id0 Maybe Modifier
forall a. Maybe a
Nothing)
[Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
iResult [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ ([InstancePort] -> Declaration
topDecl [InstancePort]
oportsDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
unwrappers) [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
outpAssign])
data InstancePort = InstancePort
{ InstancePort -> Identifier
ip_id :: Identifier
, InstancePort -> HWType
ip_type :: HWType
} deriving Int -> InstancePort -> String -> String
[InstancePort] -> String -> String
InstancePort -> String
(Int -> InstancePort -> String -> String)
-> (InstancePort -> String)
-> ([InstancePort] -> String -> String)
-> Show InstancePort
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [InstancePort] -> String -> String
$cshowList :: [InstancePort] -> String -> String
show :: InstancePort -> String
$cshow :: InstancePort -> String
showsPrec :: Int -> InstancePort -> String -> String
$cshowsPrec :: Int -> InstancePort -> String -> String
Show
mkTopInstInput
:: ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
mkTopInstInput :: ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
mkTopInstInput (ExpandedPortName HWType
hwty0 Identifier
pN) = do
Identifier
pN' <- Identifier -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Identifier -> m Identifier
Id.next Identifier
pN
([Declaration]
decls, Identifier
pN'', Expr
_bvExpr, HWType
hwty1) <- Identifier
-> HWType -> NetlistMonad ([Declaration], Identifier, Expr, HWType)
toPrimitiveType Identifier
pN' HWType
hwty0
([InstancePort], [Declaration], Identifier)
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ( [Identifier -> HWType -> InstancePort
InstancePort Identifier
pN'' HWType
hwty1]
, Maybe Text -> Identifier -> HWType -> Maybe Expr -> Declaration
NetDecl' Maybe Text
forall a. Maybe a
Nothing Identifier
pN' HWType
hwty0 Maybe Expr
forall a. Maybe a
Nothing Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: [Declaration]
decls
, Identifier
pN' )
mkTopInstInput epp :: ExpandedPortName Identifier
epp@(ExpandedPortProduct Text
pNameHint HWType
hwty0 [ExpandedPortName Identifier]
ps) = do
Identifier
pName <- Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic Text
pNameHint
let pDecl :: Declaration
pDecl = Maybe Text -> Identifier -> HWType -> Maybe Expr -> Declaration
NetDecl' Maybe Text
forall a. Maybe a
Nothing Identifier
pName HWType
hwty0 Maybe Expr
forall a. Maybe a
Nothing
let
([Attr Text]
attrs, HWType
hwty1) = HWType -> ([Attr Text], HWType)
stripAttributes HWType
hwty0
indexPN :: Int -> Int -> Expr
indexPN Int
constr Int
n = Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pName (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Indexed (HWType
hwty0, Int
constr, Int
n)))
case HWType
hwty1 of
Vector {} -> do
([[InstancePort]]
ports, [[Declaration]]
decls, [Identifier]
ids) <- [([InstancePort], [Declaration], Identifier)]
-> ([[InstancePort]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([InstancePort], [Declaration], Identifier)]
-> ([[InstancePort]], [[Declaration]], [Identifier]))
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
-> NetlistMonad ([[InstancePort]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
mkTopInstInput [ExpandedPortName Identifier]
ps
let assigns :: [Declaration]
assigns = (Identifier -> Usage -> Expr -> Declaration)
-> [Identifier] -> [Usage] -> [Expr] -> [Declaration]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Identifier -> Usage -> Expr -> Declaration
Assignment [Identifier]
ids (Usage -> [Usage]
forall a. a -> [a]
repeat Usage
Cont) ((Int -> Expr) -> [Int] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Expr
indexPN Int
10) [Int
0..])
if [Attr Text] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr Text]
attrs then
([InstancePort], [Declaration], Identifier)
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[InstancePort]] -> [InstancePort]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[InstancePort]]
ports, Declaration
pDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls, Identifier
pName)
else
String
-> String
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Vector"
RTree {} -> do
([[InstancePort]]
ports, [[Declaration]]
decls, [Identifier]
ids) <- [([InstancePort], [Declaration], Identifier)]
-> ([[InstancePort]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([InstancePort], [Declaration], Identifier)]
-> ([[InstancePort]], [[Declaration]], [Identifier]))
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
-> NetlistMonad ([[InstancePort]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
mkTopInstInput [ExpandedPortName Identifier]
ps
let assigns :: [Declaration]
assigns = (Identifier -> Usage -> Expr -> Declaration)
-> [Identifier] -> [Usage] -> [Expr] -> [Declaration]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Identifier -> Usage -> Expr -> Declaration
Assignment [Identifier]
ids (Usage -> [Usage]
forall a. a -> [a]
repeat Usage
Cont) ((Int -> Expr) -> [Int] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Expr
indexPN Int
10) [Int
0..])
if [Attr Text] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr Text]
attrs then
([InstancePort], [Declaration], Identifier)
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[InstancePort]] -> [InstancePort]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[InstancePort]]
ports, Declaration
pDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls, Identifier
pName)
else
String
-> String
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"RTree"
Product {} -> do
([[InstancePort]]
ports, [[Declaration]]
decls, [Identifier]
ids) <- [([InstancePort], [Declaration], Identifier)]
-> ([[InstancePort]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([InstancePort], [Declaration], Identifier)]
-> ([[InstancePort]], [[Declaration]], [Identifier]))
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
-> NetlistMonad ([[InstancePort]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
mkTopInstInput [ExpandedPortName Identifier]
ps
let assigns :: [Declaration]
assigns = (Identifier -> Usage -> Expr -> Declaration)
-> [Identifier] -> [Usage] -> [Expr] -> [Declaration]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Identifier -> Usage -> Expr -> Declaration
Assignment [Identifier]
ids (Usage -> [Usage]
forall a. a -> [a]
repeat Usage
Cont) ((Int -> Expr) -> [Int] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Expr
indexPN Int
0) [Int
0..])
if [Attr Text] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr Text]
attrs then
([InstancePort], [Declaration], Identifier)
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[InstancePort]] -> [InstancePort]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[InstancePort]]
ports, Declaration
pDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls, Identifier
pName)
else
String
-> String
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Product"
SP Text
_ (([[HWType]] -> [HWType]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[HWType]] -> [HWType])
-> ([(Text, [HWType])] -> [[HWType]])
-> [(Text, [HWType])]
-> [HWType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, [HWType]) -> [HWType]) -> [(Text, [HWType])] -> [[HWType]]
forall a b. (a -> b) -> [a] -> [b]
map (Text, [HWType]) -> [HWType]
forall a b. (a, b) -> b
snd) -> [HWType
elTy]) -> do
([[InstancePort]]
ports, [[Declaration]]
decls, [Identifier]
ids) <- [([InstancePort], [Declaration], Identifier)]
-> ([[InstancePort]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([InstancePort], [Declaration], Identifier)]
-> ([[InstancePort]], [[Declaration]], [Identifier]))
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
-> NetlistMonad ([[InstancePort]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
mkTopInstInput [ExpandedPortName Identifier]
ps
case [Identifier]
ids of
[Identifier
conId,Identifier
elId] -> do
let
conIx :: Modifier
conIx = (HWType, Int, Int) -> Modifier
Sliced
( Int -> HWType
BitVector (HWType -> Int
typeSize HWType
hwty1)
, HWType -> Int
typeSize HWType
hwty1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
, HWType -> Int
typeSize HWType
elTy )
elIx :: Modifier
elIx = (HWType, Int, Int) -> Modifier
Sliced
( Int -> HWType
BitVector (HWType -> Int
typeSize HWType
hwty1)
, HWType -> Int
typeSize HWType
elTy Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
, Int
0 )
assigns :: [Declaration]
assigns =
[ Identifier -> Usage -> Expr -> Declaration
Assignment Identifier
conId Usage
Cont (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pName (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just Modifier
conIx))
, Identifier -> Usage -> Expr -> Declaration
Assignment Identifier
elId Usage
Cont (Maybe Identifier -> HWType -> Expr -> Expr
FromBv Maybe Identifier
forall a. Maybe a
Nothing HWType
elTy (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pName (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just Modifier
elIx))) ]
([InstancePort], [Declaration], Identifier)
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[InstancePort]] -> [InstancePort]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[InstancePort]]
ports, Declaration
pDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls, Identifier
pName)
[Identifier]
_ -> String -> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall a. HasCallStack => String -> a
error String
"Internal error: Unexpected error for PortProduct"
HWType
_ ->
String
-> HWType
-> ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall a. String -> HWType -> ExpandedPortName Identifier -> a
portProductError $(String
curLoc) HWType
hwty0 ExpandedPortName Identifier
epp
throwAnnotatedSplitError
:: String
-> String
-> NetlistMonad a
throwAnnotatedSplitError :: String -> String -> NetlistMonad a
throwAnnotatedSplitError String
loc String
typ = do
(Identifier
_,SrcSpan
sp) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
ClashException -> NetlistMonad a
forall a e. Exception e => e -> a
throw (ClashException -> NetlistMonad a)
-> ClashException -> NetlistMonad a
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp (String
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
msg String
typ String
typ) Maybe String
forall a. Maybe a
Nothing
where
msg :: String
msg = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [ String
"Attempted to split %s into a number of HDL ports. This"
, String
"is not allowed in combination with attribute annotations."
, String
"You can annotate %s's components by splitting it up"
, String
"manually." ]
mkTopInstOutput
:: HasCallStack
=> ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
mkTopInstOutput :: ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
mkTopInstOutput (ExpandedPortName HWType
hwty0 Identifier
portName) = do
Identifier
assignName0 <- Identifier -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Identifier -> m Identifier
Id.next Identifier
portName
([Declaration]
decls, Identifier
assignName1, Expr
_expr, HWType
hwty1) <- Identifier
-> HWType -> NetlistMonad ([Declaration], Identifier, Expr, HWType)
fromPrimitiveType Identifier
assignName0 HWType
hwty0
let net :: Declaration
net = Maybe Text -> Identifier -> HWType -> Maybe Expr -> Declaration
NetDecl' Maybe Text
forall a. Maybe a
Nothing Identifier
assignName0 HWType
hwty1 Maybe Expr
forall a. Maybe a
Nothing
([InstancePort], [Declaration], Identifier)
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Identifier -> HWType -> InstancePort
InstancePort Identifier
assignName0 HWType
hwty1], Declaration
net Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: [Declaration]
decls, Identifier
assignName1)
mkTopInstOutput epp :: ExpandedPortName Identifier
epp@(ExpandedPortProduct Text
productNameHint HWType
hwty [ExpandedPortName Identifier]
ps) = do
Identifier
pName <- Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic Text
productNameHint
let pDecl :: Declaration
pDecl = Maybe Text -> Identifier -> HWType -> Maybe Expr -> Declaration
NetDecl' Maybe Text
forall a. Maybe a
Nothing Identifier
pName HWType
hwty Maybe Expr
forall a. Maybe a
Nothing
let ([Attr Text]
attrs, HWType
hwty') = HWType -> ([Attr Text], HWType)
stripAttributes HWType
hwty
case HWType
hwty' of
Vector Int
sz HWType
hwty'' -> do
([[InstancePort]]
ports, [[Declaration]]
decls, [Identifier]
ids0) <- [([InstancePort], [Declaration], Identifier)]
-> ([[InstancePort]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([InstancePort], [Declaration], Identifier)]
-> ([[InstancePort]], [[Declaration]], [Identifier]))
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
-> NetlistMonad ([[InstancePort]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HasCallStack =>
ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
mkTopInstOutput [ExpandedPortName Identifier]
ps
let ids1 :: [Expr]
ids1 = (Identifier -> Expr) -> [Identifier] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map ((Identifier -> Maybe Modifier -> Expr)
-> Maybe Modifier -> Identifier -> Expr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Identifier -> Maybe Modifier -> Expr
Identifier Maybe Modifier
forall a. Maybe a
Nothing) [Identifier]
ids0
netassgn :: Declaration
netassgn = Identifier -> Usage -> Expr -> Declaration
Assignment Identifier
pName Usage
Cont (Int -> HWType -> [Expr] -> Expr
mkVectorChain Int
sz HWType
hwty'' [Expr]
ids1)
if [Attr Text] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr Text]
attrs then
([InstancePort], [Declaration], Identifier)
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[InstancePort]] -> [InstancePort]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[InstancePort]]
ports, Declaration
pDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:Declaration
netassgnDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls, Identifier
pName)
else
String
-> String
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Vector"
RTree Int
d HWType
hwty'' -> do
([[InstancePort]]
ports, [[Declaration]]
decls, [Identifier]
ids0) <- [([InstancePort], [Declaration], Identifier)]
-> ([[InstancePort]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3