{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
#if !MIN_VERSION_ghc(8,8,0)
{-# LANGUAGE MonadFailDesugaring #-}
#endif
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Clash.Netlist.Util where
import Data.Coerce (coerce)
import Control.Error (hush)
import Control.Exception (throw)
import Control.Lens ((.=),(%=))
import qualified Control.Lens as Lens
import Control.Monad (unless, when, zipWithM, join)
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.Either (partitionEithers)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.IntSet as IntSet
import Data.String (fromString)
import Data.List (intersperse, unzip4, intercalate)
import qualified Data.List as List
import qualified Data.List.Extra as List
import Data.Maybe (catMaybes,fromMaybe,isNothing,mapMaybe)
import Data.Monoid (First (..))
import Text.Printf (printf)
#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup ((<>))
#endif
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Lazy (toStrict)
import Data.Text.Prettyprint.Doc (Doc)
import Outputable (ppr, showSDocUnsafe)
import Clash.Annotations.BitRepresentation.ClashLib
(coreToType')
import Clash.Annotations.BitRepresentation.Internal
(CustomReprs, ConstrRepr'(..), DataRepr'(..), getDataRepr,
uncheckedGetConstrRepr)
import Clash.Annotations.TopEntity (PortName (..), TopEntity (..))
import Clash.Driver.Types (Manifest (..), ClashOpts (..))
import Clash.Core.DataCon (DataCon (..))
import Clash.Core.EqSolver (typeEq)
import Clash.Core.FreeVars (localIdOccursIn, typeFreeVars, typeFreeVars')
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
(Alt, LetBinding, Pat (..), Term (..), TickInfo (..), NameMod (..),
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 (..), TypeView (..),
coreView1, splitTyConAppM, tyView, TyVar)
import Clash.Core.Util
(substArgTys, tyLitShow)
import Clash.Core.Var
(Id, Var (..), mkLocalId, modifyVarName, Attr')
import Clash.Core.VarEnv
(InScopeSet, extendInScopeSetList, uniqAway)
import {-# SOURCE #-} Clash.Netlist.BlackBox
import {-# SOURCE #-} Clash.Netlist.BlackBox.Util
import Clash.Netlist.Id (IdType (..), stripDollarPrefixes)
import Clash.Netlist.Types as HW
import Clash.Primitives.Types
import Clash.Unique
import Clash.Util
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
mkIdentifier :: IdType -> Identifier -> NetlistMonad Identifier
mkIdentifier :: IdType -> Identifier -> NetlistMonad Identifier
mkIdentifier IdType
typ Identifier
nm = Getting
(IdType -> Identifier -> Identifier)
NetlistState
(IdType -> Identifier -> Identifier)
-> NetlistMonad (IdType -> Identifier -> Identifier)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
(IdType -> Identifier -> Identifier)
NetlistState
(IdType -> Identifier -> Identifier)
Lens' NetlistState (IdType -> Identifier -> Identifier)
mkIdentifierFn NetlistMonad (IdType -> Identifier -> Identifier)
-> NetlistMonad IdType -> NetlistMonad (Identifier -> Identifier)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> IdType -> NetlistMonad IdType
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure IdType
typ NetlistMonad (Identifier -> Identifier)
-> NetlistMonad Identifier -> NetlistMonad Identifier
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Identifier -> NetlistMonad Identifier
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Identifier
nm
extendIdentifier
:: IdType
-> Identifier
-> Identifier
-> NetlistMonad Identifier
extendIdentifier :: IdType -> Identifier -> Identifier -> NetlistMonad Identifier
extendIdentifier IdType
typ Identifier
nm Identifier
ext =
Getting
(IdType -> Identifier -> Identifier -> Identifier)
NetlistState
(IdType -> Identifier -> Identifier -> Identifier)
-> NetlistMonad (IdType -> Identifier -> Identifier -> Identifier)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
(IdType -> Identifier -> Identifier -> Identifier)
NetlistState
(IdType -> Identifier -> Identifier -> Identifier)
Lens'
NetlistState (IdType -> Identifier -> Identifier -> Identifier)
extendIdentifierFn NetlistMonad (IdType -> Identifier -> Identifier -> Identifier)
-> NetlistMonad IdType
-> NetlistMonad (Identifier -> Identifier -> Identifier)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> IdType -> NetlistMonad IdType
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure IdType
typ NetlistMonad (Identifier -> Identifier -> Identifier)
-> NetlistMonad Identifier
-> NetlistMonad (Identifier -> Identifier)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Identifier -> NetlistMonad Identifier
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Identifier
nm NetlistMonad (Identifier -> Identifier)
-> NetlistMonad Identifier -> NetlistMonad Identifier
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Identifier -> NetlistMonad Identifier
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Identifier
ext
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 -> (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 (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks)) [LetBinding]
xes,Id
v)
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: res not simple var")
| 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
termType TyConMap
tcm Term
expr
unsafeCoreTypeToHWType'
:: SrcSpan
-> String
-> (CustomReprs -> TyConMap -> Type ->
State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> State HWMap HWType
unsafeCoreTypeToHWType' :: SrcSpan
-> String
-> (CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> State HWMap HWType
unsafeCoreTypeToHWType' SrcSpan
sp String
loc CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m Type
ty =
FilteredHWType -> HWType
stripFiltered (FilteredHWType -> HWType)
-> StateT HWMap Identity FilteredHWType -> State HWMap HWType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (SrcSpan
-> String
-> (CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> StateT HWMap Identity FilteredHWType
unsafeCoreTypeToHWType SrcSpan
sp String
loc CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m Type
ty)
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
-> StateT HWMap Identity 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)
-> StateT HWMap Identity 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 NetlistState CustomReprs
-> NetlistMonad CustomReprs
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting CustomReprs NetlistState CustomReprs
Lens' NetlistState CustomReprs
customReprs
TyConMap
tcm <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState 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) = StateT HWMap Identity 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
-> StateT HWMap Identity 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 NetlistState CustomReprs
-> NetlistMonad CustomReprs
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting CustomReprs NetlistState CustomReprs
Lens' NetlistState CustomReprs
customReprs
TyConMap
tcm <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState 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 (Either String FilteredHWType -> Maybe FilteredHWType
forall a b. Either a b -> Maybe b
hush 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 = Identifier -> String
forall a. Show a => a -> String
show (ConstrRepr' -> Identifier
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 Identifier
name [Identifier]
conIds ->
Identifier
-> DataRepr' -> Int -> [(ConstrRepr', Identifier)] -> HWType
CustomSum Identifier
name DataRepr'
dRepr Int
size ((Identifier -> (ConstrRepr', Identifier))
-> [Identifier] -> [(ConstrRepr', Identifier)]
forall a b. (a -> b) -> [a] -> [b]
map Identifier -> (ConstrRepr', Identifier)
packSum [Identifier]
conIds)
SP Identifier
name [(Identifier, [HWType])]
conIdsAndFieldTys ->
Identifier
-> DataRepr'
-> Int
-> [(ConstrRepr', Identifier, [HWType])]
-> HWType
CustomSP Identifier
name DataRepr'
dRepr Int
size (((Identifier, [HWType]) -> (ConstrRepr', Identifier, [HWType]))
-> [(Identifier, [HWType])]
-> [(ConstrRepr', Identifier, [HWType])]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier, [HWType]) -> (ConstrRepr', Identifier, [HWType])
forall c. (Identifier, c) -> (ConstrRepr', Identifier, c)
packSP [(Identifier, [HWType])]
conIdsAndFieldTys)
Product Identifier
name Maybe [Identifier]
maybeFieldNames [HWType]
fieldTys
| [ConstrRepr' Identifier
_cName Int
_pos BitMask
_mask BitMask
_val [BitMask]
fieldAnns] <- [ConstrRepr']
constrs ->
Identifier
-> DataRepr'
-> Int
-> Maybe [Identifier]
-> [(BitMask, HWType)]
-> HWType
CustomProduct Identifier
name DataRepr'
dRepr Int
size Maybe [Identifier]
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 Identifier
_name [Identifier]
conIds) -> [Identifier] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Identifier]
conIds
(SP Identifier
_name [(Identifier, [HWType])]
conIdsAndFieldTys) -> [(Identifier, [HWType])] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [(Identifier, [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 :: (Identifier, c) -> (ConstrRepr', Identifier, c)
packSP (Identifier
name, c
tys) = (HasCallStack => Identifier -> CustomReprs -> ConstrRepr'
Identifier -> CustomReprs -> ConstrRepr'
uncheckedGetConstrRepr Identifier
name CustomReprs
reprs, Identifier
name, c
tys)
packSum :: Identifier -> (ConstrRepr', Identifier)
packSum Identifier
name = (HasCallStack => Identifier -> CustomReprs -> ConstrRepr'
Identifier -> CustomReprs -> ConstrRepr'
uncheckedGetConstrRepr Identifier
name CustomReprs
reprs, Identifier
name)
insertVoids :: HWType -> HWType
insertVoids :: HWType -> HWType
insertVoids (CustomSP Identifier
i DataRepr'
d Int
s [(ConstrRepr', Identifier, [HWType])]
constrs0) =
Identifier
-> DataRepr'
-> Int
-> [(ConstrRepr', Identifier, [HWType])]
-> HWType
CustomSP Identifier
i DataRepr'
d Int
s (((ConstrRepr', Identifier, [HWType])
-> (ConstrRepr', Identifier, [HWType]))
-> [(ConstrRepr', Identifier, [HWType])]
-> [(ConstrRepr', Identifier, [HWType])]
forall a b. (a -> b) -> [a] -> [b]
map (ConstrRepr', Identifier, [HWType])
-> (ConstrRepr', Identifier, [HWType])
forall b. (ConstrRepr', b, [HWType]) -> (ConstrRepr', b, [HWType])
go0 [(ConstrRepr', Identifier, [HWType])]
constrs0)
where
go0 :: (ConstrRepr', b, [HWType]) -> (ConstrRepr', b, [HWType])
go0 (con :: ConstrRepr'
con@(ConstrRepr' Identifier
_ 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 Identifier
i DataRepr'
d Int
s Maybe [Identifier]
f [(BitMask, HWType)]
fieldAnns) =
Identifier
-> DataRepr'
-> Int
-> Maybe [Identifier]
-> [(BitMask, HWType)]
-> HWType
CustomProduct Identifier
i DataRepr'
d Int
s Maybe [Identifier]
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
-> HWType
-> HWType
maybeConvertToCustomRepr :: CustomReprs -> Type -> HWType -> HWType
maybeConvertToCustomRepr CustomReprs
reprs (Type -> Either String Type'
coreToType' -> Right Type'
tyName) HWType
hwTy
| Just DataRepr'
dRepr <- Type' -> CustomReprs -> Maybe DataRepr'
getDataRepr Type'
tyName CustomReprs
reprs =
HasCallStack => CustomReprs -> DataRepr' -> HWType -> HWType
CustomReprs -> DataRepr' -> HWType -> HWType
convertToCustomRepr CustomReprs
reprs DataRepr'
dRepr HWType
hwTy
maybeConvertToCustomRepr CustomReprs
_reprs Type
_ty HWType
hwTy = HWType
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 v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.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 v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.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 (HashMap 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
$
(\(FilteredHWType HWType
hwty [[(IsVoid, FilteredHWType)]]
filtered) ->
(HWType -> [[(IsVoid, FilteredHWType)]] -> FilteredHWType
FilteredHWType (CustomReprs -> Type -> HWType -> HWType
maybeConvertToCustomRepr CustomReprs
reprs Type
ty HWType
hwty) [[(IsVoid, FilteredHWType)]]
filtered)) (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 HWType
hwty [[(IsVoid, FilteredHWType)]]
filtered <- (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 (HWType -> [[(IsVoid, FilteredHWType)]] -> FilteredHWType
FilteredHWType (CustomReprs -> Type -> HWType -> HWType
maybeConvertToCustomRepr CustomReprs
reprs Type
ty HWType
hwty) [[(IsVoid, FilteredHWType)]]
filtered)
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 (TyConMap
m TyConMap -> TyConName -> TyCon
forall a b. (HasCallStack, Uniquable a) => UniqMap b -> a -> b
`lookupUniqMap'` TyConName
tc) 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 :: Identifier
tcName = TyConName -> Identifier
forall a. Name a -> Identifier
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 -> [Identifier]
dcFieldLabels -> [Identifier]
labels0],[elemTys :: [FilteredHWType]
elemTys@(FilteredHWType
_:[FilteredHWType]
_)]) -> do
Maybe [Identifier]
labelsM <-
if [Identifier] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Identifier]
labels0 then
Maybe [Identifier]
-> ExceptT String (State HWMap) (Maybe [Identifier])
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe [Identifier]
forall a. Maybe a
Nothing
else
let areNotVoids :: [IsVoid]
areNotVoids = (IsVoid -> IsVoid) -> [IsVoid] -> [IsVoid]
forall a b. (a -> b) -> [a] -> [b]
map IsVoid -> IsVoid
not ([[IsVoid]] -> [IsVoid]
forall a. [a] -> a
head [[IsVoid]]
areVoids) in
let labels1 :: [(IsVoid, Identifier)]
labels1 = ((IsVoid, Identifier) -> IsVoid)
-> [(IsVoid, Identifier)] -> [(IsVoid, Identifier)]
forall a. (a -> IsVoid) -> [a] -> [a]
filter (IsVoid, Identifier) -> IsVoid
forall a b. (a, b) -> a
fst ([IsVoid] -> [Identifier] -> [(IsVoid, Identifier)]
forall a b. [a] -> [b] -> [(a, b)]
zip [IsVoid]
areNotVoids [Identifier]
labels0) in
let labels2 :: [Identifier]
labels2 = ((IsVoid, Identifier) -> Identifier)
-> [(IsVoid, Identifier)] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map (IsVoid, Identifier) -> Identifier
forall a b. (a, b) -> b
snd [(IsVoid, Identifier)]
labels1 in
Maybe [Identifier]
-> ExceptT String (State HWMap) (Maybe [Identifier])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Identifier] -> Maybe [Identifier]
forall a. a -> Maybe a
Just [Identifier]
labels2)
let hwty :: HWType
hwty = Identifier -> Maybe [Identifier] -> [HWType] -> HWType
Product Identifier
tcName Maybe [Identifier]
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 (Identifier -> Maybe [Identifier] -> [HWType] -> HWType
Product Identifier
tcName Maybe [Identifier]
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 (Identifier -> [Identifier] -> HWType
Sum Identifier
tcName ([Identifier] -> HWType) -> [Identifier] -> HWType
forall a b. (a -> b) -> a -> b
$ (DataCon -> Identifier) -> [DataCon] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map (Name DataCon -> Identifier
forall a. Name a -> Identifier
nameOcc (Name DataCon -> Identifier)
-> (DataCon -> Name DataCon) -> DataCon -> Identifier
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 (Identifier -> [(Identifier, [HWType])] -> HWType
SP Identifier
tcName ([(Identifier, [HWType])] -> HWType)
-> [(Identifier, [HWType])] -> HWType
forall a b. (a -> b) -> a -> b
$ (DataCon -> [HWType] -> (Identifier, [HWType]))
-> [DataCon] -> [[HWType]] -> [(Identifier, [HWType])]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
(\DataCon
dc [HWType]
tys -> ( Name DataCon -> Identifier
forall a. Name a -> Identifier
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
lookupUniqMap 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 (TyConMap
m TyConMap -> TyConName -> TyCon
forall a b. (HasCallStack, Uniquable a) => UniqMap b -> a -> b
`lookupUniqMap'` TyConName
tc) 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]]
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 k v. HashMap k v
HashMap.empty (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 Identifier
_ Maybe [Identifier]
_ [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 Identifier
_ [(Identifier, [HWType])]
elTyss -> ((Identifier, [HWType]) -> IsVoid)
-> [(Identifier, [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)
-> ((Identifier, [HWType]) -> [HWType])
-> (Identifier, [HWType])
-> IsVoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identifier, [HWType]) -> [HWType]
forall a b. (a, b) -> b
snd) [(Identifier, [HWType])]
elTyss
BiDirectional PortDirection
_ HWType
t -> HWType -> IsVoid
isRepresentable HWType
t
Annotated [Attr']
_ 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 Identifier
_) = Int
1
typeSize (Reset {}) = 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 (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 Identifier
_ [(Identifier, [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 (((Identifier, [HWType]) -> Int)
-> [(Identifier, [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)
-> ((Identifier, [HWType]) -> [Int])
-> (Identifier, [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])
-> ((Identifier, [HWType]) -> [HWType])
-> (Identifier, [HWType])
-> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identifier, [HWType]) -> [HWType]
forall a b. (a, b) -> b
snd) [(Identifier, [HWType])]
cons)
typeSize (Sum Identifier
_ [Identifier]
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
$ [Identifier] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Identifier]
dcs
typeSize (Product Identifier
_ Maybe [Identifier]
_ [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 Identifier
_ DataRepr'
_ Int
size [(ConstrRepr', Identifier, [HWType])]
_) = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size
typeSize (CustomSum Identifier
_ DataRepr'
_ Int
size [(ConstrRepr', Identifier)]
_) = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size
typeSize (CustomProduct Identifier
_ DataRepr'
_ Int
size Maybe [Identifier]
_ [(BitMask, HWType)]
_) = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size
typeSize (Annotated [Attr']
_ HWType
ty) = HWType -> Int
typeSize HWType
ty
conSize :: HWType
-> Int
conSize :: HWType -> Int
conSize (SP Identifier
_ [(Identifier, [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
$ [(Identifier, [HWType])] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [(Identifier, [HWType])]
cons
conSize HWType
t = HWType -> Int
typeSize HWType
t
typeLength :: HWType
-> Int
typeLength :: HWType -> Int
typeLength (Vector Int
n HWType
_) = Int
n
typeLength HWType
_ = Int
0
termHWType :: String
-> Term
-> NetlistMonad HWType
termHWType :: String -> Term -> NetlistMonad HWType
termHWType String
loc Term
e = do
TyConMap
m <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
let ty :: Type
ty = TyConMap -> Term -> Type
termType 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 NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
let ty :: Type
ty = TyConMap -> Term -> Type
termType 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 HWType
_ = IsVoid
False
containsBiSignalIn
:: HWType
-> Bool
containsBiSignalIn :: HWType -> IsVoid
containsBiSignalIn (BiDirectional PortDirection
In HWType
_) = IsVoid
True
containsBiSignalIn (Product Identifier
_ Maybe [Identifier]
_ [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 Identifier
_ [(Identifier, [HWType])]
tyss) = ((Identifier, [HWType]) -> IsVoid)
-> [(Identifier, [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)
-> ((Identifier, [HWType]) -> [HWType])
-> (Identifier, [HWType])
-> IsVoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identifier, [HWType]) -> [HWType]
forall a b. (a, b) -> b
snd) [(Identifier, [HWType])]
tyss
containsBiSignalIn (Vector Int
_ HWType
ty) = HWType -> IsVoid
containsBiSignalIn HWType
ty
containsBiSignalIn (RTree Int
_ HWType
ty) = HWType -> IsVoid
containsBiSignalIn HWType
ty
containsBiSignalIn HWType
_ = IsVoid
False
collectPortNames'
:: [String]
-> PortName
-> [Identifier]
collectPortNames' :: [String] -> PortName -> [Identifier]
collectPortNames' [String]
prefixes (PortName String
nm) =
let prefixes' :: [String]
prefixes' = [String] -> [String]
forall a. [a] -> [a]
reverse (String
nm String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
prefixes) in
[String -> Identifier
forall a. IsString a => String -> a
fromString (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"_" [String]
prefixes')]
collectPortNames' [String]
prefixes (PortProduct String
"" [PortName]
nms) =
(PortName -> [Identifier]) -> [PortName] -> [Identifier]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap ([String] -> PortName -> [Identifier]
collectPortNames' [String]
prefixes) [PortName]
nms
collectPortNames' [String]
prefixes (PortProduct String
prefix [PortName]
nms) =
(PortName -> [Identifier]) -> [PortName] -> [Identifier]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap ([String] -> PortName -> [Identifier]
collectPortNames' (String
prefix String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
prefixes)) [PortName]
nms
collectPortNames
:: TopEntity
-> [Identifier]
collectPortNames :: TopEntity -> [Identifier]
collectPortNames TestBench {} = []
collectPortNames Synthesize { [PortName]
t_inputs :: TopEntity -> [PortName]
t_inputs :: [PortName]
t_inputs, PortName
t_output :: TopEntity -> PortName
t_output :: PortName
t_output } =
(PortName -> [Identifier]) -> [PortName] -> [Identifier]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap ([String] -> PortName -> [Identifier]
collectPortNames' []) [PortName]
t_inputs [Identifier] -> [Identifier] -> [Identifier]
forall a. [a] -> [a] -> [a]
++ ([String] -> PortName -> [Identifier]
collectPortNames' []) PortName
t_output
filterVoidPorts
:: FilteredHWType
-> PortName
-> PortName
filterVoidPorts :: FilteredHWType -> PortName -> PortName
filterVoidPorts FilteredHWType
_hwty (PortName String
s) =
String -> PortName
PortName String
s
filterVoidPorts (FilteredHWType HWType
_hwty [[(IsVoid, FilteredHWType)]
filtered]) (PortProduct String
s [PortName]
ps)
| [(IsVoid, FilteredHWType)] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [(IsVoid, FilteredHWType)]
filtered Int -> Int -> IsVoid
forall a. Ord a => a -> a -> IsVoid
> Int
1
= String -> [PortName] -> PortName
PortProduct String
s [FilteredHWType -> PortName -> PortName
filterVoidPorts FilteredHWType
f PortName
p | (PortName
p, (IsVoid
void, FilteredHWType
f)) <- [PortName]
-> [(IsVoid, FilteredHWType)]
-> [(PortName, (IsVoid, FilteredHWType))]
forall a b. [a] -> [b] -> [(a, b)]
zip [PortName]
ps [(IsVoid, FilteredHWType)]
filtered, IsVoid -> IsVoid
not IsVoid
void]
filterVoidPorts (FilteredHWType HWType
_hwty [[(IsVoid, FilteredHWType)]]
fs) (PortProduct String
s [PortName]
ps)
| [(IsVoid, FilteredHWType)] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length (((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)]] -> [(IsVoid, FilteredHWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(IsVoid, FilteredHWType)]]
fs)) Int -> Int -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Int
1
, [[(IsVoid, FilteredHWType)]] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [[(IsVoid, FilteredHWType)]]
fs Int -> Int -> IsVoid
forall a. Ord a => a -> a -> IsVoid
> Int
1
, [PortName] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [PortName]
ps Int -> Int -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Int
2
= String -> [PortName] -> PortName
PortProduct String
s [PortName]
ps
filterVoidPorts FilteredHWType
filtered pp :: PortName
pp@(PortProduct String
_s [PortName]
_ps) =
String -> PortName
forall a. HasCallStack => String -> a
error (String -> PortName) -> String -> PortName
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Ports were annotated as product, but type wasn't one: \n\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Filtered was: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FilteredHWType -> String
forall a. Show a => a -> String
show FilteredHWType
filtered String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Ports was: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PortName -> String
forall a. Show a => a -> String
show PortName
pp
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
let
portNames :: [Identifier]
portNames =
case Maybe (Maybe TopEntity) -> Maybe TopEntity
forall (m :: Type -> Type) a. Monad m => m (m a) -> m a
join Maybe (Maybe TopEntity)
topMM of
Maybe TopEntity
Nothing -> []
Just TopEntity
top -> TopEntity -> [Identifier]
collectPortNames TopEntity
top
(HashMap Identifier Word -> Identity (HashMap Identifier Word))
-> NetlistState -> Identity NetlistState
Lens' NetlistState (HashMap Identifier Word)
seenIds ((HashMap Identifier Word -> Identity (HashMap Identifier Word))
-> NetlistState -> Identity NetlistState)
-> (HashMap Identifier Word -> HashMap Identifier Word)
-> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ((Word -> Word -> Word)
-> HashMap Identifier Word
-> HashMap Identifier Word
-> HashMap Identifier Word
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HashMap.unionWith Word -> Word -> Word
forall a. Ord a => a -> a -> a
max ([(Identifier, Word)] -> HashMap Identifier Word
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ((Identifier -> (Identifier, Word))
-> [Identifier] -> [(Identifier, Word)]
forall a b. (a -> b) -> [a] -> [b]
map (,Word
0) [Identifier]
portNames)))
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 (Maybe TopEntity)
-> [Id]
-> NetlistMonad
([IsVoid], [(Identifier, HWType)], [Declaration], Subst)
mkUniqueArguments (InScopeSet -> Subst
mkSubst InScopeSet
is1) Maybe (Maybe TopEntity)
topMM [Id]
args
Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
resM <- Subst
-> Maybe (Maybe TopEntity)
-> Id
-> NetlistMonad
(Maybe ([(Identifier, HWType)], [Declaration], Id, Subst))
mkUniqueResult Subst
substArgs Maybe (Maybe TopEntity)
topMM Id
res
case Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
resM of
Just ([(Identifier, HWType)]
oports,[Declaration]
owrappers,Id
res1,Subst
substRes) -> do
let resRead :: IsVoid
resRead = (Term -> IsVoid) -> [Term] -> IsVoid
forall (t :: Type -> Type) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
any (Id -> Term -> IsVoid
localIdOccursIn Id
res) [Term]
exprs
((Id
res2,Subst
subst1,[LetBinding]
extraBndr),[Id]
bndrs1) <-
((Id, Subst, [LetBinding])
-> LetBinding -> NetlistMonad ((Id, Subst, [LetBinding]), Id))
-> (Id, Subst, [LetBinding])
-> [LetBinding]
-> NetlistMonad ((Id, Subst, [LetBinding]), [Id])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
List.mapAccumLM (Subst
-> Id
-> IsVoid
-> (Id, Subst, [LetBinding])
-> LetBinding
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
setBinderName Subst
substRes Id
res IsVoid
resRead) (Id
res1,Subst
substRes,[]) [LetBinding]
binds
let ([Id]
bndrsL,Id
r:[Id]
bndrsR) = (Id -> IsVoid) -> [Id] -> ([Id], [Id])
forall a. (a -> IsVoid) -> [a] -> ([a], [a])
break ((Id -> Id -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Id
res2)) [Id]
bndrs1
([Id]
bndrsL1,Subst
substL) <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique Subst
subst1 [Id]
bndrsL
([Id]
bndrsR1,Subst
substR) <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique Subst
substL [Id]
bndrsR
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" :: Doc ()) Subst
substR) [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
, [(Identifier, HWType)]
oports
, [Declaration]
owrappers
, [Id] -> [Term] -> [LetBinding]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Id]
bndrsL1 [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ Id
rId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
bndrsR1) [Term]
exprs1 [LetBinding] -> [LetBinding] -> [LetBinding]
forall a. [a] -> [a] -> [a]
++ [LetBinding]
extraBndr
, 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
([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
, []
, []
, [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" :: Doc ()) Subst
substArgs1) [Term]
exprs)
,Maybe Id
forall a. Maybe a
Nothing)
setBinderName
:: Subst
-> Id
-> Bool
-> (Id, Subst, [(Id,Term)])
-> (Id,Term)
-> NetlistMonad ((Id, Subst, [(Id,Term)]),Id)
setBinderName :: Subst
-> Id
-> IsVoid
-> (Id, Subst, [LetBinding])
-> LetBinding
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
setBinderName Subst
subst Id
res IsVoid
resRead m :: (Id, Subst, [LetBinding])
m@(Id
resN,Subst
_,[LetBinding]
_) (Id
i,Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks -> (Term
k,[Either Term Type]
args,[TickInfo]
ticks)) = case Term
k of
Prim PrimInfo
p -> let nm :: Identifier
nm = PrimInfo -> Identifier
primName PrimInfo
p in HasCallStack => Identifier -> NetlistMonad CompiledPrimitive
Identifier -> NetlistMonad CompiledPrimitive
extractPrimWarnOrFail Identifier
nm NetlistMonad CompiledPrimitive
-> (CompiledPrimitive
-> NetlistMonad ((Id, Subst, [LetBinding]), Id))
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Identifier
-> CompiledPrimitive
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
forall a c d.
Identifier
-> Primitive a BlackBox c d
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
go Identifier
nm
Term
_ -> NetlistMonad ((Id, Subst, [LetBinding]), Id)
goDef
where
go :: Identifier
-> Primitive a BlackBox c d
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
go Identifier
nm (BlackBox {resultName :: forall a b c d. Primitive a b c d -> Maybe b
resultName = Just (BBTemplate BlackBoxTemplate
nmD)}) = [TickInfo]
-> ([Declaration] -> NetlistMonad ((Id, Subst, [LetBinding]), Id))
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
forall a.
[TickInfo] -> ([Declaration] -> NetlistMonad a) -> NetlistMonad a
withTicks [TickInfo]
ticks (([Declaration] -> NetlistMonad ((Id, Subst, [LetBinding]), Id))
-> NetlistMonad ((Id, Subst, [LetBinding]), Id))
-> ([Declaration] -> NetlistMonad ((Id, Subst, [LetBinding]), Id))
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
forall a b. (a -> b) -> a -> b
$ \[Declaration]
_ -> do
(BlackBoxContext
bbCtx,[Declaration]
_) <- NetlistMonad (BlackBoxContext, [Declaration])
-> NetlistMonad (BlackBoxContext, [Declaration])
forall a. NetlistMonad a -> NetlistMonad a
preserveVarEnv (Identifier
-> Id
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext Identifier
nm Id
i [Either Term Type]
args)
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 bbRetValName :: Identifier
bbRetValName = case SomeBackend
be of
SomeBackend backend
s -> Text -> Identifier
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
nmD) backend
s) Int
0)
i1 :: Id
i1 = (Name Term -> Name Term) -> Id -> Id
forall a. (Name a -> Name a) -> Var a -> Var a
modifyVarName (\Name Term
n -> Name Term
n {nameOcc :: Identifier
nameOcc = Identifier
bbRetValName}) Id
i
if Id
res Id -> Id -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Id
i1 then do
([Id
i2],Subst
subst1) <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique Subst
subst [Id
i1]
((Id, Subst, [LetBinding]), Id)
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Id
i2,Subst
subst1,[(Id
resN,Id -> Term
Var Id
i2)]),Id
i2)
else
((Id, Subst, [LetBinding]), Id)
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Id, Subst, [LetBinding])
m,Id
i1)
go Identifier
_ Primitive a BlackBox c d
_ = NetlistMonad ((Id, Subst, [LetBinding]), Id)
goDef
goDef :: NetlistMonad ((Id, Subst, [LetBinding]), Id)
goDef
| Id
i Id -> Id -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Id
res IsVoid -> IsVoid -> IsVoid
&& IsVoid
resRead
= do
([Id
i1],Subst
subst1) <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique Subst
subst [(Name Term -> Name Term) -> Id -> Id
forall a. (Name a -> Name a) -> Var a -> Var a
modifyVarName (Name Term -> Identifier -> Name Term
forall a. Name a -> Identifier -> Name a
`appendToName` Identifier
"_rec") Id
res]
((Id, Subst, [LetBinding]), Id)
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Id
i1, Subst
subst1, [(Id
resN,Id -> Term
Var Id
i1)]),Id
i1)
| Id
i Id -> Id -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Id
res
= ((Id, Subst, [LetBinding]), Id)
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Id, Subst, [LetBinding])
m,Id
resN)
| IsVoid
otherwise
= ((Id, Subst, [LetBinding]), Id)
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Id, Subst, [LetBinding])
m,Id
i)
mkUniqueArguments
:: Subst
-> Maybe (Maybe TopEntity)
-> [Id]
-> NetlistMonad
( [Bool]
, [(Identifier,HWType)]
, [Declaration]
, Subst
)
mkUniqueArguments :: Subst
-> Maybe (Maybe TopEntity)
-> [Id]
-> NetlistMonad
([IsVoid], [(Identifier, HWType)], [Declaration], Subst)
mkUniqueArguments Subst
subst0 Maybe (Maybe TopEntity)
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 Maybe TopEntity
teM) [Id]
args = do
let iPortSupply :: [Maybe PortName]
iPortSupply = [Maybe PortName]
-> (TopEntity -> [Maybe PortName])
-> Maybe TopEntity
-> [Maybe PortName]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe PortName -> [Maybe PortName]
forall a. a -> [a]
repeat Maybe PortName
forall a. Maybe a
Nothing) ([PortName] -> [Maybe PortName]
extendPorts ([PortName] -> [Maybe PortName])
-> (TopEntity -> [PortName]) -> TopEntity -> [Maybe PortName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopEntity -> [PortName]
t_inputs) Maybe TopEntity
teM
[Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
ports0 <- (Maybe PortName
-> Id
-> NetlistMonad
(Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))))
-> [Maybe PortName]
-> [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 PortName
-> Id
-> NetlistMonad
(Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding)))
go [Maybe PortName]
iPortSupply [Id]
args
let ([[(Identifier, HWType)]]
ports1, [[Declaration]]
decls, [(Id, LetBinding)]
subst) = [([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
-> ([[(Identifier, HWType)]], [[Declaration]], [(Id, LetBinding)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
-> [([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
ports0)
([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)], [Declaration], (Id, LetBinding))
-> IsVoid)
-> [Maybe
([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
-> [IsVoid]
forall a b. (a -> b) -> [a] -> [b]
map Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))
-> IsVoid
forall a. Maybe a -> IsVoid
isNothing [Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
ports0
, [[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports1
, [[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)]
subst))
(((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)]
subst))
where
go :: Maybe PortName
-> Id
-> NetlistMonad
(Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding)))
go Maybe PortName
pM Id
var = do
let i :: Name Term
i = Id -> Name Term
forall a. Var a -> Name a
varName Id
var
i' :: Identifier
i' = Name Term -> Identifier
forall a. Name a -> Identifier
nameOcc Name Term
i
ty :: Type
ty = Id -> Type
forall a. Var a -> Type
varType Id
var
FilteredHWType
fHwty <- String -> Type -> NetlistMonad FilteredHWType
unsafeCoreTypeToHWTypeM $(String
curLoc) Type
ty
let FilteredHWType HWType
hwty [[(IsVoid, FilteredHWType)]]
_ = FilteredHWType
fHwty
([(Identifier, HWType)]
ports,[Declaration]
decls,Expr
_,Identifier
pN) <- Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkInput (FilteredHWType -> PortName -> PortName
filterVoidPorts FilteredHWType
fHwty (PortName -> PortName) -> Maybe PortName -> Maybe PortName
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PortName
pM) (Identifier
i',HWType
hwty)
let pId :: Id
pId = Type -> Name Term -> Id
mkLocalId Type
ty (Identifier -> Name Term -> Name Term
forall a. Identifier -> Name a -> Name a
repName Identifier
pN Name Term
i)
if HWType -> IsVoid
isVoid HWType
hwty
then Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))
-> NetlistMonad
(Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))
forall a. Maybe a
Nothing
else 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 (Maybe TopEntity)
-> Id
-> NetlistMonad (Maybe ([(Identifier,HWType)],[Declaration],Id,Subst))
mkUniqueResult :: Subst
-> Maybe (Maybe TopEntity)
-> Id
-> NetlistMonad
(Maybe ([(Identifier, HWType)], [Declaration], Id, Subst))
mkUniqueResult Subst
subst0 Maybe (Maybe TopEntity)
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 Maybe TopEntity
teM) 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
let o :: Name Term
o = Id -> Name Term
forall a. Var a -> Name a
varName Id
res
o' :: Identifier
o' = Name Term -> Identifier
forall a. Name a -> Identifier
nameOcc Name Term
o
ty :: Type
ty = Id -> Type
forall a. Var a -> Type
varType Id
res
FilteredHWType
fHwty <- String -> Type -> NetlistMonad FilteredHWType
unsafeCoreTypeToHWTypeM $(String
curLoc) Type
ty
let FilteredHWType HWType
hwty [[(IsVoid, FilteredHWType)]]
_ = FilteredHWType
fHwty
oPortSupply :: Maybe PortName
oPortSupply = (TopEntity -> PortName) -> Maybe TopEntity -> Maybe PortName
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap TopEntity -> PortName
t_output Maybe TopEntity
teM
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))
Maybe ([(Identifier, HWType)], [Declaration], Identifier)
output <- Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
(Maybe ([(Identifier, HWType)], [Declaration], Identifier))
mkOutput (FilteredHWType -> PortName -> PortName
filterVoidPorts FilteredHWType
fHwty (PortName -> PortName) -> Maybe PortName -> Maybe PortName
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PortName
oPortSupply) (Identifier
o',HWType
hwty)
case Maybe ([(Identifier, HWType)], [Declaration], Identifier)
output of
Just ([(Identifier, HWType)]
ports, [Declaration]
decls, Identifier
pN) -> do
let pO :: Name Term
pO = Identifier -> Name Term -> Name Term
forall a. Identifier -> Name a -> Name a
repName Identifier
pN Name Term
o
pOId :: Id
pOId = Type -> Name Term -> Id
mkLocalId Type
ty 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))
Maybe ([(Identifier, HWType)], [Declaration], Identifier)
_ -> 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
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
let i :: Name Term
i = Id -> Name Term
forall a. Var a -> Name a
varName Id
var
ty :: Type
ty = Id -> Type
forall a. Var a -> Type
varType Id
var
HWType
hwTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(String
curLoc) Type
ty
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 (Name Term -> Identifier
forall a. Name a -> Identifier
nameOcc Name Term
i, HWType
hwTy))
id2type :: Id -> Type
id2type :: Id -> Type
id2type = Id -> Type
forall a. Var a -> Type
varType
id2identifier :: Id -> Identifier
id2identifier :: Id -> Identifier
id2identifier = Name Term -> Identifier
forall a. Name a -> Identifier
nameOcc (Name Term -> Identifier) -> (Id -> Name Term) -> Id -> Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name Term
forall a. Var a -> Name a
varName
repName :: Text -> Name a -> Name a
repName :: Identifier -> Name a -> Name a
repName Identifier
s (Name NameSort
sort' Identifier
_ Int
i SrcSpan
loc) = NameSort -> Identifier -> Int -> SrcSpan -> Name a
forall a. NameSort -> Identifier -> Int -> SrcSpan -> Name a
Name NameSort
sort' Identifier
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
Identifier
iN <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Extended (Id -> Identifier
id2identifier 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 (Identifier -> Name Term -> Name Term
forall a. Identifier -> Name a -> Name a
repName Identifier
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
mkUniqueIdentifier
:: IdType
-> Identifier
-> NetlistMonad Identifier
mkUniqueIdentifier :: IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
typ Identifier
nm = do
HashMap Identifier Word
seen <- Getting
(HashMap Identifier Word) NetlistState (HashMap Identifier Word)
-> NetlistMonad (HashMap Identifier Word)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
(HashMap Identifier Word) NetlistState (HashMap Identifier Word)
Lens' NetlistState (HashMap Identifier Word)
seenIds
HashMap Identifier Word
seenC <- Getting
(HashMap Identifier Word) NetlistState (HashMap Identifier Word)
-> NetlistMonad (HashMap Identifier Word)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
(HashMap Identifier Word) NetlistState (HashMap Identifier Word)
Lens' NetlistState (HashMap Identifier Word)
seenComps
Identifier
i <- IdType -> Identifier -> NetlistMonad Identifier
mkIdentifier IdType
typ Identifier
nm
let getCopyIter :: Identifier -> Maybe Word
getCopyIter Identifier
k = First Word -> Maybe Word
forall a. First a -> Maybe a
getFirst (Maybe Word -> First Word
forall a. Maybe a -> First a
First (Identifier -> HashMap Identifier Word -> Maybe Word
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Identifier
k HashMap Identifier Word
seen) First Word -> First Word -> First Word
forall a. Semigroup a => a -> a -> a
<> Maybe Word -> First Word
forall a. Maybe a -> First a
First (Identifier -> HashMap Identifier Word -> Maybe Word
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Identifier
k HashMap Identifier Word
seenC))
case Identifier -> Maybe Word
getCopyIter Identifier
i of
Just Word
n -> Word
-> (Identifier -> Maybe Word)
-> Identifier
-> NetlistMonad Identifier
go Word
n Identifier -> Maybe Word
getCopyIter Identifier
i
Maybe Word
Nothing -> do
(HashMap Identifier Word -> Identity (HashMap Identifier Word))
-> NetlistState -> Identity NetlistState
Lens' NetlistState (HashMap Identifier Word)
seenIds ((HashMap Identifier Word -> Identity (HashMap Identifier Word))
-> NetlistState -> Identity NetlistState)
-> (HashMap Identifier Word -> HashMap Identifier Word)
-> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Identifier
-> Word -> HashMap Identifier Word -> HashMap Identifier Word
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Identifier
i Word
0
Identifier -> NetlistMonad Identifier
forall (m :: Type -> Type) a. Monad m => a -> m a
return Identifier
i
where
go :: Word -> (Identifier -> Maybe Word) -> Identifier -> NetlistMonad Identifier
go :: Word
-> (Identifier -> Maybe Word)
-> Identifier
-> NetlistMonad Identifier
go Word
n Identifier -> Maybe Word
g Identifier
i = do
Identifier
i' <- IdType -> Identifier -> Identifier -> NetlistMonad Identifier
extendIdentifier IdType
typ Identifier
i (String -> Identifier
Text.pack (Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:Word -> String
forall a. Show a => a -> String
show Word
n))
case Identifier -> Maybe Word
g Identifier
i' of
Just Word
_ -> Word
-> (Identifier -> Maybe Word)
-> Identifier
-> NetlistMonad Identifier
go (Word
nWord -> Word -> Word
forall a. Num a => a -> a -> a
+Word
1) Identifier -> Maybe Word
g Identifier
i
Maybe Word
Nothing -> do
(HashMap Identifier Word -> Identity (HashMap Identifier Word))
-> NetlistState -> Identity NetlistState
Lens' NetlistState (HashMap Identifier Word)
seenIds ((HashMap Identifier Word -> Identity (HashMap Identifier Word))
-> NetlistState -> Identity NetlistState)
-> (HashMap Identifier Word -> HashMap Identifier Word)
-> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Identifier
-> Word -> HashMap Identifier Word -> HashMap Identifier Word
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Identifier
i (Word
nWord -> Word -> Word
forall a. Num a => a -> a -> a
+Word
1)
(HashMap Identifier Word -> Identity (HashMap Identifier Word))
-> NetlistState -> Identity NetlistState
Lens' NetlistState (HashMap Identifier Word)
seenIds ((HashMap Identifier Word -> Identity (HashMap Identifier Word))
-> NetlistState -> Identity NetlistState)
-> (HashMap Identifier Word -> HashMap Identifier Word)
-> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Identifier
-> Word -> HashMap Identifier Word -> HashMap Identifier Word
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Identifier
i' Word
0
Identifier -> NetlistMonad Identifier
forall (m :: Type -> Type) a. Monad m => a -> m a
return Identifier
i'
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
Int
vCnt <- Getting Int NetlistState Int -> NetlistMonad Int
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting Int NetlistState Int
Lens' NetlistState Int
varCount
(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
HashMap Identifier Word
vSeen <- Getting
(HashMap Identifier Word) NetlistState (HashMap Identifier Word)
-> NetlistMonad (HashMap Identifier Word)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
(HashMap Identifier Word) NetlistState (HashMap Identifier Word)
Lens' NetlistState (HashMap Identifier Word)
seenIds
a
val <- NetlistMonad a
action
(Int -> Identity Int) -> NetlistState -> Identity NetlistState
Lens' NetlistState Int
varCount ((Int -> Identity Int) -> NetlistState -> Identity NetlistState)
-> Int -> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Int
vCnt
((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
(HashMap Identifier Word -> Identity (HashMap Identifier Word))
-> NetlistState -> Identity NetlistState
Lens' NetlistState (HashMap Identifier Word)
seenIds ((HashMap Identifier Word -> Identity (HashMap Identifier Word))
-> NetlistState -> Identity NetlistState)
-> HashMap Identifier Word -> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= HashMap Identifier Word
vSeen
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
portName
:: String
-> Identifier
-> Identifier
portName :: String -> Identifier -> Identifier
portName [] Identifier
i = Identifier
i
portName String
x Identifier
_ = String -> Identifier
Text.pack String
x
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
appendIdentifier
:: (Identifier,HWType)
-> Int
-> NetlistMonad (Identifier,HWType)
appendIdentifier :: (Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
nm,HWType
hwty) Int
i =
(,HWType
hwty) (Identifier -> (Identifier, HWType))
-> NetlistMonad Identifier -> NetlistMonad (Identifier, HWType)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IdType -> Identifier -> Identifier -> NetlistMonad Identifier
extendIdentifier IdType
Extended Identifier
nm (String -> Identifier
Text.pack (Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show Int
i))
uniquePortName
:: String
-> Identifier
-> NetlistMonad Identifier
uniquePortName :: String -> Identifier -> NetlistMonad Identifier
uniquePortName [] Identifier
i = IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Extended Identifier
i
uniquePortName String
x Identifier
_ = do
let xT :: Identifier
xT = String -> Identifier
Text.pack String
x
Identifier
xTB <- IdType -> Identifier -> NetlistMonad Identifier
mkIdentifier IdType
Basic Identifier
xT
(HashMap Identifier Word -> Identity (HashMap Identifier Word))
-> NetlistState -> Identity NetlistState
Lens' NetlistState (HashMap Identifier Word)
seenIds ((HashMap Identifier Word -> Identity (HashMap Identifier Word))
-> NetlistState -> Identity NetlistState)
-> (HashMap Identifier Word -> HashMap Identifier Word)
-> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (\HashMap Identifier Word
s -> (HashMap Identifier Word -> Identifier -> HashMap Identifier Word)
-> HashMap Identifier Word
-> [Identifier]
-> HashMap Identifier Word
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\HashMap Identifier Word
m Identifier
k -> Identifier
-> Word -> HashMap Identifier Word -> HashMap Identifier Word
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Identifier
k Word
0 HashMap Identifier Word
m) HashMap Identifier Word
s [Identifier
xT,Identifier
xTB])
Identifier -> NetlistMonad Identifier
forall (m :: Type -> Type) a. Monad m => a -> m a
return Identifier
xT
mkInput
:: Maybe PortName
-> (Identifier,HWType)
-> NetlistMonad ([(Identifier,HWType)],[Declaration],Expr,Identifier)
mkInput :: Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkInput Maybe PortName
pM = case Maybe PortName
pM of
Maybe PortName
Nothing -> (Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
go
Just PortName
p -> PortName
-> (Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
go' PortName
p
where
go :: (Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
go (Identifier
i,HWType
hwty) = do
Identifier
i' <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Extended Identifier
i
let ([Attr']
attrs, HWType
hwty') = HWType -> ([Attr'], HWType)
stripAttributes HWType
hwty
case HWType
hwty' of
Vector Int
sz HWType
hwty'' -> do
[(Identifier, HWType)]
arguments <- (Int -> NetlistMonad (Identifier, HWType))
-> [Int] -> NetlistMonad [(Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
i',HWType
hwty'')) [Int
0..Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
([[(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
<$> ((Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> [(Identifier, HWType)]
-> 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 (Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkInput Maybe PortName
forall a. Maybe a
Nothing) [(Identifier, HWType)]
arguments
let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
i' (Int -> HWType -> HWType
Vector Int
sz HWType
hwty'')
vecExpr :: Expr
vecExpr = Int -> HWType -> [Expr] -> Expr
mkVectorChain Int
sz HWType
hwty'' [Expr]
exprs
netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
i' Expr
vecExpr
if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
([(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
netdecl,Declaration
netassgn],Expr
vecExpr,Identifier
i')
else
String
-> String
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Vector"
RTree Int
d HWType
hwty'' -> do
[(Identifier, HWType)]
arguments <- (Int -> NetlistMonad (Identifier, HWType))
-> [Int] -> NetlistMonad [(Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
i',HWType
hwty'')) [Int
0..Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
([[(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
<$> ((Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> [(Identifier, HWType)]
-> 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 (Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkInput Maybe PortName
forall a. Maybe a
Nothing) [(Identifier, HWType)]
arguments
let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
i' (Int -> HWType -> HWType
RTree Int
d HWType
hwty'')
trExpr :: Expr
trExpr = Int -> HWType -> [Expr] -> Expr
mkRTreeChain Int
d HWType
hwty'' [Expr]
exprs
netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
i' Expr
trExpr
if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
([(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
netdecl,Declaration
netassgn],Expr
trExpr,Identifier
i')
else
String
-> String
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"RTree"
Product Identifier
_ Maybe [Identifier]
_ [HWType]
hwtys -> do
[(Identifier, HWType)]
arguments <- ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Int]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
i',) [HWType]
hwtys) [Int
0..]
([[(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
<$> ((Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> [(Identifier, HWType)]
-> 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 (Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkInput Maybe PortName
forall a. Maybe a
Nothing) [(Identifier, HWType)]
arguments
case [Expr]
exprs of
[Expr
expr] ->
let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
i' HWType
hwty
dcExpr :: Expr
dcExpr = Expr
expr
netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
i' Expr
expr
in ([(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
netdecl,Declaration
netassgn],Expr
dcExpr,Identifier
i')
[Expr]
_ ->
let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
i' HWType
hwty
dcExpr :: Expr
dcExpr = HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
hwty ((HWType, Int) -> Modifier
DC (HWType
hwty,Int
0)) [Expr]
exprs
netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
i' Expr
dcExpr
in if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
([(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
netdecl,Declaration
netassgn],Expr
dcExpr,Identifier
i')
else
String
-> String
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Product"
HWType
_ -> ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier
i',HWType
hwty)],[],Identifier -> Maybe Modifier -> Expr
Identifier Identifier
i' Maybe Modifier
forall a. Maybe a
Nothing,Identifier
i')
go' :: PortName
-> (Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
go' (PortName String
p) (Identifier
i,HWType
hwty) = do
Identifier
pN <- String -> Identifier -> NetlistMonad Identifier
uniquePortName String
p Identifier
i
([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier
pN,HWType
hwty)],[],Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pN Maybe Modifier
forall a. Maybe a
Nothing,Identifier
pN)
go' (PortProduct String
p [PortName]
ps) (Identifier
i,HWType
hwty) = do
Identifier
pN <- String -> Identifier -> NetlistMonad Identifier
uniquePortName String
p Identifier
i
let ([Attr']
attrs, HWType
hwty') = HWType -> ([Attr'], HWType)
stripAttributes HWType
hwty
case HWType
hwty' of
Vector Int
sz HWType
hwty'' -> do
[(Identifier, HWType)]
arguments <- (Int -> NetlistMonad (Identifier, HWType))
-> [Int] -> NetlistMonad [(Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
pN,HWType
hwty'')) [Int
0..Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
([[(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
<$> (Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> [Maybe PortName]
-> [(Identifier, HWType)]
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Expr, Identifier)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkInput ([PortName] -> [Maybe PortName]
extendPorts ([PortName] -> [Maybe PortName]) -> [PortName] -> [Maybe PortName]
forall a b. (a -> b) -> a -> b
$ (PortName -> PortName) -> [PortName] -> [PortName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PortName -> PortName
prefixParent String
p) [PortName]
ps) [(Identifier, HWType)]
arguments
let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
pN (Int -> HWType -> HWType
Vector Int
sz HWType
hwty'')
vecExpr :: Expr
vecExpr = Int -> HWType -> [Expr] -> Expr
mkVectorChain Int
sz HWType
hwty'' [Expr]
exprs
netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pN Expr
vecExpr
if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
([(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
netdecl,Declaration
netassgn],Expr
vecExpr,Identifier
pN)
else
String
-> String
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Vector"
RTree Int
d HWType
hwty'' -> do
[(Identifier, HWType)]
arguments <- (Int -> NetlistMonad (Identifier, HWType))
-> [Int] -> NetlistMonad [(Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
pN,HWType
hwty'')) [Int
0..Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
([[(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
<$> (Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> [Maybe PortName]
-> [(Identifier, HWType)]
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Expr, Identifier)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkInput ([PortName] -> [Maybe PortName]
extendPorts ([PortName] -> [Maybe PortName]) -> [PortName] -> [Maybe PortName]
forall a b. (a -> b) -> a -> b
$ (PortName -> PortName) -> [PortName] -> [PortName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PortName -> PortName
prefixParent String
p) [PortName]
ps) [(Identifier, HWType)]
arguments
let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
pN (Int -> HWType -> HWType
RTree Int
d HWType
hwty'')
trExpr :: Expr
trExpr = Int -> HWType -> [Expr] -> Expr
mkRTreeChain Int
d HWType
hwty'' [Expr]
exprs
netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pN Expr
trExpr
if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
([(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
netdecl,Declaration
netassgn],Expr
trExpr,Identifier
pN)
else
String
-> String
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"RTree"
Product Identifier
_ Maybe [Identifier]
_ [HWType]
hwtys -> do
[(Identifier, HWType)]
arguments <- ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Int]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
pN,) [HWType]
hwtys) [Int
0..]
let ps' :: [Maybe PortName]
ps' = [PortName] -> [Maybe PortName]
extendPorts ([PortName] -> [Maybe PortName]) -> [PortName] -> [Maybe PortName]
forall a b. (a -> b) -> a -> b
$ (PortName -> PortName) -> [PortName] -> [PortName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PortName -> PortName
prefixParent String
p) [PortName]
ps
([[(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
<$> ([Maybe PortName]
-> [(Identifier, HWType)]
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Expr, Identifier)])
-> ([Maybe PortName], [(Identifier, HWType)])
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Expr, Identifier)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> [Maybe PortName]
-> [(Identifier, HWType)]
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Expr, Identifier)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkInput) ([Maybe PortName]
ps', [(Identifier, HWType)]
arguments)
case [Expr]
exprs of
[Expr
expr] ->
let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
pN HWType
hwty'
dcExpr :: Expr
dcExpr = Expr
expr
netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pN Expr
expr
in ([(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
netdecl,Declaration
netassgn],Expr
dcExpr,Identifier
pN)
[Expr]
_ -> let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
pN HWType
hwty'
dcExpr :: Expr
dcExpr = HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
hwty' ((HWType, Int) -> Modifier
DC (HWType
hwty',Int
0)) [Expr]
exprs
netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pN Expr
dcExpr
in if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
([(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
netdecl,Declaration
netassgn],Expr
dcExpr,Identifier
pN)
else
String
-> String
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Product"
SP Identifier
_ (([[HWType]] -> [HWType]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[HWType]] -> [HWType])
-> ([(Identifier, [HWType])] -> [[HWType]])
-> [(Identifier, [HWType])]
-> [HWType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Identifier, [HWType]) -> [HWType])
-> [(Identifier, [HWType])] -> [[HWType]]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier, [HWType]) -> [HWType]
forall a b. (a, b) -> b
snd) -> [HWType
elTy]) -> do
let hwtys :: [HWType]
hwtys = [Int -> HWType
BitVector (HWType -> Int
conSize HWType
hwty'),HWType
elTy]
[(Identifier, HWType)]
arguments <- ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Int]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
pN,) [HWType]
hwtys) [Int
0..]
let ps' :: [Maybe PortName]
ps' = [PortName] -> [Maybe PortName]
extendPorts ([PortName] -> [Maybe PortName]) -> [PortName] -> [Maybe PortName]
forall a b. (a -> b) -> a -> b
$ (PortName -> PortName) -> [PortName] -> [PortName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PortName -> PortName
prefixParent String
p) [PortName]
ps
([[(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
<$> ([Maybe PortName]
-> [(Identifier, HWType)]
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Expr, Identifier)])
-> ([Maybe PortName], [(Identifier, HWType)])
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Expr, Identifier)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> [Maybe PortName]
-> [(Identifier, HWType)]
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Expr, Identifier)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkInput) ([Maybe PortName]
ps', [(Identifier, HWType)]
arguments)
case [Expr]
exprs of
[Expr
conExpr,Expr
elExpr] -> do
let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
pN HWType
hwty'
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 -> IsVoid -> Expr -> Expr
ConvBV Maybe Identifier
forall a. Maybe a
Nothing HWType
elTy IsVoid
True Expr
elExpr]
netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pN 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
netdecl,Declaration
netassgn],Expr
dcExpr,Identifier
pN)
[Expr]
_ -> String
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall a. HasCallStack => String -> a
error String
"Unexpected error for PortProduct"
HWType
_ -> ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier
pN,HWType
hwty)],[],Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pN Maybe Modifier
forall a. Maybe a
Nothing,Identifier
pN)
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
-> HashMap Identifier Word
-> (IdType -> Identifier -> Identifier)
-> ComponentPrefix
-> Id
-> Identifier
genComponentName :: IsVoid
-> HashMap Identifier Word
-> (IdType -> Identifier -> Identifier)
-> ComponentPrefix
-> Id
-> Identifier
genComponentName IsVoid
newInlineStrat HashMap Identifier Word
seen IdType -> Identifier -> Identifier
mkIdFn ComponentPrefix
prefixM Id
nm =
let nm' :: [Identifier]
nm' = Identifier -> Identifier -> [Identifier]
Text.splitOn (String -> Identifier
Text.pack String
".") (Name Term -> Identifier
forall a. Name a -> Identifier
nameOcc (Id -> Name Term
forall a. Var a -> Name a
varName Id
nm))
fn :: Identifier
fn = IdType -> Identifier -> Identifier
mkIdFn IdType
Basic (Identifier -> Identifier
stripDollarPrefixes ([Identifier] -> Identifier
forall a. [a] -> a
last [Identifier]
nm'))
fn' :: Identifier
fn' = if Identifier -> IsVoid
Text.null Identifier
fn then String -> Identifier
Text.pack String
"Component" else Identifier
fn
prefix :: [Identifier]
prefix = ([Identifier] -> [Identifier])
-> (Identifier -> [Identifier] -> [Identifier])
-> Maybe Identifier
-> [Identifier]
-> [Identifier]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Identifier] -> [Identifier]
forall a. a -> a
id (:) (ComponentPrefix -> Maybe Identifier
componentPrefixOther ComponentPrefix
prefixM) (if IsVoid
newInlineStrat then [] else [Identifier] -> [Identifier]
forall a. [a] -> [a]
init [Identifier]
nm')
nm2 :: Identifier
nm2 = [Identifier] -> Identifier
Text.concat (Identifier -> [Identifier] -> [Identifier]
forall a. a -> [a] -> [a]
intersperse (String -> Identifier
Text.pack String
"_") ([Identifier]
prefix [Identifier] -> [Identifier] -> [Identifier]
forall a. [a] -> [a] -> [a]
++ [Identifier
fn']))
nm3 :: Identifier
nm3 = IdType -> Identifier -> Identifier
mkIdFn IdType
Basic Identifier
nm2
in case Identifier -> HashMap Identifier Word -> Maybe Word
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Identifier
nm3 HashMap Identifier Word
seen of
Just Word
n -> Word -> Identifier -> Identifier
go Word
n Identifier
nm3
Maybe Word
Nothing -> Identifier
nm3
where
go :: Word -> Identifier -> Identifier
go :: Word -> Identifier -> Identifier
go Word
n Identifier
i =
let i' :: Identifier
i' = IdType -> Identifier -> Identifier
mkIdFn IdType
Basic (Identifier
i Identifier -> Identifier -> Identifier
`Text.append` String -> Identifier
Text.pack (Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:Word -> String
forall a. Show a => a -> String
show Word
n))
in case Identifier -> HashMap Identifier Word -> Maybe Word
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Identifier
i' HashMap Identifier Word
seen of
Just Word
_ -> Word -> Identifier -> Identifier
go (Word
nWord -> Word -> Word
forall a. Num a => a -> a -> a
+Word
1) Identifier
i
Maybe Word
Nothing -> Identifier
i'
genTopComponentName
:: Bool
-> (IdType -> Identifier -> Identifier)
-> ComponentPrefix
-> Maybe TopEntity
-> Id
-> Identifier
genTopComponentName :: IsVoid
-> (IdType -> Identifier -> Identifier)
-> ComponentPrefix
-> Maybe TopEntity
-> Id
-> Identifier
genTopComponentName IsVoid
_newInlineStrat IdType -> Identifier -> Identifier
_mkIdFn ComponentPrefix
prefixM (Just TopEntity
ann) Id
_nm =
case ComponentPrefix -> Maybe Identifier
componentPrefixTop ComponentPrefix
prefixM of
Just Identifier
p -> Identifier
p Identifier -> Identifier -> Identifier
`Text.append` String -> Identifier
Text.pack (Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:TopEntity -> String
t_name TopEntity
ann)
Maybe Identifier
_ -> String -> Identifier
Text.pack (TopEntity -> String
t_name TopEntity
ann)
genTopComponentName IsVoid
newInlineStrat IdType -> Identifier -> Identifier
mkIdFn ComponentPrefix
prefixM Maybe TopEntity
Nothing Id
nm =
IsVoid
-> HashMap Identifier Word
-> (IdType -> Identifier -> Identifier)
-> ComponentPrefix
-> Id
-> Identifier
genComponentName IsVoid
newInlineStrat HashMap Identifier Word
forall k v. HashMap k v
HashMap.empty IdType -> Identifier -> Identifier
mkIdFn ComponentPrefix
prefixM' Id
nm
where
prefixM' :: ComponentPrefix
prefixM' = ComponentPrefix
prefixM{componentPrefixOther :: Maybe Identifier
componentPrefixOther = ComponentPrefix -> Maybe Identifier
componentPrefixTop ComponentPrefix
prefixM}
stripAttributes
:: HWType
-> ([Attr'], HWType)
stripAttributes :: HWType -> ([Attr'], HWType)
stripAttributes (Annotated [Attr']
attrs HWType
typ) =
let ([Attr']
attrs', HWType
typ') = HWType -> ([Attr'], HWType)
stripAttributes HWType
typ
in ([Attr']
attrs [Attr'] -> [Attr'] -> [Attr']
forall a. [a] -> [a] -> [a]
++ [Attr']
attrs', HWType
typ')
stripAttributes HWType
typ = ([], HWType
typ)
mkOutput
:: Maybe PortName
-> (Identifier,HWType)
-> NetlistMonad (Maybe ([(Identifier,HWType)],[Declaration],Identifier))
mkOutput :: Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
(Maybe ([(Identifier, HWType)], [Declaration], Identifier))
mkOutput Maybe PortName
_pM (Identifier
_o, (BiDirectional PortDirection
Out HWType
_)) = Maybe ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad
(Maybe ([(Identifier, HWType)], [Declaration], Identifier))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe ([(Identifier, HWType)], [Declaration], Identifier)
forall a. Maybe a
Nothing
mkOutput Maybe PortName
_pM (Identifier
_o, (Void Maybe HWType
_)) = Maybe ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad
(Maybe ([(Identifier, HWType)], [Declaration], Identifier))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe ([(Identifier, HWType)], [Declaration], Identifier)
forall a. Maybe a
Nothing
mkOutput Maybe PortName
pM (Identifier
o, HWType
hwty) = ([(Identifier, HWType)], [Declaration], Identifier)
-> Maybe ([(Identifier, HWType)], [Declaration], Identifier)
forall a. a -> Maybe a
Just (([(Identifier, HWType)], [Declaration], Identifier)
-> Maybe ([(Identifier, HWType)], [Declaration], Identifier))
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad
(Maybe ([(Identifier, HWType)], [Declaration], Identifier))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkOutput' Maybe PortName
pM (Identifier
o, HWType
hwty)
mkOutput'
:: Maybe PortName
-> (Identifier,HWType)
-> NetlistMonad ([(Identifier,HWType)],[Declaration],Identifier)
mkOutput' :: Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkOutput' Maybe PortName
pM = case Maybe PortName
pM of
Maybe PortName
Nothing -> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
go
Just PortName
p -> PortName
-> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
go' PortName
p
where
go :: (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
go (Identifier
o,HWType
hwty) = do
Identifier
o' <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Extended Identifier
o
let ([Attr']
attrs, HWType
hwty') = HWType -> ([Attr'], HWType)
stripAttributes HWType
hwty
case HWType
hwty' of
Vector Int
sz HWType
hwty'' -> do
IsVoid -> NetlistMonad () -> NetlistMonad ()
forall (f :: Type -> Type). Applicative f => IsVoid -> f () -> f ()
unless ([Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs)
(String -> String -> NetlistMonad ()
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Vector")
[(Identifier, HWType)]
results <- (Int -> NetlistMonad (Identifier, HWType))
-> [Int] -> NetlistMonad [(Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
o',HWType
hwty'')) [Int
0..Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
([[(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
<$> ((Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Identifier))
-> [(Identifier, HWType)]
-> 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 (Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkOutput' Maybe PortName
forall a. Maybe a
Nothing) [(Identifier, HWType)]
results
let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
o' HWType
hwty'
assigns :: [Declaration]
assigns = (Identifier -> Int -> Declaration)
-> [Identifier] -> [Int] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Identifier -> HWType -> Int -> Identifier -> Int -> Declaration
assignId Identifier
o' HWType
hwty' Int
10) [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
netdeclDeclaration -> [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
o')
RTree Int
d HWType
hwty'' -> do
IsVoid -> NetlistMonad () -> NetlistMonad ()
forall (f :: Type -> Type). Applicative f => IsVoid -> f () -> f ()
unless ([Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs)
(String -> String -> NetlistMonad ()
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"RTree")
[(Identifier, HWType)]
results <- (Int -> NetlistMonad (Identifier, HWType))
-> [Int] -> NetlistMonad [(Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
o',HWType
hwty'')) [Int
0..Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
([[(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
<$> ((Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Identifier))
-> [(Identifier, HWType)]
-> 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 (Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkOutput' Maybe PortName
forall a. Maybe a
Nothing) [(Identifier, HWType)]
results
let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
o' HWType
hwty'
assigns :: [Declaration]
assigns = (Identifier -> Int -> Declaration)
-> [Identifier] -> [Int] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Identifier -> HWType -> Int -> Identifier -> Int -> Declaration
assignId Identifier
o' HWType
hwty' Int
10) [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
netdeclDeclaration -> [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
o')
Product Identifier
_ Maybe [Identifier]
_ [HWType]
hwtys -> do
[(Identifier, HWType)]
results <- ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Int]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
o,) [HWType]
hwtys) [Int
0..]
([[(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
<$> ((Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Identifier))
-> [(Identifier, HWType)]
-> 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 (Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkOutput' Maybe PortName
forall a. Maybe a
Nothing) [(Identifier, HWType)]
results
case [Identifier]
ids of
[Identifier
i] ->
let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
o' HWType
hwty
assign :: Declaration
assign = Identifier -> Expr -> Declaration
Assignment Identifier
i (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
o' Maybe Modifier
forall a. Maybe a
Nothing)
in ([(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
netdeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:Declaration
assignDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier
o')
[Identifier]
_ ->
let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
o' HWType
hwty
assigns :: [Declaration]
assigns = (Identifier -> Int -> Declaration)
-> [Identifier] -> [Int] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Identifier -> HWType -> Int -> Identifier -> Int -> Declaration
assignId Identifier
o' HWType
hwty Int
0) [Identifier]
ids [Int
0..]
in if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
([(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
netdeclDeclaration -> [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
o')
else
String
-> String
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Product"
HWType
_ -> ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier
o',HWType
hwty)],[],Identifier
o')
go' :: PortName
-> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
go' (PortName String
p) (Identifier
o,HWType
hwty) = do
Identifier
pN <- String -> Identifier -> NetlistMonad Identifier
uniquePortName String
p Identifier
o
([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier
pN,HWType
hwty)],[],Identifier
pN)
go' (PortProduct String
p [PortName]
ps) (Identifier
_,HWType
hwty) = do
Identifier
pN <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Basic (String -> Identifier
Text.pack String
p)
let ([Attr']
attrs, HWType
hwty') = HWType -> ([Attr'], HWType)
stripAttributes HWType
hwty
case HWType
hwty' of
Vector Int
sz HWType
hwty'' -> do
IsVoid -> NetlistMonad () -> NetlistMonad ()
forall (f :: Type -> Type). Applicative f => IsVoid -> f () -> f ()
unless ([Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs)
(String -> String -> NetlistMonad ()
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Vector")
[(Identifier, HWType)]
results <- (Int -> NetlistMonad (Identifier, HWType))
-> [Int] -> NetlistMonad [(Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
pN,HWType
hwty'')) [Int
0..Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
([[(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
<$> (Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Identifier))
-> [Maybe PortName]
-> [(Identifier, HWType)]
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Identifier)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkOutput' ([PortName] -> [Maybe PortName]
extendPorts ([PortName] -> [Maybe PortName]) -> [PortName] -> [Maybe PortName]
forall a b. (a -> b) -> a -> b
$ (PortName -> PortName) -> [PortName] -> [PortName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PortName -> PortName
prefixParent String
p) [PortName]
ps) [(Identifier, HWType)]
results
let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
pN HWType
hwty'
assigns :: [Declaration]
assigns = (Identifier -> Int -> Declaration)
-> [Identifier] -> [Int] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Identifier -> HWType -> Int -> Identifier -> Int -> Declaration
assignId Identifier
pN HWType
hwty' Int
10) [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
netdeclDeclaration -> [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 Int
d HWType
hwty'' -> do
IsVoid -> NetlistMonad () -> NetlistMonad ()
forall (f :: Type -> Type). Applicative f => IsVoid -> f () -> f ()
unless ([Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs)
(String -> String -> NetlistMonad ()
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"RTree")
[(Identifier, HWType)]
results <- (Int -> NetlistMonad (Identifier, HWType))
-> [Int] -> NetlistMonad [(Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
pN,HWType
hwty'')) [Int
0..Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
([[(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
<$> (Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Identifier))
-> [Maybe PortName]
-> [(Identifier, HWType)]
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Identifier)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkOutput' ([PortName] -> [Maybe PortName]
extendPorts ([PortName] -> [Maybe PortName]) -> [PortName] -> [Maybe PortName]
forall a b. (a -> b) -> a -> b
$ (PortName -> PortName) -> [PortName] -> [PortName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PortName -> PortName
prefixParent String
p) [PortName]
ps) [(Identifier, HWType)]
results
let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
pN HWType
hwty'
assigns :: [Declaration]
assigns = (Identifier -> Int -> Declaration)
-> [Identifier] -> [Int] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Identifier -> HWType -> Int -> Identifier -> Int -> Declaration
assignId Identifier
pN HWType
hwty' Int
10) [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
netdeclDeclaration -> [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 Identifier
_ Maybe [Identifier]
_ [HWType]
hwtys -> do
[(Identifier, HWType)]
results <- ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Int]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
pN,) [HWType]
hwtys) [Int
0..]
let ps' :: [Maybe PortName]
ps' = [PortName] -> [Maybe PortName]
extendPorts ([PortName] -> [Maybe PortName]) -> [PortName] -> [Maybe PortName]
forall a b. (a -> b) -> a -> b
$ (PortName -> PortName) -> [PortName] -> [PortName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PortName -> PortName
prefixParent String
p) [PortName]
ps
([[(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
<$> ([Maybe PortName]
-> [(Identifier, HWType)]
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Identifier)])
-> ([Maybe PortName], [(Identifier, HWType)])
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Identifier)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Identifier))
-> [Maybe PortName]
-> [(Identifier, HWType)]
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Identifier)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkOutput') ([Maybe PortName]
ps', [(Identifier, HWType)]
results)
let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
pN HWType
hwty'
case [Identifier]
ids of
[Identifier
i] -> let assign :: Declaration
assign = Identifier -> Expr -> Declaration
Assignment Identifier
i (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pN Maybe Modifier
forall a. Maybe a
Nothing)
in ([(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
netdeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:Declaration
assignDeclaration -> [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]
_ -> let assigns :: [Declaration]
assigns = (Identifier -> Int -> Declaration)
-> [Identifier] -> [Int] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Identifier -> HWType -> Int -> Identifier -> Int -> Declaration
assignId Identifier
pN HWType
hwty' Int
0) [Identifier]
ids [Int
0..]
in if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
([(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
netdeclDeclaration -> [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)
else
String
-> String
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Product"
SP Identifier
_ (([[HWType]] -> [HWType]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[HWType]] -> [HWType])
-> ([(Identifier, [HWType])] -> [[HWType]])
-> [(Identifier, [HWType])]
-> [HWType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Identifier, [HWType]) -> [HWType])
-> [(Identifier, [HWType])] -> [[HWType]]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier, [HWType]) -> [HWType]
forall a b. (a, b) -> b
snd) -> [HWType
elTy]) -> do
let hwtys :: [HWType]
hwtys = [Int -> HWType
BitVector (HWType -> Int
conSize HWType
hwty'),HWType
elTy]
[(Identifier, HWType)]
results <- ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Int]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
pN,) [HWType]
hwtys) [Int
0..]
let ps' :: [Maybe PortName]
ps' = [PortName] -> [Maybe PortName]
extendPorts ([PortName] -> [Maybe PortName]) -> [PortName] -> [Maybe PortName]
forall a b. (a -> b) -> a -> b
$ (PortName -> PortName) -> [PortName] -> [PortName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PortName -> PortName
prefixParent String
p) [PortName]
ps
([[(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
<$> ([Maybe PortName]
-> [(Identifier, HWType)]
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Identifier)])
-> ([Maybe PortName], [(Identifier, HWType)])
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Identifier)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
([(Identifier, HWType)], [Declaration], Identifier))
-> [Maybe PortName]
-> [(Identifier, HWType)]
-> NetlistMonad
[([(Identifier, HWType)], [Declaration], Identifier)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkOutput') ([Maybe PortName]
ps', [(Identifier, HWType)]
results)
case [Identifier]
ids of
[Identifier
conId,Identifier
elId] ->
let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
pN HWType
hwty'
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
)
assigns :: [Declaration]
assigns = [Identifier -> Expr -> Declaration
Assignment Identifier
conId (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pN (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just Modifier
conIx))
,Identifier -> Expr -> Declaration
Assignment Identifier
elId (Maybe Identifier -> HWType -> IsVoid -> Expr -> Expr
ConvBV Maybe Identifier
forall a. Maybe a
Nothing HWType
elTy IsVoid
False
(Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pN (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just Modifier
elIx)))
]
in ([(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
netdeclDeclaration -> [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)
[Identifier]
_ -> String
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall a. HasCallStack => String -> a
error String
"Unexpected error for PortProduct"
HWType
_ -> ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier
pN,HWType
hwty)],[],Identifier
pN)
assignId :: Identifier -> HWType -> Int -> Identifier -> Int -> Declaration
assignId Identifier
p HWType
hwty Int
con Identifier
i Int
n =
Identifier -> Expr -> Declaration
Assignment 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))))
mkTopUnWrapper
:: Id
-> Maybe TopEntity
-> Manifest
-> (Identifier,HWType)
-> [(Expr,HWType)]
-> [Declaration]
-> NetlistMonad [Declaration]
mkTopUnWrapper :: Id
-> Maybe TopEntity
-> Manifest
-> (Identifier, HWType)
-> [(Expr, HWType)]
-> [Declaration]
-> NetlistMonad [Declaration]
mkTopUnWrapper Id
topEntity Maybe TopEntity
annM Manifest
man (Identifier, HWType)
dstId [(Expr, HWType)]
args [Declaration]
tickDecls = do
let inTys :: [Identifier]
inTys = Manifest -> [Identifier]
portInTypes Manifest
man
outTys :: [Identifier]
outTys = Manifest -> [Identifier]
portOutTypes Manifest
man
inNames :: [Identifier]
inNames = Manifest -> [Identifier]
portInNames Manifest
man
outNames :: [Identifier]
outNames = Manifest -> [Identifier]
portOutNames Manifest
man
IsVoid
newInlineStrat <- ClashOpts -> IsVoid
opt_newInlineStrat (ClashOpts -> IsVoid)
-> NetlistMonad ClashOpts -> NetlistMonad IsVoid
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting ClashOpts NetlistState ClashOpts -> NetlistMonad ClashOpts
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting ClashOpts NetlistState ClashOpts
Lens' NetlistState ClashOpts
clashOpts
IdType -> Identifier -> Identifier
mkIdFn <- Getting
(IdType -> Identifier -> Identifier)
NetlistState
(IdType -> Identifier -> Identifier)
-> NetlistMonad (IdType -> Identifier -> Identifier)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
(IdType -> Identifier -> Identifier)
NetlistState
(IdType -> Identifier -> Identifier)
Lens' NetlistState (IdType -> Identifier -> Identifier)
mkIdentifierFn
ComponentPrefix
prefixM <- Getting ComponentPrefix NetlistState ComponentPrefix
-> NetlistMonad ComponentPrefix
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting ComponentPrefix NetlistState ComponentPrefix
Lens' NetlistState ComponentPrefix
componentPrefix
let topName :: Identifier
topName = IsVoid
-> (IdType -> Identifier -> Identifier)
-> ComponentPrefix
-> Maybe TopEntity
-> Id
-> Identifier
genTopComponentName IsVoid
newInlineStrat IdType -> Identifier -> Identifier
mkIdFn ComponentPrefix
prefixM Maybe TopEntity
annM Id
topEntity
topM :: Maybe Identifier
topM = (TopEntity -> Identifier) -> Maybe TopEntity -> Maybe Identifier
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Identifier -> TopEntity -> Identifier
forall a b. a -> b -> a
const Identifier
topName) Maybe TopEntity
annM
let iPortSupply :: [Maybe PortName]
iPortSupply = [Maybe PortName]
-> (TopEntity -> [Maybe PortName])
-> Maybe TopEntity
-> [Maybe PortName]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe PortName -> [Maybe PortName]
forall a. a -> [a]
repeat Maybe PortName
forall a. Maybe a
Nothing)
([PortName] -> [Maybe PortName]
extendPorts ([PortName] -> [Maybe PortName])
-> (TopEntity -> [PortName]) -> TopEntity -> [Maybe PortName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopEntity -> [PortName]
t_inputs)
Maybe TopEntity
annM
[(Identifier, HWType)]
arguments <- ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Int]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (((Expr, HWType) -> (Identifier, HWType))
-> [(Expr, HWType)] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Expr, HWType)
a -> (Identifier
"input",(Expr, HWType) -> HWType
forall a b. (a, b) -> b
snd (Expr, HWType)
a)) [(Expr, HWType)]
args) [Int
0..]
([(Identifier, Identifier)]
_,[([(Identifier, Identifier, HWType)], [Declaration],
Either Identifier (Identifier, HWType))]
arguments1) <- ([(Identifier, Identifier)]
-> (Maybe PortName, (Identifier, HWType))
-> NetlistMonad
([(Identifier, Identifier)],
([(Identifier, Identifier, HWType)], [Declaration],
Either Identifier (Identifier, HWType))))
-> [(Identifier, Identifier)]
-> [(Maybe PortName, (Identifier, HWType))]
-> NetlistMonad
([(Identifier, Identifier)],
[([(Identifier, Identifier, HWType)], [Declaration],
Either Identifier (Identifier, HWType))])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
List.mapAccumLM (\[(Identifier, Identifier)]
acc (Maybe PortName
p,(Identifier, HWType)
i) -> Maybe Identifier
-> [(Identifier, Identifier)]
-> Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
([(Identifier, Identifier)],
([(Identifier, Identifier, HWType)], [Declaration],
Either Identifier (Identifier, HWType)))
mkTopInput Maybe Identifier
topM [(Identifier, Identifier)]
acc Maybe PortName
p (Identifier, HWType)
i)
([Identifier] -> [Identifier] -> [(Identifier, Identifier)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Identifier]
inNames [Identifier]
inTys)
([Maybe PortName]
-> [(Identifier, HWType)]
-> [(Maybe PortName, (Identifier, HWType))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe PortName]
iPortSupply [(Identifier, HWType)]
arguments)
let ([[(Identifier, Identifier, HWType)]]
iports,[[Declaration]]
wrappers,[Either Identifier (Identifier, HWType)]
idsI) = [([(Identifier, Identifier, HWType)], [Declaration],
Either Identifier (Identifier, HWType))]
-> ([[(Identifier, Identifier, HWType)]], [[Declaration]],
[Either Identifier (Identifier, HWType)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [([(Identifier, Identifier, HWType)], [Declaration],
Either Identifier (Identifier, HWType))]
arguments1
inpAssigns :: [Declaration]
inpAssigns = (Either Identifier (Identifier, HWType) -> Expr -> Declaration)
-> [Either Identifier (Identifier, HWType)]
-> [Expr]
-> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Maybe Identifier
-> Either Identifier (Identifier, HWType) -> Expr -> Declaration
argBV Maybe Identifier
topM) [Either Identifier (Identifier, HWType)]
idsI (((Expr, HWType) -> Expr) -> [(Expr, HWType)] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Expr, HWType) -> Expr
forall a b. (a, b) -> a
fst [(Expr, HWType)]
args)
let oPortSupply :: [Maybe PortName]
oPortSupply = [Maybe PortName]
-> (TopEntity -> [Maybe PortName])
-> Maybe TopEntity
-> [Maybe PortName]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(Maybe PortName -> [Maybe PortName]
forall a. a -> [a]
repeat Maybe PortName
forall a. Maybe a
Nothing)
([PortName] -> [Maybe PortName]
extendPorts ([PortName] -> [Maybe PortName])
-> (TopEntity -> [PortName]) -> TopEntity -> [Maybe PortName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PortName -> [PortName] -> [PortName]
forall a. a -> [a] -> [a]
:[]) (PortName -> [PortName])
-> (TopEntity -> PortName) -> TopEntity -> [PortName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopEntity -> PortName
t_output)
Maybe TopEntity
annM
let iResult :: [Declaration]
iResult = [Declaration]
inpAssigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
wrappers
result :: (Identifier, HWType)
result = (Identifier
"result",(Identifier, HWType) -> HWType
forall a b. (a, b) -> b
snd (Identifier, HWType)
dstId)
Identifier
instLabel0 <- IdType -> Identifier -> Identifier -> NetlistMonad Identifier
extendIdentifier IdType
Basic Identifier
topName (Identifier
"_" Identifier -> Identifier -> Identifier
`Text.append` (Identifier, HWType) -> Identifier
forall a b. (a, b) -> a
fst (Identifier, HWType)
dstId)
Identifier
instLabel1 <- Identifier -> Maybe Identifier -> Identifier
forall a. a -> Maybe a -> a
fromMaybe Identifier
instLabel0 (Maybe Identifier -> Identifier)
-> NetlistMonad (Maybe Identifier) -> NetlistMonad Identifier
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Maybe Identifier) NetlistEnv (Maybe Identifier)
-> NetlistMonad (Maybe Identifier)
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting (Maybe Identifier) NetlistEnv (Maybe Identifier)
Lens' NetlistEnv (Maybe Identifier)
setName
Identifier
instLabel2 <- Identifier -> NetlistMonad Identifier
affixName Identifier
instLabel1
Identifier
instLabel3 <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Basic Identifier
instLabel2
Maybe
([(Identifier, Identifier)],
([(Identifier, Identifier, HWType)], [Declaration],
Either Identifier (Identifier, HWType)))
topOutputM <- Maybe Identifier
-> [(Identifier, Identifier)]
-> Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
(Maybe
([(Identifier, Identifier)],
([(Identifier, Identifier, HWType)], [Declaration],
Either Identifier (Identifier, HWType))))
mkTopOutput Maybe Identifier
topM ([Identifier] -> [Identifier] -> [(Identifier, Identifier)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Identifier]
outNames [Identifier]
outTys) ([Maybe PortName] -> Maybe PortName
forall a. [a] -> a
head [Maybe PortName]
oPortSupply) (Identifier, HWType)
result
let
topCompDecl :: [(Identifier, Identifier, HWType)] -> Declaration
topCompDecl [(Identifier, Identifier, HWType)]
oports =
EntityOrComponent
-> Maybe Identifier
-> Identifier
-> Identifier
-> [(Expr, HWType, Expr)]
-> [(Expr, PortDirection, HWType, Expr)]
-> Declaration
InstDecl
EntityOrComponent
Entity
(Identifier -> Maybe Identifier
forall a. a -> Maybe a
Just Identifier
topName)
Identifier
topName
Identifier
instLabel3
[]
( ((Identifier, Identifier, HWType)
-> (Expr, PortDirection, HWType, Expr))
-> [(Identifier, Identifier, HWType)]
-> [(Expr, PortDirection, HWType, Expr)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Identifier
p,Identifier
i,HWType
t) -> (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
p Maybe Modifier
forall a. Maybe a
Nothing,PortDirection
In, HWType
t,Identifier -> Maybe Modifier -> Expr
Identifier Identifier
i Maybe Modifier
forall a. Maybe a
Nothing)) ([[(Identifier, Identifier, HWType)]]
-> [(Identifier, Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, Identifier, HWType)]]
iports) [(Expr, PortDirection, HWType, Expr)]
-> [(Expr, PortDirection, HWType, Expr)]
-> [(Expr, PortDirection, HWType, Expr)]
forall a. [a] -> [a] -> [a]
++
((Identifier, Identifier, HWType)
-> (Expr, PortDirection, HWType, Expr))
-> [(Identifier, Identifier, HWType)]
-> [(Expr, PortDirection, HWType, Expr)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Identifier
p,Identifier
o,HWType
t) -> (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
p Maybe Modifier
forall a. Maybe a
Nothing,PortDirection
Out,HWType
t,Identifier -> Maybe Modifier -> Expr
Identifier Identifier
o Maybe Modifier
forall a. Maybe a
Nothing)) [(Identifier, Identifier, HWType)]
oports)
case Maybe
([(Identifier, Identifier)],
([(Identifier, Identifier, HWType)], [Declaration],
Either Identifier (Identifier, HWType)))
topOutputM of
Maybe
([(Identifier, Identifier)],
([(Identifier, Identifier, HWType)], [Declaration],
Either Identifier (Identifier, HWType)))
Nothing ->
[Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([(Identifier, Identifier, HWType)] -> Declaration
topCompDecl [] Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: [Declaration]
iResult)
Just ([(Identifier, Identifier)]
_, ([(Identifier, Identifier, HWType)]
oports, [Declaration]
unwrappers, Either Identifier (Identifier, HWType)
idsO)) -> do
let outpAssign :: Declaration
outpAssign = Identifier -> Expr -> Declaration
Assignment ((Identifier, HWType) -> Identifier
forall a b. (a, b) -> a
fst (Identifier, HWType)
dstId) (Maybe Identifier -> Either Identifier (Identifier, HWType) -> Expr
resBV Maybe Identifier
topM Either Identifier (Identifier, HWType)
idsO)
[Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Declaration]
iResult [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ ([(Identifier, Identifier, HWType)] -> Declaration
topCompDecl [(Identifier, Identifier, HWType)]
oportsDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
unwrappers) [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
outpAssign])
argBV
:: Maybe Identifier
-> Either Identifier (Identifier, HWType)
-> Expr
-> Declaration
argBV :: Maybe Identifier
-> Either Identifier (Identifier, HWType) -> Expr -> Declaration
argBV Maybe Identifier
_ (Left Identifier
i) Expr
e = Identifier -> Expr -> Declaration
Assignment Identifier
i Expr
e
argBV Maybe Identifier
topM (Right (Identifier
i,HWType
t)) Expr
e = Identifier -> Expr -> Declaration
Assignment Identifier
i
(Expr -> Declaration) -> (Expr -> Expr) -> Expr -> Declaration
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HWType -> Maybe (Maybe Identifier) -> IsVoid -> Expr -> Expr
doConv HWType
t ((Identifier -> Maybe Identifier)
-> Maybe Identifier -> Maybe (Maybe Identifier)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Identifier -> Maybe Identifier
forall a. a -> Maybe a
Just Maybe Identifier
topM) IsVoid
False
(Expr -> Declaration) -> Expr -> Declaration
forall a b. (a -> b) -> a -> b
$ HWType -> Maybe (Maybe Identifier) -> IsVoid -> Expr -> Expr
doConv HWType
t ((Identifier -> Maybe Identifier)
-> Maybe Identifier -> Maybe (Maybe Identifier)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Identifier -> Identifier -> Maybe Identifier
forall a b. a -> b -> a
const Maybe Identifier
forall a. Maybe a
Nothing) Maybe Identifier
topM) IsVoid
True Expr
e
resBV
:: Maybe Identifier
-> Either Identifier (Identifier, HWType)
-> Expr
resBV :: Maybe Identifier -> Either Identifier (Identifier, HWType) -> Expr
resBV Maybe Identifier
_ (Left Identifier
i) = Identifier -> Maybe Modifier -> Expr
Identifier Identifier
i Maybe Modifier
forall a. Maybe a
Nothing
resBV Maybe Identifier
topM (Right (Identifier
i,HWType
t)) = HWType -> Maybe (Maybe Identifier) -> IsVoid -> Expr -> Expr
doConv HWType
t ((Identifier -> Maybe Identifier)
-> Maybe Identifier -> Maybe (Maybe Identifier)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Identifier -> Identifier -> Maybe Identifier
forall a b. a -> b -> a
const Maybe Identifier
forall a. Maybe a
Nothing) Maybe Identifier
topM) IsVoid
False
(Expr -> Expr) -> (Expr -> Expr) -> Expr -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HWType -> Maybe (Maybe Identifier) -> IsVoid -> Expr -> Expr
doConv HWType
t ((Identifier -> Maybe Identifier)
-> Maybe Identifier -> Maybe (Maybe Identifier)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Identifier -> Maybe Identifier
foral