{-|
  Copyright   :  (C) 2012-2016, University of Twente,
                     2016-2017, Myrtle Software Ltd,
                     2017-2018, Google Inc.,
                     2021-2024, QBayLogic B.V.
                     2022     , Google Inc.
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>

  Create Netlists out of normalized CoreHW Terms
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

module Clash.Netlist where

import           Control.Exception                (throw)
import           Control.Lens                     ((.=), (<~))
import qualified Control.Lens                     as Lens
import           Control.Monad                    (zipWithM)
import           Control.Monad.Extra              (concatMapM, mapMaybeM)
import           Control.Monad.Reader             (runReaderT)
import           Control.Monad.State.Strict       (State, runStateT, runState)
import           Data.Bifunctor                   (first, second)
import           Data.Char                        (ord)
import           Data.Either                      (partitionEithers, rights)
import           Data.Foldable                    (foldlM)
import           Data.List                        (elemIndex, partition)
import           Data.List.Extra                  (zipEqual)
import           Data.List.NonEmpty               (NonEmpty (..))
import qualified Data.List.NonEmpty.Extra         as NE
import           Data.Maybe
  (listToMaybe, fromMaybe)
import qualified Data.Map.Ordered                 as OMap
import qualified Data.Set                         as Set
import qualified Data.Text                        as StrictText
import           GHC.Stack                        (HasCallStack)

#if MIN_VERSION_ghc(9,0,0)
import           GHC.Utils.Outputable             (ppr, showSDocUnsafe)
import           GHC.Types.SrcLoc                 (isGoodSrcSpan)
#else
import           Outputable                       (ppr, showSDocUnsafe)
import           SrcLoc                           (isGoodSrcSpan)
#endif

import           Clash.Annotations.Primitive      (HDL)
import           Clash.Annotations.BitRepresentation.ClashLib
  (coreToType')
import           Clash.Annotations.BitRepresentation.Internal
  (CustomReprs, DataRepr'(..), ConstrRepr'(..), getDataRepr, getConstrRepr)
import           Clash.Core.DataCon               (DataCon (..))
import           Clash.Core.HasType
import           Clash.Core.Literal               (Literal (..))
import           Clash.Core.Name                  (Name(..))
import           Clash.Core.Pretty                (showPpr)
import           Clash.Core.Term
  (IsMultiPrim (..), PrimInfo (..), mpi_resultTypes,  Alt, Pat (..), Term (..),
   TickInfo (..), collectArgs, collectArgsTicks,
   collectTicks, mkApps, mkTicks, stripTicks)
import qualified Clash.Core.Term                  as Core
import           Clash.Core.TermInfo              (multiPrimInfo', splitMultiPrimArgs)
import           Clash.Core.Type
  (Type (..), coreView1, splitFunForallTy, splitCoreFunForallTy)
import           Clash.Core.TyCon                 (TyConMap)
import           Clash.Core.Util                  (splitShouldSplit)
import           Clash.Core.Var                   (Id, Var (..), isGlobalId)
import           Clash.Core.VarEnv
  (VarEnv, emptyInScopeSet, emptyVarEnv, extendVarEnv, lookupVarEnv,
   lookupVarEnv')
import           Clash.Driver.Types               (BindingMap, Binding(..), ClashEnv(..), ClashOpts (..))
import           Clash.Netlist.BlackBox
import qualified Clash.Netlist.Id                 as Id
import           Clash.Netlist.Types              as HW
import           Clash.Netlist.Util
import           Clash.Primitives.Types           as P
import           Clash.Util
import qualified Clash.Util.Interpolate           as I

-- | Generate a hierarchical netlist out of a set of global binders with
-- @topEntity@ at the top.
genNetlist
  :: ClashEnv
  -> Bool
  -- ^ Whether this we're compiling a testbench (suppresses certain warnings)
  -> BindingMap
  -- ^ Global binders
  -> VarEnv TopEntityT
  -- ^ TopEntity annotations
  -> VarEnv Identifier
  -- ^ Top entity names
  -> (CustomReprs -> TyConMap -> Type ->
      State HWMap (Maybe (Either String FilteredHWType)))
  -- ^ Hardcoded Type -> HWType translator
  -> Bool
  -- ^ Whether the backend supports ifThenElse expressions
  -> SomeBackend
  -- ^ The current HDL backend
  -> IdentifierSet
  -- ^ Seen components
  -> FilePath
  -- ^ HDL dir
  -> Maybe StrictText.Text
  -- ^ Component name prefix
  -> Id
  -- ^ Name of the @topEntity@
  -> IO (Component, ComponentMap, IdentifierSet)
genNetlist :: ClashEnv
-> Bool
-> BindingMap
-> VarEnv TopEntityT
-> VarEnv Identifier
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> Bool
-> SomeBackend
-> IdentifierSet
-> String
-> Maybe Text
-> Id
-> IO (Component, ComponentMap, IdentifierSet)
genNetlist ClashEnv
env Bool
isTb BindingMap
globals VarEnv TopEntityT
tops VarEnv Identifier
topNames CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
typeTrans Bool
ite SomeBackend
be IdentifierSet
seen0 String
dir Maybe Text
prefixM Id
topEntity = do
  ((ComponentMeta
_meta, Component
topComponent), NetlistState
s) <-
    ClashEnv
-> Bool
-> BindingMap
-> VarEnv TopEntityT
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> Bool
-> SomeBackend
-> IdentifierSet
-> String
-> VarEnv Identifier
-> NetlistMonad (ComponentMeta, Component)
-> IO ((ComponentMeta, Component), NetlistState)
forall a.
ClashEnv
-> Bool
-> BindingMap
-> VarEnv TopEntityT
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> Bool
-> SomeBackend
-> IdentifierSet
-> String
-> VarEnv Identifier
-> NetlistMonad a
-> IO (a, NetlistState)
runNetlistMonad ClashEnv
env Bool
isTb BindingMap
globals VarEnv TopEntityT
tops CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
typeTrans Bool
ite SomeBackend
be IdentifierSet
seen1 String
dir VarEnv Identifier
componentNames_
      (NetlistMonad (ComponentMeta, Component)
 -> IO ((ComponentMeta, Component), NetlistState))
-> NetlistMonad (ComponentMeta, Component)
-> IO ((ComponentMeta, Component), NetlistState)
forall a b. (a -> b) -> a -> b
$ HasCallStack => Id -> NetlistMonad (ComponentMeta, Component)
Id -> NetlistMonad (ComponentMeta, Component)
genComponent Id
topEntity
  (Component, ComponentMap, IdentifierSet)
-> IO (Component, ComponentMap, IdentifierSet)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Component
topComponent, NetlistState -> ComponentMap
_components NetlistState
s, IdentifierSet
seen1)
 where
  (VarEnv Identifier
componentNames_, IdentifierSet
seen1) =
    Bool
-> Maybe Text
-> IdentifierSet
-> VarEnv Identifier
-> BindingMap
-> (VarEnv Identifier, IdentifierSet)
genNames (ClashOpts -> Bool
opt_newInlineStrat (ClashEnv -> ClashOpts
envOpts ClashEnv
env)) Maybe Text
prefixM IdentifierSet
seen0 VarEnv Identifier
topNames BindingMap
globals

-- | Run a NetlistMonad action in a given environment
runNetlistMonad
  :: ClashEnv
  -> Bool
  -- ^ Whether this we're compiling a testbench (suppresses certain warnings)
  -> BindingMap
  -- ^ Global binders
  -> VarEnv TopEntityT
  -- ^ TopEntity annotations
  -> (CustomReprs -> TyConMap -> Type ->
      State HWMap (Maybe (Either String FilteredHWType)))
  -- ^ Hardcode Type -> HWType translator
  -> Bool
  -- ^ Whether the backend supports ifThenElse expressions
  -> SomeBackend
  -- ^ The current HDL backend
  -> IdentifierSet
  -- ^ Seen components
  -> FilePath
  -- ^ HDL dir
  -> VarEnv Identifier
  -- ^ Seen components
  -> NetlistMonad a
  -- ^ Action to run
  -> IO (a, NetlistState)
runNetlistMonad :: ClashEnv
-> Bool
-> BindingMap
-> VarEnv TopEntityT
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> Bool
-> SomeBackend
-> IdentifierSet
-> String
-> VarEnv Identifier
-> NetlistMonad a
-> IO (a, NetlistState)
runNetlistMonad ClashEnv
env Bool
isTb BindingMap
s VarEnv TopEntityT
tops CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
typeTrans Bool
ite SomeBackend
be IdentifierSet
seenIds_ String
dir VarEnv Identifier
componentNames_
  = (ReaderT NetlistEnv IO (a, NetlistState)
 -> NetlistEnv -> IO (a, NetlistState))
-> NetlistEnv
-> ReaderT NetlistEnv IO (a, NetlistState)
-> IO (a, NetlistState)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT NetlistEnv IO (a, NetlistState)
-> NetlistEnv -> IO (a, NetlistState)
forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT (ClashEnv -> Text -> Text -> Maybe Text -> NetlistEnv
NetlistEnv ClashEnv
env Text
"" Text
"" Maybe Text
forall a. Maybe a
Nothing)
  (ReaderT NetlistEnv IO (a, NetlistState) -> IO (a, NetlistState))
-> (NetlistMonad a -> ReaderT NetlistEnv IO (a, NetlistState))
-> NetlistMonad a
-> IO (a, NetlistState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT NetlistState (ReaderT NetlistEnv IO) a
 -> NetlistState -> ReaderT NetlistEnv IO (a, NetlistState))
-> NetlistState
-> StateT NetlistState (ReaderT NetlistEnv IO) a
-> ReaderT NetlistEnv IO (a, NetlistState)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT NetlistState (ReaderT NetlistEnv IO) a
-> NetlistState -> ReaderT NetlistEnv IO (a, NetlistState)
forall s (m :: Type -> Type) a. StateT s m a -> s -> m (a, s)
runStateT NetlistState
s'
  (StateT NetlistState (ReaderT NetlistEnv IO) a
 -> ReaderT NetlistEnv IO (a, NetlistState))
-> (NetlistMonad a
    -> StateT NetlistState (ReaderT NetlistEnv IO) a)
-> NetlistMonad a
-> ReaderT NetlistEnv IO (a, NetlistState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NetlistMonad a -> StateT NetlistState (ReaderT NetlistEnv IO) a
forall a.
NetlistMonad a -> StateT NetlistState (ReaderT NetlistEnv IO) a
runNetlist
  where
    s' :: NetlistState
s' =
      NetlistState :: BindingMap
-> ComponentMap
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> (Identifier, SrcSpan)
-> IdentifierSet
-> IdentifierSet
-> Set Text
-> VarEnv Identifier
-> VarEnv TopEntityT
-> String
-> Int
-> Bool
-> Bool
-> SomeBackend
-> HWMap
-> UsageMap
-> NetlistState
NetlistState
        { _bindings :: BindingMap
_bindings=BindingMap
s
        , _components :: ComponentMap
_components=ComponentMap
forall k v. OMap k v
OMap.empty
        , _typeTranslator :: CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
_typeTranslator=CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
typeTrans
        , _curCompNm :: (Identifier, SrcSpan)
_curCompNm=(String -> Identifier
forall a. HasCallStack => String -> a
error String
"genComponent should have set _curCompNm", SrcSpan
noSrcSpan)
        , _seenIds :: IdentifierSet
_seenIds=IdentifierSet
seenIds_
        , _seenComps :: IdentifierSet
_seenComps=IdentifierSet
seenIds_
        , _seenPrimitives :: Set Text
_seenPrimitives=Set Text
forall a. Set a
Set.empty
        , _componentNames :: VarEnv Identifier
_componentNames=VarEnv Identifier
componentNames_
        , _topEntityAnns :: VarEnv TopEntityT
_topEntityAnns=VarEnv TopEntityT
tops
        , _hdlDir :: String
_hdlDir=String
dir
        , _curBBlvl :: Int
_curBBlvl=Int
0
        , _isTestBench :: Bool
_isTestBench=Bool
isTb
        , _backEndITE :: Bool
_backEndITE=Bool
ite
        , _backend :: SomeBackend
_backend=SomeBackend
be
        , _htyCache :: HWMap
_htyCache=HWMap
forall a. Monoid a => a
mempty
        , _usages :: UsageMap
_usages=UsageMap
forall a. Monoid a => a
mempty
        }

-- | Generate names for all binders in "BindingMap", except for the ones already
-- present in given identifier varenv.
genNames
  :: Bool
  -- ^ New inline strategy enabled?
  -> Maybe StrictText.Text
  -- ^ Prefix
  -> IdentifierSet
  -- ^ Identifier set to extend
  -> VarEnv Identifier
  -- ^ Pre-generated names
  -> BindingMap
  -> (VarEnv Identifier, IdentifierSet)
genNames :: Bool
-> Maybe Text
-> IdentifierSet
-> VarEnv Identifier
-> BindingMap
-> (VarEnv Identifier, IdentifierSet)
genNames Bool
newInlineStrat Maybe Text
prefixM IdentifierSet
is VarEnv Identifier
env BindingMap
bndrs =
  State IdentifierSet (VarEnv Identifier)
-> IdentifierSet -> (VarEnv Identifier, IdentifierSet)
forall s a. State s a -> s -> (a, s)
runState ((VarEnv Identifier
 -> Binding Term -> State IdentifierSet (VarEnv Identifier))
-> VarEnv Identifier
-> BindingMap
-> State IdentifierSet (VarEnv Identifier)
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM VarEnv Identifier
-> Binding Term -> State IdentifierSet (VarEnv Identifier)
forall (f :: Type -> Type) a.
IdentifierSetMonad f =>
VarEnv Identifier -> Binding a -> f (VarEnv Identifier)
go VarEnv Identifier
env BindingMap
bndrs) IdentifierSet
is
 where
  go :: VarEnv Identifier -> Binding a -> f (VarEnv Identifier)
go VarEnv Identifier
env_ (Binding a -> Id
forall a. Binding a -> Id
bindingId -> Id
id_) =
    case Id -> VarEnv Identifier -> Maybe Identifier
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
id_ VarEnv Identifier
env_ of
      Just Identifier
_ -> VarEnv Identifier -> f (VarEnv Identifier)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure VarEnv Identifier
env_
      Maybe Identifier
Nothing -> do
        Identifier
nm <- Text -> f Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic (Bool -> Maybe Text -> Id -> Text
genComponentName Bool
newInlineStrat Maybe Text
prefixM Id
id_)
        VarEnv Identifier -> f (VarEnv Identifier)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Id -> Identifier -> VarEnv Identifier -> VarEnv Identifier
forall b a. Var b -> a -> VarEnv a -> VarEnv a
extendVarEnv Id
id_ Identifier
nm VarEnv Identifier
env_)

-- | Generate names for top entities. Should be executed at the very start of
-- the synthesis process and shared between all passes.
genTopNames
  :: ClashOpts
  -> HDL
  -- ^ HDL to generate identifiers for
  -> [TopEntityT]
  -> (VarEnv Identifier, IdentifierSet)
genTopNames :: ClashOpts
-> HDL -> [TopEntityT] -> (VarEnv Identifier, IdentifierSet)
genTopNames ClashOpts
opts HDL
hdl [TopEntityT]
tops =
  -- TODO: Report error if fixed top entities have conflicting names
  (State IdentifierSet (VarEnv Identifier)
 -> IdentifierSet -> (VarEnv Identifier, IdentifierSet))
-> IdentifierSet
-> State IdentifierSet (VarEnv Identifier)
-> (VarEnv Identifier, IdentifierSet)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State IdentifierSet (VarEnv Identifier)
-> IdentifierSet -> (VarEnv Identifier, IdentifierSet)
forall s a. State s a -> s -> (a, s)
runState (Bool -> PreserveCase -> HDL -> IdentifierSet
Id.emptyIdentifierSet Bool
esc PreserveCase
lw HDL
hdl) (State IdentifierSet (VarEnv Identifier)
 -> (VarEnv Identifier, IdentifierSet))
-> State IdentifierSet (VarEnv Identifier)
-> (VarEnv Identifier, IdentifierSet)
forall a b. (a -> b) -> a -> b
$ do
    VarEnv Identifier
env0 <- (VarEnv Identifier
 -> (Id, TopEntity) -> State IdentifierSet (VarEnv Identifier))
-> VarEnv Identifier
-> [(Id, TopEntity)]
-> State IdentifierSet (VarEnv Identifier)
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM VarEnv Identifier
-> (Id, TopEntity) -> State IdentifierSet (VarEnv Identifier)
forall (m :: Type -> Type) b.
IdentifierSetMonad m =>
VarEnv Identifier -> (Var b, TopEntity) -> m (VarEnv Identifier)
goFixed VarEnv Identifier
forall a. VarEnv a
emptyVarEnv [(Id, TopEntity)]
fixedTops
    VarEnv Identifier
env1 <- (VarEnv Identifier
 -> Id -> State IdentifierSet (VarEnv Identifier))
-> VarEnv Identifier
-> [Id]
-> State IdentifierSet (VarEnv Identifier)
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM VarEnv Identifier -> Id -> State IdentifierSet (VarEnv Identifier)
forall (m :: Type -> Type).
IdentifierSetMonad m =>
VarEnv Identifier -> Id -> m (VarEnv Identifier)
goNonFixed VarEnv Identifier
env0 [Id]
nonFixedTops
    VarEnv Identifier -> State IdentifierSet (VarEnv Identifier)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure VarEnv Identifier
env1
 where
  prefixM :: Maybe Text
prefixM = ClashOpts -> Maybe Text
opt_componentPrefix ClashOpts
opts
  esc :: Bool
esc = ClashOpts -> Bool
opt_escapedIds ClashOpts
opts
  lw :: PreserveCase
lw = ClashOpts -> PreserveCase
opt_lowerCaseBasicIds ClashOpts
opts

  fixedTops :: [(Id, TopEntity)]
fixedTops = [(Id
topId, TopEntity
ann) | TopEntityT{Id
topId :: TopEntityT -> Id
topId :: Id
topId, topAnnotation :: TopEntityT -> Maybe TopEntity
topAnnotation=Just TopEntity
ann} <- [TopEntityT]
tops]
  nonFixedTops :: [Id]
nonFixedTops = [Id
topId | TopEntityT{Id
topId :: Id
topId :: TopEntityT -> Id
topId, topAnnotation :: TopEntityT -> Maybe TopEntity
topAnnotation=Maybe TopEntity
Nothing} <- [TopEntityT]
tops]

  goFixed :: VarEnv Identifier -> (Var b, TopEntity) -> m (VarEnv Identifier)
goFixed VarEnv Identifier
env (Var b
topId, TopEntity
ann) = do
    Identifier
topNm <- Maybe Text -> TopEntity -> m Identifier
forall (m :: Type -> Type).
IdentifierSetMonad m =>
Maybe Text -> TopEntity -> m Identifier
genTopName Maybe Text
prefixM TopEntity
ann
    VarEnv Identifier -> m (VarEnv Identifier)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Var b -> Identifier -> VarEnv Identifier -> VarEnv Identifier
forall b a. Var b -> a -> VarEnv a -> VarEnv a
extendVarEnv Var b
topId Identifier
topNm VarEnv Identifier
env)

  goNonFixed :: VarEnv Identifier -> Id -> m (VarEnv Identifier)
goNonFixed VarEnv Identifier
env Id
id_ = do
    Identifier
topNm <- Text -> m Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic (Bool -> Maybe Text -> Id -> Text
genComponentName Bool
True Maybe Text
prefixM Id
id_)
    VarEnv Identifier -> m (VarEnv Identifier)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Id -> Identifier -> VarEnv Identifier -> VarEnv Identifier
forall b a. Var b -> a -> VarEnv a -> VarEnv a
extendVarEnv Id
id_ Identifier
topNm VarEnv Identifier
env)

-- | Generate a component for a given function (caching)
genComponent
  :: HasCallStack
  => Id
  -- ^ Name of the function
  -> NetlistMonad (ComponentMeta, Component)
genComponent :: Id -> NetlistMonad (ComponentMeta, Component)
genComponent Id
compName = do
  Maybe (Binding Term)
compExprM <- Id -> BindingMap -> Maybe (Binding Term)
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
compName (BindingMap -> Maybe (Binding Term))
-> NetlistMonad BindingMap -> NetlistMonad (Maybe (Binding Term))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting BindingMap NetlistState BindingMap
-> NetlistMonad BindingMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting BindingMap NetlistState BindingMap
Lens' NetlistState BindingMap
bindings
  case Maybe (Binding Term)
compExprM of
    Maybe (Binding Term)
Nothing -> do
      (Identifier
_,SrcSpan
sp) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
      ClashException -> NetlistMonad (ComponentMeta, Component)
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
"No normalized expression found for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Id -> String
forall a. Show a => a -> String
show Id
compName) Maybe String
forall a. Maybe a
Nothing)
    Just Binding Term
b -> do
      Id
-> Lens' NetlistState ComponentMap
-> NetlistMonad (ComponentMeta, Component)
-> NetlistMonad (ComponentMeta, Component)
forall s (m :: Type -> Type) k v.
(MonadState s m, Uniquable k) =>
k -> Lens' s (OMap Int v) -> m v -> m v
makeCachedO Id
compName Lens' NetlistState ComponentMap
components (NetlistMonad (ComponentMeta, Component)
 -> NetlistMonad (ComponentMeta, Component))
-> NetlistMonad (ComponentMeta, Component)
-> NetlistMonad (ComponentMeta, Component)
forall a b. (a -> b) -> a -> b
$ HasCallStack =>
Id -> Term -> NetlistMonad (ComponentMeta, Component)
Id -> Term -> NetlistMonad (ComponentMeta, Component)
genComponentT Id
compName (Binding Term -> Term
forall a. Binding a -> a
bindingTerm Binding Term
b)

-- | Generate a component for a given function
genComponentT
  :: HasCallStack
  => Id
  -- ^ Name of the function
  -> Term
  -- ^ Corresponding term
  -> NetlistMonad (ComponentMeta, Component)
genComponentT :: Id -> Term -> NetlistMonad (ComponentMeta, Component)
genComponentT Id
compName0 Term
componentExpr = do
  TyConMap
tcm <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
  Identifier
compName1 <- (VarEnv Identifier -> Id -> Identifier
forall a b. HasCallStack => VarEnv a -> Var b -> a
`lookupVarEnv'` Id
compName0) (VarEnv Identifier -> Identifier)
-> NetlistMonad (VarEnv Identifier) -> NetlistMonad Identifier
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (VarEnv Identifier) NetlistState (VarEnv Identifier)
-> NetlistMonad (VarEnv Identifier)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (VarEnv Identifier) NetlistState (VarEnv Identifier)
Lens' NetlistState (VarEnv Identifier)
componentNames
  SrcSpan
sp <- (Binding Term -> SrcSpan
forall a. Binding a -> SrcSpan
bindingLoc (Binding Term -> SrcSpan)
-> (BindingMap -> Binding Term) -> BindingMap -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BindingMap -> Id -> Binding Term
forall a b. HasCallStack => VarEnv a -> Var b -> a
`lookupVarEnv'` Id
compName0)) (BindingMap -> SrcSpan)
-> NetlistMonad BindingMap -> NetlistMonad SrcSpan
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting BindingMap NetlistState BindingMap
-> NetlistMonad BindingMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting BindingMap NetlistState BindingMap
Lens' NetlistState BindingMap
bindings
  ((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
compName1, SrcSpan
sp)
  (UsageMap -> Identity UsageMap)
-> NetlistState -> Identity NetlistState
Lens' NetlistState UsageMap
usages ((UsageMap -> Identity UsageMap)
 -> NetlistState -> Identity NetlistState)
-> UsageMap -> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= UsageMap
forall a. Monoid a => a
mempty

  Maybe TopEntityT
topEntityTM <- Id -> VarEnv TopEntityT -> Maybe TopEntityT
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
compName0 (VarEnv TopEntityT -> Maybe TopEntityT)
-> NetlistMonad (VarEnv TopEntityT)
-> NetlistMonad (Maybe TopEntityT)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (VarEnv TopEntityT) NetlistState (VarEnv TopEntityT)
-> NetlistMonad (VarEnv TopEntityT)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (VarEnv TopEntityT) NetlistState (VarEnv TopEntityT)
Lens' NetlistState (VarEnv TopEntityT)
topEntityAnns
  let topAnnMM :: Maybe (Maybe TopEntity)
topAnnMM = TopEntityT -> Maybe TopEntity
topAnnotation (TopEntityT -> Maybe TopEntity)
-> Maybe TopEntityT -> Maybe (Maybe TopEntity)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TopEntityT
topEntityTM
      topVarTypeM :: Maybe Type
topVarTypeM = ([Either TyVar Type], Type) -> Type
forall a b. (a, b) -> b
snd (([Either TyVar Type], Type) -> Type)
-> (TopEntityT -> ([Either TyVar Type], Type))
-> TopEntityT
-> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyConMap -> Type -> ([Either TyVar Type], Type)
splitCoreFunForallTy TyConMap
tcm (Type -> ([Either TyVar Type], Type))
-> (TopEntityT -> Type)
-> TopEntityT
-> ([Either TyVar Type], Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
forall a. HasType a => a -> Type
coreTypeOf (Id -> Type) -> (TopEntityT -> Id) -> TopEntityT -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopEntityT -> Id
topId (TopEntityT -> Type) -> Maybe TopEntityT -> Maybe Type
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TopEntityT
topEntityTM

  (IdentifierSet -> Identity IdentifierSet)
-> NetlistState -> Identity NetlistState
Lens' NetlistState IdentifierSet
seenIds ((IdentifierSet -> Identity IdentifierSet)
 -> NetlistState -> Identity NetlistState)
-> NetlistMonad IdentifierSet -> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> m b -> m ()
<~ Getting IdentifierSet NetlistState IdentifierSet
-> NetlistMonad IdentifierSet
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting IdentifierSet NetlistState IdentifierSet
Lens' NetlistState IdentifierSet
seenComps
  ([Bool]
wereVoids,[(Identifier, HWType)]
compInps,[Declaration]
argWrappers,[(Identifier, HWType)]
compOutps,[Declaration]
resUnwrappers,[LetBinding]
binders,Maybe Id
resultM) <-
    case TyConMap -> Term -> Either String ([Id], [LetBinding], Id)
splitNormalized TyConMap
tcm Term
componentExpr of
      Right ([Id]
args, [LetBinding]
binds, Id
res) -> do
        let varType1 :: Type
varType1 = Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe (Id -> Type
forall a. HasType a => a -> Type
coreTypeOf Id
res) Maybe Type
topVarTypeM
        HasCallStack =>
InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([Bool], [(Identifier, HWType)], [Declaration],
      [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([Bool], [(Identifier, HWType)], [Declaration],
      [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
mkUniqueNormalized
          InScopeSet
emptyInScopeSet
          Maybe (Maybe TopEntity)
topAnnMM
          -- HACK: Determine resulttype of this function by looking at its definition
          -- instead of looking at its last binder (which obscures any attributes
          -- [see: Clash.Annotations.SynthesisAttributes]).
          (([Id]
args, [LetBinding]
binds, Id
res{varType :: Type
varType=Type
varType1}))
      Left String
err ->
        ClashException
-> NetlistMonad
     ([Bool], [(Identifier, HWType)], [Declaration],
      [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
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
err) Maybe String
forall a. Maybe a
Nothing)

  [Declaration]
netDecls <- (LetBinding -> NetlistMonad [Declaration])
-> [LetBinding] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m [b]) -> [a] -> m [b]
concatMapM LetBinding -> NetlistMonad [Declaration]
mkNetDecl ((LetBinding -> Bool) -> [LetBinding] -> [LetBinding]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Id -> Bool) -> (Id -> Id -> Bool) -> Maybe Id -> Id -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> Id -> Bool
forall a b. a -> b -> a
const Bool
True) Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
(/=) Maybe Id
resultM (Id -> Bool) -> (LetBinding -> Id) -> LetBinding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LetBinding -> Id
forall a b. (a, b) -> a
fst) [LetBinding]
binders)
  [Declaration]
decls    <- [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[Declaration]] -> [Declaration])
-> NetlistMonad [[Declaration]] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (LetBinding -> NetlistMonad [Declaration])
-> [LetBinding] -> NetlistMonad [[Declaration]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Id -> Term -> NetlistMonad [Declaration])
-> LetBinding -> NetlistMonad [Declaration]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HasCallStack => Id -> Term -> NetlistMonad [Declaration]
Id -> Term -> NetlistMonad [Declaration]
mkDeclarations) [LetBinding]
binders

  case Maybe Id
resultM of
    Just Id
result -> do
      [NetDecl' Maybe Text
_ Identifier
_ HWType
_ Maybe Expr
rIM] <- case (LetBinding -> Bool) -> [LetBinding] -> [LetBinding]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
==Id
result) (Id -> Bool) -> (LetBinding -> Id) -> LetBinding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LetBinding -> Id
forall a b. (a, b) -> a
fst) [LetBinding]
binders of
        LetBinding
b:[LetBinding]
_ -> LetBinding -> NetlistMonad [Declaration]
mkNetDecl LetBinding
b
        [LetBinding]
_ -> String -> NetlistMonad [Declaration]
forall a. HasCallStack => String -> a
error String
"internal error: couldn't find result binder"

      UsageMap
u <- Getting UsageMap NetlistState UsageMap -> NetlistMonad UsageMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting UsageMap NetlistState UsageMap
Lens' NetlistState UsageMap
usages
      let useOf :: (Identifier, b) -> Usage
useOf (Identifier, b)
i = Usage -> Maybe Usage -> Usage
forall a. a -> Maybe a -> a
fromMaybe Usage
Cont (Maybe Usage -> Usage) -> Maybe Usage -> Usage
forall a b. (a -> b) -> a -> b
$ Identifier -> UsageMap -> Maybe Usage
lookupUsage ((Identifier, b) -> Identifier
forall a b. (a, b) -> a
fst (Identifier, b)
i) UsageMap
u

      let ([(Usage, (Identifier, HWType), Maybe Expr)]
compOutps',[Declaration]
resUnwrappers') = case [(Identifier, HWType)]
compOutps of
            [(Identifier, HWType)
oport] -> ([((Identifier, HWType) -> Usage
forall b. (Identifier, b) -> Usage
useOf (Identifier, HWType)
oport,(Identifier, HWType)
oport,Maybe Expr
rIM)],[Declaration]
resUnwrappers)
            [(Identifier, HWType)]
_ -> case [Declaration]
resUnwrappers of
              NetDecl Maybe Text
n Identifier
res HWType
resTy:[Declaration]
_ ->
                (((Identifier, HWType) -> (Usage, (Identifier, HWType), Maybe Expr))
-> [(Identifier, HWType)]
-> [(Usage, (Identifier, HWType), Maybe Expr)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Identifier, HWType)
op -> ((Identifier, HWType) -> Usage
forall b. (Identifier, b) -> Usage
useOf (Identifier, HWType)
op,(Identifier, HWType)
op,Maybe Expr
forall a. Maybe a
Nothing)) [(Identifier, HWType)]
compOutps
                ,Maybe Text -> Identifier -> HWType -> Maybe Expr -> Declaration
NetDecl' Maybe Text
n Identifier
res HWType
resTy Maybe Expr
forall a. Maybe a
NothingDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:Int -> [Declaration] -> [Declaration]
forall a. Int -> [a] -> [a]
drop Int
1 [Declaration]
resUnwrappers
                )
              [Declaration]
_ -> String
-> ([(Usage, (Identifier, HWType), Maybe Expr)], [Declaration])
forall a. HasCallStack => String -> a
error String
"internal error: insufficient resUnwrappers"
          component :: Component
component      = Identifier
-> [(Identifier, HWType)]
-> [(Usage, (Identifier, HWType), Maybe Expr)]
-> [Declaration]
-> Component
Component Identifier
compName1 [(Identifier, HWType)]
compInps [(Usage, (Identifier, HWType), Maybe Expr)]
compOutps'
                             ([Declaration]
netDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
argWrappers [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
decls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
resUnwrappers')
      IdentifierSet
ids <- Getting IdentifierSet NetlistState IdentifierSet
-> NetlistMonad IdentifierSet
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting IdentifierSet NetlistState IdentifierSet
Lens' NetlistState IdentifierSet
seenIds
      (ComponentMeta, Component)
-> NetlistMonad (ComponentMeta, Component)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Bool] -> SrcSpan -> IdentifierSet -> UsageMap -> ComponentMeta
ComponentMeta [Bool]
wereVoids SrcSpan
sp IdentifierSet
ids UsageMap
u, Component
component)
    -- No result declaration means that the result is empty, this only happens
    -- when the TopEntity has an empty result. We just create an empty component
    -- in this case.
    Maybe Id
Nothing -> do
      let component :: Component
component = Identifier
-> [(Identifier, HWType)]
-> [(Usage, (Identifier, HWType), Maybe Expr)]
-> [Declaration]
-> Component
Component Identifier
compName1 [(Identifier, HWType)]
compInps [] ([Declaration]
netDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
argWrappers [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
decls)
      IdentifierSet
ids <- Getting IdentifierSet NetlistState IdentifierSet
-> NetlistMonad IdentifierSet
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting IdentifierSet NetlistState IdentifierSet
Lens' NetlistState IdentifierSet
seenIds
      UsageMap
u <- Getting UsageMap NetlistState UsageMap -> NetlistMonad UsageMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting UsageMap NetlistState UsageMap
Lens' NetlistState UsageMap
usages
      (ComponentMeta, Component)
-> NetlistMonad (ComponentMeta, Component)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Bool] -> SrcSpan -> IdentifierSet -> UsageMap -> ComponentMeta
ComponentMeta [Bool]
wereVoids SrcSpan
sp IdentifierSet
ids UsageMap
u, Component
component)

mkNetDecl :: (Id, Term) -> NetlistMonad [Declaration]
mkNetDecl :: LetBinding -> NetlistMonad [Declaration]
mkNetDecl (Id
id_,Term
tm) = NetlistMonad [Declaration] -> NetlistMonad [Declaration]
forall a. NetlistMonad a -> NetlistMonad a
preserveVarEnv (NetlistMonad [Declaration] -> NetlistMonad [Declaration])
-> NetlistMonad [Declaration] -> NetlistMonad [Declaration]
forall a b. (a -> b) -> a -> b
$ do
  HWType
hwTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(String
curLoc) (Id -> Type
forall a. HasType a => a -> Type
coreTypeOf Id
id_)

  if | Bool -> Bool
not (HWType -> Term -> Bool
shouldRenderDecl HWType
hwTy Term
tm) -> [Declaration] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a. Monad m => a -> m a
return []
     | (Prim pInfo :: PrimInfo
pInfo@PrimInfo{primMultiResult :: PrimInfo -> IsMultiPrim
primMultiResult=IsMultiPrim
MultiResult}, [Either Term Type]
args) <- Term -> (Term, [Either Term Type])
collectArgs Term
tm ->
          PrimInfo -> [Either Term Type] -> NetlistMonad [Declaration]
multiDecls PrimInfo
pInfo [Either Term Type]
args
     | Bool
otherwise -> Declaration -> [Declaration]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Declaration -> [Declaration])
-> NetlistMonad Declaration -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> HWType -> NetlistMonad Declaration
singleDecl HWType
hwTy

  where
    multiDecls :: PrimInfo -> [Either Term Type] -> NetlistMonad [Declaration]
multiDecls PrimInfo
pInfo [Either Term Type]
args0 = do
      TyConMap
tcm <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
      [Expr]
resInits0 <- LetBinding -> NetlistMonad [Expr]
getResInits (Id
id_, Term
tm)
      let
        resInits1 :: [Maybe Expr]
resInits1 = (Expr -> Maybe Expr) -> [Expr] -> [Maybe Expr]
forall a b. (a -> b) -> [a] -> [b]
map Expr -> Maybe Expr
forall a. a -> Maybe a
Just [Expr]
resInits0 [Maybe Expr] -> [Maybe Expr] -> [Maybe Expr]
forall a. Semigroup a => a -> a -> a
<> Maybe Expr -> [Maybe Expr]
forall a. a -> [a]
repeat Maybe Expr
forall a. Maybe a
Nothing
        mpInfo :: MultiPrimInfo
mpInfo = HasCallStack => TyConMap -> PrimInfo -> MultiPrimInfo
TyConMap -> PrimInfo -> MultiPrimInfo
multiPrimInfo' TyConMap
tcm PrimInfo
pInfo
        ([Either Term Type]
_, [Id]
res) = HasCallStack =>
MultiPrimInfo -> [Either Term Type] -> ([Either Term Type], [Id])
MultiPrimInfo -> [Either Term Type] -> ([Either Term Type], [Id])
splitMultiPrimArgs MultiPrimInfo
mpInfo [Either Term Type]
args0

        netdecl :: Id -> HWType -> Maybe Expr -> Declaration
netdecl Id
i HWType
typ Maybe Expr
resInit =
          Maybe Text -> Identifier -> HWType -> Maybe Expr -> Declaration
NetDecl' Maybe Text
srcNote (HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId Id
i) HWType
typ Maybe Expr
resInit

      [HWType]
hwTys <- (Type -> NetlistMonad HWType) -> [Type] -> NetlistMonad [HWType]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(String
curLoc)) (MultiPrimInfo -> [Type]
mpi_resultTypes MultiPrimInfo
mpInfo)
      [Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Id -> HWType -> Maybe Expr -> Declaration)
-> [Id] -> [HWType] -> [Maybe Expr] -> [Declaration]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Id -> HWType -> Maybe Expr -> Declaration
netdecl [Id]
res [HWType]
hwTys [Maybe Expr]
resInits1)

    singleDecl :: HWType -> NetlistMonad Declaration
singleDecl HWType
hwTy = do
      Maybe Expr
rIM <- [Expr] -> Maybe Expr
forall a. [a] -> Maybe a
listToMaybe ([Expr] -> Maybe Expr)
-> NetlistMonad [Expr] -> NetlistMonad (Maybe Expr)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> LetBinding -> NetlistMonad [Expr]
getResInits (Id
id_, Term
tm)
      Declaration -> NetlistMonad Declaration
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe Text -> Identifier -> HWType -> Maybe Expr -> Declaration
NetDecl' Maybe Text
srcNote (HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId Id
id_) HWType
hwTy Maybe Expr
rIM)

    addSrcNote :: SrcSpan -> Maybe Text
addSrcNote SrcSpan
loc
      | SrcSpan -> Bool
isGoodSrcSpan SrcSpan
loc = Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
StrictText.pack (SDoc -> String
showSDocUnsafe (SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
loc)))
      | Bool
otherwise = Maybe Text
forall a. Maybe a
Nothing

    srcNote :: Maybe Text
srcNote = SrcSpan -> Maybe Text
addSrcNote (SrcSpan -> Maybe Text) -> SrcSpan -> Maybe Text
forall a b. (a -> b) -> a -> b
$ case Term
tm of
      Tick (SrcSpan SrcSpan
s) Term
_ -> SrcSpan
s
      Term
_ -> Name Term -> SrcSpan
forall a. Name a -> SrcSpan
nameLoc (Id -> Name Term
forall a. Var a -> Name a
varName Id
id_)

    isMultiPrimSelect :: Term -> Bool
    isMultiPrimSelect :: Term -> Bool
isMultiPrimSelect Term
t = case Term -> (Term, [Either Term Type])
collectArgs Term
t of
      (Prim (PrimInfo -> Text
primName -> Text
"c$multiPrimSelect"), [Either Term Type]
_) -> Bool
True
      (Term, [Either Term Type])
_ -> Bool
False

    shouldRenderDecl :: HWType -> Term -> Bool
    shouldRenderDecl :: HWType -> Term -> Bool
shouldRenderDecl HWType
ty Term
t
      | HWType -> Bool
isVoid HWType
ty = Bool
False
      | Term -> Bool
isMultiPrimSelect Term
t = Bool
False
      | Bool
otherwise = Bool
True

    -- Set the initialization value of a signal when a primitive wants to set it
    getResInits :: (Id, Term) -> NetlistMonad [Expr]
    getResInits :: LetBinding -> NetlistMonad [Expr]
getResInits (Id
i,Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks -> (Term
k,[Either Term Type]
args0,[TickInfo]
ticks)) = case Term
k of
      Prim PrimInfo
p -> HasCallStack => Text -> NetlistMonad CompiledPrimitive
Text -> NetlistMonad CompiledPrimitive
extractPrimWarnOrFail (PrimInfo -> Text
primName PrimInfo
p) NetlistMonad CompiledPrimitive
-> (CompiledPrimitive -> NetlistMonad [Expr])
-> NetlistMonad [Expr]
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= PrimInfo -> CompiledPrimitive -> NetlistMonad [Expr]
forall a c d.
PrimInfo -> Primitive a BlackBox c d -> NetlistMonad [Expr]
go PrimInfo
p
      Term
_ -> [Expr] -> NetlistMonad [Expr]
forall (m :: Type -> Type) a. Monad m => a -> m a
return []
     where
      go :: PrimInfo -> Primitive a BlackBox c d -> NetlistMonad [Expr]
go PrimInfo
pInfo (BlackBox {resultInits :: forall a b c d. Primitive a b c d -> [b]
resultInits=[BlackBox]
nmDs, multiResult :: forall a b c d. Primitive a b c d -> Bool
multiResult=Bool
True}) = [TickInfo]
-> ([Declaration] -> NetlistMonad [Expr]) -> NetlistMonad [Expr]
forall a.
[TickInfo] -> ([Declaration] -> NetlistMonad a) -> NetlistMonad a
withTicks [TickInfo]
ticks (([Declaration] -> NetlistMonad [Expr]) -> NetlistMonad [Expr])
-> ([Declaration] -> NetlistMonad [Expr]) -> NetlistMonad [Expr]
forall a b. (a -> b) -> a -> b
$ \[Declaration]
_ -> do
        TyConMap
tcm <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
        let ([Either Term Type]
args1, [Id]
res) = HasCallStack =>
MultiPrimInfo -> [Either Term Type] -> ([Either Term Type], [Id])
MultiPrimInfo -> [Either Term Type] -> ([Either Term Type], [Id])
splitMultiPrimArgs (HasCallStack => TyConMap -> PrimInfo -> MultiPrimInfo
TyConMap -> PrimInfo -> MultiPrimInfo
multiPrimInfo' TyConMap
tcm PrimInfo
pInfo) [Either Term Type]
args0
        (BlackBoxContext
bbCtx, [Declaration]
_) <- HasCallStack =>
Text
-> [Id]
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
Text
-> [Id]
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext (PrimInfo -> Text
primName PrimInfo
pInfo) [Id]
res [Either Term Type]
args1
        (BlackBox -> NetlistMonad Expr)
-> [BlackBox] -> NetlistMonad [Expr]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Text -> BlackBoxContext -> BlackBox -> NetlistMonad Expr
go' (PrimInfo -> Text
primName PrimInfo
pInfo) BlackBoxContext
bbCtx) [BlackBox]
nmDs
      go PrimInfo
pInfo (BlackBox {resultInits :: forall a b c d. Primitive a b c d -> [b]
resultInits=[BlackBox]
nmDs}) = [TickInfo]
-> ([Declaration] -> NetlistMonad [Expr]) -> NetlistMonad [Expr]
forall a.
[TickInfo] -> ([Declaration] -> NetlistMonad a) -> NetlistMonad a
withTicks [TickInfo]
ticks (([Declaration] -> NetlistMonad [Expr]) -> NetlistMonad [Expr])
-> ([Declaration] -> NetlistMonad [Expr]) -> NetlistMonad [Expr]
forall a b. (a -> b) -> a -> b
$ \[Declaration]
_ -> do
        (BlackBoxContext
bbCtx, [Declaration]
_) <- HasCallStack =>
Text
-> [Id]
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
Text
-> [Id]
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext (PrimInfo -> Text
primName PrimInfo
pInfo) [Id
i] [Either Term Type]
args0
        (BlackBox -> NetlistMonad Expr)
-> [BlackBox] -> NetlistMonad [Expr]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Text -> BlackBoxContext -> BlackBox -> NetlistMonad Expr
go' (PrimInfo -> Text
primName PrimInfo
pInfo) BlackBoxContext
bbCtx) [BlackBox]
nmDs
      go PrimInfo
_ Primitive a BlackBox c d
_ = [Expr] -> NetlistMonad [Expr]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []

      go' :: Text -> BlackBoxContext -> BlackBox -> NetlistMonad Expr
go' Text
pNm BlackBoxContext
bbCtx BlackBox
nmD = do
        (BlackBox
bbTempl, [Declaration]
templDecl) <- Text
-> BlackBox
-> BlackBoxContext
-> NetlistMonad (BlackBox, [Declaration])
prepareBlackBox Text
pNm BlackBox
nmD BlackBoxContext
bbCtx
        case [Declaration]
templDecl of
          [] ->
            Expr -> NetlistMonad Expr
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> BlackBoxContext
-> Bool
-> Expr
BlackBoxE Text
pNm [] [] [] BlackBox
bbTempl BlackBoxContext
bbCtx Bool
False)
          [Declaration]
_  -> do
            (Identifier
_,SrcSpan
sloc) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
            ClashException -> NetlistMonad Expr
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sloc [I.i|
              Initial values cannot produce declarations, but saw:

                #{templDecl}

              after rendering initial values for blackbox:

                #{pNm}

              Given template:

                #{nmD}
            |] Maybe String
forall a. Maybe a
Nothing)

-- | Generate a list of concurrent Declarations for a let-binder, return an
-- empty list if the bound expression is represented by 0 bits
mkDeclarations
  :: HasCallStack
  => Id
  -- ^ LHS of the let-binder
  -> Term
  -- ^ RHS of the let-binder
  -> NetlistMonad [Declaration]
mkDeclarations :: Id -> Term -> NetlistMonad [Declaration]
mkDeclarations = HasCallStack =>
DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
mkDeclarations' DeclarationType
Concurrent

-- | Generate a list of Declarations for a let-binder, return an empty list if
-- the bound expression is represented by 0 bits
mkDeclarations'
  :: HasCallStack
  => DeclarationType
  -- ^ Concurrent of sequential declaration
  -> Id
  -- ^ LHS of the let-binder
  -> Term
  -- ^ RHS of the let-binder
  -> NetlistMonad [Declaration]
mkDeclarations' :: DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
mkDeclarations' DeclarationType
_declType Id
bndr (Term -> (Term, [TickInfo])
collectTicks -> (Var Id
v,[TickInfo]
ticks)) =
  [TickInfo]
-> ([Declaration] -> NetlistMonad [Declaration])
-> NetlistMonad [Declaration]
forall a.
[TickInfo] -> ([Declaration] -> NetlistMonad a) -> NetlistMonad a
withTicks [TickInfo]
ticks (HasCallStack =>
Identifier
-> Id -> [Term] -> [Declaration] -> NetlistMonad [Declaration]
Identifier
-> Id -> [Term] -> [Declaration] -> NetlistMonad [Declaration]
mkFunApp (HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId Id
bndr) Id
v [])

mkDeclarations' DeclarationType
_declType Id
_bndr e :: Term
e@(Term -> (Term, [TickInfo])
collectTicks -> (Case Term
_ Type
_ [],[TickInfo]
_)) = do
  (Identifier
_,SrcSpan
sp) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
  ClashException -> NetlistMonad [Declaration]
forall a e. Exception e => e -> a
throw (ClashException -> NetlistMonad [Declaration])
-> ClashException -> NetlistMonad [Declaration]
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> Maybe String -> ClashException
ClashException
          SrcSpan
sp
          ( [String] -> String
unwords [ $(String
curLoc)
                    , String
"Not in normal form: Case-decompositions with an"
                    , String
"empty list of alternatives not supported:\n\n"
                    , Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
e
                    ])
          Maybe String
forall a. Maybe a
Nothing

mkDeclarations' DeclarationType
declType Id
bndr (Term -> (Term, [TickInfo])
collectTicks -> (Case Term
scrut Type
altTy (Alt
alt:alts :: [Alt]
alts@(Alt
_:[Alt]
_)),[TickInfo]
ticks)) =
  [TickInfo]
-> ([Declaration] -> NetlistMonad [Declaration])
-> NetlistMonad [Declaration]
forall a.
[TickInfo] -> ([Declaration] -> NetlistMonad a) -> NetlistMonad a
withTicks [TickInfo]
ticks (DeclarationType
-> NetlistId
-> Term
-> Type
-> NonEmpty Alt
-> [Declaration]
-> NetlistMonad [Declaration]
mkSelection DeclarationType
declType (Id -> NetlistId
CoreId Id
bndr) Term
scrut Type
altTy (Alt
alt Alt -> [Alt] -> NonEmpty Alt
forall a. a -> [a] -> NonEmpty a
:| [Alt]
alts))

mkDeclarations' DeclarationType
declType Id
bndr Term
app = do
  let (Term
appF,[Either Term Type]
args0,[TickInfo]
ticks) = Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks Term
app
      ([Term]
args,[Type]
tyArgs) = [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Term Type]
args0
  case Term
appF of
    Var Id
f
      | [Type] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Type]
tyArgs ->
        [TickInfo]
-> ([Declaration] -> NetlistMonad [Declaration])
-> NetlistMonad [Declaration]
forall a.
[TickInfo] -> ([Declaration] -> NetlistMonad a) -> NetlistMonad a
withTicks [TickInfo]
ticks (HasCallStack =>
Identifier
-> Id -> [Term] -> [Declaration] -> NetlistMonad [Declaration]
Identifier
-> Id -> [Term] -> [Declaration] -> NetlistMonad [Declaration]
mkFunApp (HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId Id
bndr) Id
f [Term]
args)
      | Bool
otherwise   -> do
        (Identifier
_,SrcSpan
sp) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
        ClashException -> NetlistMonad [Declaration]
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
"Not in normal form: Var-application with Type arguments:\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
app) Maybe String
forall a. Maybe a
Nothing)
    Term
_ -> do
      (Expr
exprApp,[Declaration]
declsApp0) <- HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
declType (Id -> NetlistId
CoreId Id
bndr) Term
app
      let dstId :: Identifier
dstId = HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId Id
bndr
      [Declaration]
assn  <- case Expr
exprApp of
                 Identifier Identifier
_ Maybe Modifier
Nothing ->
                   -- Supplied 'bndr' was used to assign a result to, so we
                   -- don't have to manually turn it into a declaration
                   [Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []

                 Expr
Noop ->
                   -- Rendered expression rendered a "noop" - a list of
                   -- declarations without a result. Used for things like
                   -- mealy IO / inline assertions / multi result primitives.
                   [Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []

                 Expr
_ -> do
                   -- Turn returned expression into declaration by assigning
                   -- it to 'dstId'
                   Declaration
assn <- case DeclarationType
declType of
                     DeclarationType
Concurrent -> HasCallStack => Identifier -> Expr -> NetlistMonad Declaration
Identifier -> Expr -> NetlistMonad Declaration
contAssign Identifier
dstId Expr
exprApp
                     DeclarationType
Sequential -> HasCallStack =>
Blocking -> Identifier -> Expr -> NetlistMonad Declaration
Blocking -> Identifier -> Expr -> NetlistMonad Declaration
procAssign Blocking
Blocking Identifier
dstId Expr
exprApp
                   [Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [Declaration
assn]

      [Declaration]
declsApp1 <- if [Declaration] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Declaration]
declsApp0
                   then [TickInfo]
-> ([Declaration] -> NetlistMonad [Declaration])
-> NetlistMonad [Declaration]
forall a.
[TickInfo] -> ([Declaration] -> NetlistMonad a) -> NetlistMonad a
withTicks [TickInfo]
ticks [Declaration] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a. Monad m => a -> m a
return
                   else [Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [Declaration]
declsApp0
      [Declaration] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Declaration]
declsApp1 [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
assn)

-- | Generate a declaration that selects an alternative based on the value of
-- the scrutinee
mkSelection
  :: DeclarationType
  -> NetlistId
  -> Term
  -> Type
  -> NonEmpty Alt
  -> [Declaration]
  -> NetlistMonad [Declaration]
mkSelection :: DeclarationType
-> NetlistId
-> Term
-> Type
-> NonEmpty Alt
-> [Declaration]
-> NetlistMonad [Declaration]
mkSelection DeclarationType
declType NetlistId
bndr Term
scrut Type
altTy NonEmpty Alt
alts0 [Declaration]
tickDecls = do
  let dstId :: Identifier
dstId = (Identifier -> Identifier)
-> (Id -> Identifier) -> NetlistId -> Identifier
forall r.
HasCallStack =>
(Identifier -> r) -> (Id -> r) -> NetlistId -> r
netlistId1 Identifier -> Identifier
forall a. a -> a
id HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId NetlistId
bndr
  TyConMap
tcm <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
  let scrutTy :: Type
scrutTy = TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
scrut
  HWType
scrutHTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(String
curLoc) Type
scrutTy
  Identifier
scrutId  <- Identifier -> Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Identifier -> Text -> m Identifier
Id.suffix Identifier
dstId Text
"selection"
  (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
  Bool
ite <- Getting Bool NetlistState Bool -> NetlistMonad Bool
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting Bool NetlistState Bool
Lens' NetlistState Bool
backEndITE
  HWType
altHTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(String
curLoc) Type
altTy
  case HWType -> [Alt] -> Maybe (Term, Term)
iteAlts HWType
scrutHTy (NonEmpty Alt -> [Alt]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Alt
alts0) of
    Just (Term
altT,Term
altF)
      | Bool
ite
      , DeclarationType
Concurrent <- DeclarationType
declType
      -> do
      (Expr
scrutExpr,[Declaration]
scrutDecls) <- case HWType
scrutHTy of
        SP {} -> (Expr -> Expr) -> (Expr, [Declaration]) -> (Expr, [Declaration])
forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (SrcSpan -> HWType -> Pat -> Expr -> Expr
mkScrutExpr SrcSpan
sp HWType
scrutHTy (Alt -> Pat
forall a b. (a, b) -> a
fst (NonEmpty Alt -> Alt
forall a. NonEmpty a -> a
NE.last NonEmpty Alt
alts0))) ((Expr, [Declaration]) -> (Expr, [Declaration]))
-> NetlistMonad (Expr, [Declaration])
-> NetlistMonad (Expr, [Declaration])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
                   HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
True DeclarationType
declType (Identifier -> Type -> NetlistId
NetlistId Identifier
scrutId Type
scrutTy) Term
scrut
        HWType
_ -> HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
declType (Identifier -> Type -> NetlistId
NetlistId Identifier
scrutId Type
scrutTy) Term
scrut
      Identifier
altTId <- Identifier -> Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Identifier -> Text -> m Identifier
Id.suffix Identifier
dstId Text
"sel_alt_t"
      Identifier
altFId <- Identifier -> Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Identifier -> Text -> m Identifier
Id.suffix Identifier
dstId Text
"sel_alt_f"
      (Expr
altTExpr,[Declaration]
altTDecls) <- HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
declType (Identifier -> Type -> NetlistId
NetlistId Identifier
altTId Type
altTy) Term
altT
      (Expr
altFExpr,[Declaration]
altFDecls) <- HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
declType (Identifier -> Type -> NetlistId
NetlistId Identifier
altFId Type
altTy) Term
altF
      -- This logic (and the same logic a few lines below) is faulty in the
      -- sense that it won't generate "void decls" if the alternatives' type
      -- is void, but the type of the scrut isn't. Ideally, we'd like to pass
      -- a boolean to 'mkExpr' indicating that it should only render "void decls"
      -- but that it should skip any others.
      --
      -- TODO: Fix ^
      if | HWType -> Bool
isVoid HWType
altHTy Bool -> Bool -> Bool
&& HWType -> Bool
isVoid HWType
scrutHTy
          -> [Declaration] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Declaration] -> NetlistMonad [Declaration])
-> [Declaration] -> NetlistMonad [Declaration]
forall a b. (a -> b) -> a -> b
$! [Declaration]
scrutDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
altTDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
altFDecls
         | HWType -> Bool
isVoid HWType
altHTy
          -> [Declaration] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Declaration] -> NetlistMonad [Declaration])
-> [Declaration] -> NetlistMonad [Declaration]
forall a b. (a -> b) -> a -> b
$! [Declaration]
altTDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
altFDecls
         | Bool
otherwise
          -> do Declaration
dstAssign <- HasCallStack => Identifier -> Expr -> NetlistMonad Declaration
Identifier -> Expr -> NetlistMonad Declaration
contAssign Identifier
dstId (Expr -> Expr -> Expr -> Expr
IfThenElse Expr
scrutExpr Expr
altTExpr Expr
altFExpr)
                [Declaration] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Declaration] -> NetlistMonad [Declaration])
-> [Declaration] -> NetlistMonad [Declaration]
forall a b. (a -> b) -> a -> b
$! [Declaration]
scrutDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
altTDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
altFDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
dstAssign]
    Maybe (Term, Term)
_ -> do
      CustomReprs
reprs <- Getting CustomReprs NetlistEnv CustomReprs
-> NetlistMonad CustomReprs
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting CustomReprs NetlistEnv CustomReprs
Getter NetlistEnv CustomReprs
customReprs
      let alts1 :: NonEmpty Alt
alts1 = (NonEmpty Alt -> NonEmpty Alt
reorderDefault (NonEmpty Alt -> NonEmpty Alt)
-> (NonEmpty Alt -> NonEmpty Alt) -> NonEmpty Alt -> NonEmpty Alt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyConMap -> CustomReprs -> Type -> NonEmpty Alt -> NonEmpty Alt
reorderCustom TyConMap
tcm CustomReprs
reprs Type
scrutTy) NonEmpty Alt
alts0
      (Expr
scrutExpr,[Declaration]
scrutDecls) <- (Expr -> Expr) -> (Expr, [Declaration]) -> (Expr, [Declaration])
forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (SrcSpan -> HWType -> Pat -> Expr -> Expr
mkScrutExpr SrcSpan
sp HWType
scrutHTy (Alt -> Pat
forall a b. (a, b) -> a
fst (NonEmpty Alt -> Alt
forall a. NonEmpty a -> a
NE.head NonEmpty Alt
alts1))) ((Expr, [Declaration]) -> (Expr, [Declaration]))
-> NetlistMonad (Expr, [Declaration])
-> NetlistMonad (Expr, [Declaration])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                  HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
True DeclarationType
declType (Identifier -> Type -> NetlistId
NetlistId Identifier
scrutId Type
scrutTy) Term
scrut
      ([(Maybe Literal, Expr)]
exprs,[[Declaration]]
altsDecls)      <- [((Maybe Literal, Expr), [Declaration])]
-> ([(Maybe Literal, Expr)], [[Declaration]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([((Maybe Literal, Expr), [Declaration])]
 -> ([(Maybe Literal, Expr)], [[Declaration]]))
-> NetlistMonad [((Maybe Literal, Expr), [Declaration])]
-> NetlistMonad ([(Maybe Literal, Expr)], [[Declaration]])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Alt -> NetlistMonad ((Maybe Literal, Expr), [Declaration]))
-> [Alt] -> NetlistMonad [((Maybe Literal, Expr), [Declaration])]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HWType
-> Alt -> NetlistMonad ((Maybe Literal, Expr), [Declaration])
mkCondExpr HWType
scrutHTy) (NonEmpty Alt -> [Alt]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Alt
alts1)
      case DeclarationType
declType of
        DeclarationType
Sequential -> do
          -- Assign to the result in every branch
          ([[Declaration]]
altNets,[(Maybe Literal, [Seq])]
exprAlts) <- ([([Declaration], (Maybe Literal, [Seq]))]
 -> ([[Declaration]], [(Maybe Literal, [Seq])]))
-> NetlistMonad [([Declaration], (Maybe Literal, [Seq]))]
-> NetlistMonad ([[Declaration]], [(Maybe Literal, [Seq])])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [([Declaration], (Maybe Literal, [Seq]))]
-> ([[Declaration]], [(Maybe Literal, [Seq])])
forall a b. [(a, b)] -> ([a], [b])
unzip (((Maybe Literal, Expr)
 -> [Declaration]
 -> NetlistMonad ([Declaration], (Maybe Literal, [Seq])))
-> [(Maybe Literal, Expr)]
-> [[Declaration]]
-> NetlistMonad [([Declaration], (Maybe Literal, [Seq]))]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier
-> (Maybe Literal, Expr)
-> [Declaration]
-> NetlistMonad ([Declaration], (Maybe Literal, [Seq]))
altAssign Identifier
dstId) [(Maybe Literal, Expr)]
exprs [[Declaration]]
altsDecls)
          [Declaration] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Declaration] -> NetlistMonad [Declaration])
-> [Declaration] -> NetlistMonad [Declaration]
forall a b. (a -> b) -> a -> b
$! [Declaration]
scrutDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
altNets [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++
                    [[Seq] -> Declaration
Seq [Expr -> HWType -> [(Maybe Literal, [Seq])] -> Seq
Branch Expr
scrutExpr HWType
scrutHTy [(Maybe Literal, [Seq])]
exprAlts]]
        DeclarationType
Concurrent ->
          if | HWType -> Bool
isVoid HWType
altHTy Bool -> Bool -> Bool
&& HWType -> Bool
isVoid HWType
scrutHTy
              -> [Declaration] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Declaration] -> NetlistMonad [Declaration])
-> [Declaration] -> NetlistMonad [Declaration]
forall a b. (a -> b) -> a -> b
$! [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
altsDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
scrutDecls
             | HWType -> Bool
isVoid HWType
altHTy
              -> [Declaration] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Declaration] -> NetlistMonad [Declaration])
-> [Declaration] -> NetlistMonad [Declaration]
forall a b. (a -> b) -> a -> b
$! [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
altsDecls
             | Bool
otherwise
              -> do Declaration
assign <- Identifier
-> HWType
-> Expr
-> HWType
-> [(Maybe Literal, Expr)]
-> NetlistMonad Declaration
condAssign Identifier
dstId HWType
altHTy Expr
scrutExpr HWType
scrutHTy [(Maybe Literal, Expr)]
exprs
                    [Declaration] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Declaration] -> NetlistMonad [Declaration])
-> [Declaration] -> NetlistMonad [Declaration]
forall a b. (a -> b) -> a -> b
$! [Declaration]
scrutDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
altsDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
assign]
 where
  mkCondExpr :: HWType -> (Pat,Term) -> NetlistMonad ((Maybe HW.Literal,Expr),[Declaration])
  mkCondExpr :: HWType
-> Alt -> NetlistMonad ((Maybe Literal, Expr), [Declaration])
mkCondExpr HWType
scrutHTy (Pat
pat,Term
alt) = do
    Identifier
altId <- Identifier -> Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Identifier -> Text -> m Identifier
Id.suffix ((Identifier -> Identifier)
-> (Id -> Identifier) -> NetlistId -> Identifier
forall r.
HasCallStack =>
(Identifier -> r) -> (Id -> r) -> NetlistId -> r
netlistId1 Identifier -> Identifier
forall a. a -> a
id HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId NetlistId
bndr) Text
"sel_alt"
    (Expr
altExpr,[Declaration]
altDecls) <- HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
declType (Identifier -> Type -> NetlistId
NetlistId Identifier
altId Type
altTy) Term
alt
    (,[Declaration]
altDecls) ((Maybe Literal, Expr) -> ((Maybe Literal, Expr), [Declaration]))
-> NetlistMonad (Maybe Literal, Expr)
-> NetlistMonad ((Maybe Literal, Expr), [Declaration])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> case Pat
pat of
      Pat
DefaultPat           -> (Maybe Literal, Expr) -> NetlistMonad (Maybe Literal, Expr)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe Literal
forall a. Maybe a
Nothing,Expr
altExpr)
      DataPat DataCon
dc [TyVar]
_ [Id]
_ -> (Maybe Literal, Expr) -> NetlistMonad (Maybe Literal, Expr)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Literal -> Maybe Literal
forall a. a -> Maybe a
Just (HWType -> Int -> Literal
dcToLiteral HWType
scrutHTy (DataCon -> Int
dcTag DataCon
dc)),Expr
altExpr)
      LitPat  (IntegerLiteral Integer
i) -> (Maybe Literal, Expr) -> NetlistMonad (Maybe Literal, Expr)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Literal -> Maybe Literal
forall a. a -> Maybe a
Just (Integer -> Literal
NumLit Integer
i),Expr
altExpr)
      LitPat  (IntLiteral Integer
i) -> (Maybe Literal, Expr) -> NetlistMonad (Maybe Literal, Expr)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Literal -> Maybe Literal
forall a. a -> Maybe a
Just (Integer -> Literal
NumLit Integer
i), Expr
altExpr)
      LitPat  (WordLiteral Integer
w) -> (Maybe Literal, Expr) -> NetlistMonad (Maybe Literal, Expr)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Literal -> Maybe Literal
forall a. a -> Maybe a
Just (Integer -> Literal
NumLit Integer
w), Expr
altExpr)
      LitPat  (CharLiteral Char
c) -> (Maybe Literal, Expr) -> NetlistMonad (Maybe Literal, Expr)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Literal -> Maybe Literal
forall a. a -> Maybe a
Just (Integer -> Literal
NumLit (Integer -> Literal) -> (Int -> Integer) -> Int -> Literal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Literal) -> Int -> Literal
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c), Expr
altExpr)
      LitPat  (Int64Literal Integer
i) -> (Maybe Literal, Expr) -> NetlistMonad (Maybe Literal, Expr)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Literal -> Maybe Literal
forall a. a -> Maybe a
Just (Integer -> Literal
NumLit Integer
i), Expr
altExpr)
      LitPat  (Word64Literal Integer
w) -> (Maybe Literal, Expr) -> NetlistMonad (Maybe Literal, Expr)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Literal -> Maybe Literal
forall a. a -> Maybe a
Just (Integer -> Literal
NumLit Integer
w), Expr
altExpr)
#if MIN_VERSION_base(4,16,0)
      LitPat  (Int8Literal i) -> return (Just (NumLit i), altExpr)
      LitPat  (Int16Literal i) -> return (Just (NumLit i), altExpr)
      LitPat  (Int32Literal i) -> return (Just (NumLit i), altExpr)
      LitPat  (Word8Literal w) -> return (Just (NumLit w), altExpr)
      LitPat  (Word16Literal w) -> return (Just (NumLit w), altExpr)
      LitPat  (Word32Literal w) -> return (Just (NumLit w), altExpr)
#endif
      LitPat  (NaturalLiteral Integer
n) -> (Maybe Literal, Expr) -> NetlistMonad (Maybe Literal, Expr)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Literal -> Maybe Literal
forall a. a -> Maybe a
Just (Integer -> Literal
NumLit Integer
n), Expr
altExpr)
      Pat
_  -> do
        (Identifier
_,SrcSpan
sp) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
        ClashException -> NetlistMonad (Maybe Literal, Expr)
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
"Not an integer literal in LitPat:\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pat -> String
forall p. PrettyPrec p => p -> String
showPpr Pat
pat) Maybe String
forall a. Maybe a
Nothing)

  mkScrutExpr :: SrcSpan -> HWType -> Pat -> Expr -> Expr
  mkScrutExpr :: SrcSpan -> HWType -> Pat -> Expr -> Expr
mkScrutExpr SrcSpan
sp HWType
scrutHTy Pat
pat Expr
scrutE = case Pat
pat of
    DataPat DataCon
dc [TyVar]
_ [Id]
_ -> let modifier :: Maybe Modifier
modifier = Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int) -> Modifier
DC (HWType
scrutHTy,DataCon -> Int
dcTag DataCon
dc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
                      in case Expr
scrutE of
                          Identifier Identifier
scrutId Maybe Modifier
Nothing -> Identifier -> Maybe Modifier -> Expr
Identifier Identifier
scrutId Maybe Modifier
modifier
                          Expr
_ -> ClashException -> Expr
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
"Not in normal form: Not a variable reference or primitive as subject of a case-statement:\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
scrutE) Maybe String
forall a. Maybe a
Nothing)
    Pat
_ -> Expr
scrutE

  altAssign
    :: Identifier
    -> (Maybe HW.Literal,Expr)
    -> [Declaration]
    -> NetlistMonad ([Declaration],(Maybe HW.Literal,[Seq]))
  altAssign :: Identifier
-> (Maybe Literal, Expr)
-> [Declaration]
-> NetlistMonad ([Declaration], (Maybe Literal, [Seq]))
altAssign Identifier
i (Maybe Literal
m,Expr
expr) [Declaration]
ds = do
    let ([Declaration]
nets,[Declaration]
rest) = (Declaration -> Bool)
-> [Declaration] -> ([Declaration], [Declaration])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Declaration -> Bool
isNet [Declaration]
ds
    [Declaration]
assn <- case Expr
expr of
              Expr
Noop -> [Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
              Expr
_ -> do Declaration
assn <- HasCallStack =>
Blocking -> Identifier -> Expr -> NetlistMonad Declaration
Blocking -> Identifier -> Expr -> NetlistMonad Declaration
procAssign Blocking
Blocking Identifier
i Expr
expr
                      [Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [Declaration
assn]
    ([Declaration], (Maybe Literal, [Seq]))
-> NetlistMonad ([Declaration], (Maybe Literal, [Seq]))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Declaration]
nets,(Maybe Literal
m,(Declaration -> Seq) -> [Declaration] -> [Seq]
forall a b. (a -> b) -> [a] -> [b]
map Declaration -> Seq
SeqDecl ([Declaration]
rest [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
assn)))
   where
    isNet :: Declaration -> Bool
isNet NetDecl' {} = Bool
True
    isNet Declaration
_ = Bool
False

-- GHC puts default patterns in the first position, we want them in the
-- last position.
reorderDefault
  :: NonEmpty (Pat, Term)
  -> NonEmpty (Pat, Term)
reorderDefault :: NonEmpty Alt -> NonEmpty Alt
reorderDefault ((Pat
DefaultPat,Term
e) :| [Alt]
alts') =
  case [Alt]
alts' of
    [] -> (Pat
DefaultPat,Term
e) Alt -> [Alt] -> NonEmpty Alt
forall a. a -> [a] -> NonEmpty a
:| []
    Alt
x:[Alt]
xs -> Alt
x Alt -> [Alt] -> NonEmpty Alt
forall a. a -> [a] -> NonEmpty a
:| ([Alt]
xs [Alt] -> [Alt] -> [Alt]
forall a. Semigroup a => a -> a -> a
<> [(Pat
DefaultPat,Term
e)])
reorderDefault NonEmpty Alt
alts' = NonEmpty Alt
alts'

reorderCustom
  :: TyConMap
  -> CustomReprs
  -> Type
  -> NonEmpty (Pat, Term)
  -> NonEmpty (Pat, Term)
reorderCustom :: TyConMap -> CustomReprs -> Type -> NonEmpty Alt -> NonEmpty Alt
reorderCustom TyConMap
tcm CustomReprs
reprs (TyConMap -> Type -> Maybe Type
coreView1 TyConMap
tcm -> Just Type
ty) NonEmpty Alt
alts =
  TyConMap -> CustomReprs -> Type -> NonEmpty Alt -> NonEmpty Alt
reorderCustom TyConMap
tcm CustomReprs
reprs Type
ty NonEmpty Alt
alts
reorderCustom TyConMap
_tcm CustomReprs
reprs (Type -> Either String Type'
coreToType' -> Right Type'
typeName) NonEmpty Alt
alts =
  case Type' -> CustomReprs -> Maybe DataRepr'
getDataRepr Type'
typeName CustomReprs
reprs of
    Just (DataRepr' Type'
_name Int
_size [ConstrRepr']
_constrReprs) ->
      (Alt -> Int) -> NonEmpty Alt -> NonEmpty Alt
forall b a. Ord b => (a -> b) -> NonEmpty a -> NonEmpty a
NE.sortOn (CustomReprs -> Pat -> Int
patPos CustomReprs
reprs (Pat -> Int) -> (Alt -> Pat) -> Alt -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alt -> Pat
forall a b. (a, b) -> a
fst) NonEmpty Alt
alts
    Maybe DataRepr'
Nothing ->
      NonEmpty Alt
alts
reorderCustom TyConMap
_tcm CustomReprs
_reprs Type
_type NonEmpty Alt
alts =
  NonEmpty Alt
alts

patPos
  :: CustomReprs
  -> Pat
  -> Int
patPos :: CustomReprs -> Pat -> Int
patPos CustomReprs
_reprs Pat
DefaultPat = -Int
1
patPos CustomReprs
_reprs (LitPat Literal
_) = Int
0
patPos CustomReprs
reprs pat :: Pat
pat@(DataPat DataCon
dataCon [TyVar]
_ [Id]
_) =
  -- We sort data patterns by their syntactical order
  let name :: Text
name = Name DataCon -> Text
forall a. Name a -> Text
nameOcc (Name DataCon -> Text) -> Name DataCon -> Text
forall a b. (a -> b) -> a -> b
$ DataCon -> Name DataCon
dcName DataCon
dataCon in
  case Text -> CustomReprs -> Maybe ConstrRepr'
getConstrRepr Text
name CustomReprs
reprs of
    Maybe ConstrRepr'
Nothing ->
      -- TODO: err
      String -> Int
forall a. HasCallStack => String -> a
error (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Pat -> String
forall a. Show a => a -> String
show Pat
pat)
    Just (ConstrRepr' Text
_name Int
n Integer
_mask Integer
_value [Integer]
_anns) ->
      Int
n


-- | Generate a list of Declarations for a let-binder where the RHS is a function application
mkFunApp
  :: HasCallStack
  => Identifier -- ^ LHS of the let-binder
  -> Id -- ^ Name of the applied function
  -> [Term] -- ^ Function arguments
  -> [Declaration] -- ^ Tick declarations
  -> NetlistMonad [Declaration]
mkFunApp :: Identifier
-> Id -> [Term] -> [Declaration] -> NetlistMonad [Declaration]
mkFunApp Identifier
dstId Id
fun [Term]
args [Declaration]
tickDecls = do
  VarEnv TopEntityT
topAnns <- Getting (VarEnv TopEntityT) NetlistState (VarEnv TopEntityT)
-> NetlistMonad (VarEnv TopEntityT)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (VarEnv TopEntityT) NetlistState (VarEnv TopEntityT)
Lens' NetlistState (VarEnv TopEntityT)
topEntityAnns
  TyConMap
tcm     <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
  case (Id -> Bool
forall a. Var a -> Bool
isGlobalId Id
fun, Id -> VarEnv TopEntityT -> Maybe TopEntityT
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
fun VarEnv TopEntityT
topAnns) of
    (Bool
True, Just TopEntityT
topEntity)
      | let ty :: Type
ty = Id -> Type
forall a. HasType a => a -> Type
coreTypeOf (TopEntityT -> Id
topId TopEntityT
topEntity)
      , let ([Either TyVar Type]
fArgTys0,Type
fResTy) = Type -> ([Either TyVar Type], Type)
splitFunForallTy Type
ty
      -- Take into account that clocks and stuff are split off from any product
      -- types containing them
      , let fArgTys1 :: [Type]
fArgTys1 = TyConMap -> [Type] -> [Type]
splitShouldSplit TyConMap
tcm ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ [Either TyVar Type] -> [Type]
forall a b. [Either a b] -> [b]
rights [Either TyVar Type]
fArgTys0
      , [Type] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Type]
fArgTys1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Term] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Term]
args
      -> do
        [HWType]
argHWTys <- (Type -> NetlistMonad HWType) -> [Type] -> NetlistMonad [HWType]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(String
curLoc)) [Type]
fArgTys1
        ([Expr]
argExprs, [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat -> [Declaration]
argDecls) <- [(Expr, [Declaration])] -> ([Expr], [[Declaration]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Expr, [Declaration])] -> ([Expr], [[Declaration]]))
-> NetlistMonad [(Expr, [Declaration])]
-> NetlistMonad ([Expr], [[Declaration]])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
          ((Term, Type) -> NetlistMonad (Expr, [Declaration]))
-> [(Term, Type)] -> NetlistMonad [(Expr, [Declaration])]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Term
e,Type
t) -> HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Concurrent (Identifier -> Type -> NetlistId
NetlistId Identifier
dstId Type
t) Term
e)
                                 ([Term] -> [Type] -> [(Term, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Term]
args [Type]
fArgTys1)

        -- Filter void arguments, but make sure to render their declarations:
        let
          filteredTypeExprs :: [(Expr, HWType)]
filteredTypeExprs = ((Expr, HWType) -> Bool) -> [(Expr, HWType)] -> [(Expr, HWType)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Expr, HWType) -> Bool) -> (Expr, HWType) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HWType -> Bool
isVoid (HWType -> Bool)
-> ((Expr, HWType) -> HWType) -> (Expr, HWType) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Expr, HWType) -> HWType
forall a b. (a, b) -> b
snd) ([Expr] -> [HWType] -> [(Expr, HWType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Expr]
argExprs [HWType]
argHWTys)

        HWType
dstHWty  <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(String
curLoc) Type
fResTy

        -- TODO: The commented code fetches the function definition from the
        --       set of global bindings and uses it to replicate the port names
        --       of it. However, this does rely on the binding actually being
        --       present in the binding map. This isn't the case, as only
        --       the current top entity (and its dependencies, stopping at other
        --       top entities) are present. We can't add the non-normalized
        --       version, as this logic relies on 'splitArguments' having
        --       fired. Adding normalized versions would create a dependency
        --       between two top entities, defeating the ability to compile in
        --       parallel.
        --
        --       One option is to split the normalization process into two
        --       chunks: preprocessing (e.g., 'splitArguments') and actually
        --       normalizing. This would ensure only minimal work is being done
        --       serially.
        --
        --       The current workaround is to not rely on named arguments, using
        --       positional ones instead when instantiating a top entity.
        --
        -- funTerm <- fmap bindingTerm . lookupVarEnv fun <$> Lens.use bindings
        --
        -- expandedTopEntity <-
        --   case splitNormalized tcm <$> funTerm of
        --     Nothing -> error ("Internal error: could not find " <> show fun)
        --     Just (Left err) -> error ("Internal error: " <> show err)
        --     Just (Right (argIds, _binds, resId)) -> do
        --       argTys <- mapM (unsafeCoreTypeToHWTypeM $(curLoc)) (map coreTypeOf argIds)
        --       resTy <- unsafeCoreTypeToHWTypeM $(curLoc) (coreTypeOf resId)
        --       is <- Lens.use seenIds
        --       let topAnnM = topAnnotation topEntity
        --       pure (expandTopEntityOrErr is (zip argIds argTys) (resId, resTy) topAnnM)

        -- Generate ExpandedTopEntity, see TODO^
        [FilteredHWType]
argTys <- (Term -> NetlistMonad FilteredHWType)
-> [Term] -> NetlistMonad [FilteredHWType]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Type -> NetlistMonad FilteredHWType
unsafeCoreTypeToHWTypeM $(String
curLoc) (Type -> NetlistMonad FilteredHWType)
-> (Term -> Type) -> Term -> NetlistMonad FilteredHWType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm) [Term]
args
        FilteredHWType
resTy <- String -> Type -> NetlistMonad FilteredHWType
unsafeCoreTypeToHWTypeM $(String
curLoc) Type
fResTy
        let
          ettArgs :: [(Maybe a, FilteredHWType)]
ettArgs = (Maybe a
forall a. Maybe a
Nothing,) (FilteredHWType -> (Maybe a, FilteredHWType))
-> [FilteredHWType] -> [(Maybe a, FilteredHWType)]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilteredHWType]
argTys
          ettRes :: (Maybe a, FilteredHWType)
ettRes = (Maybe a
forall a. Maybe a
Nothing, FilteredHWType
resTy)
        ExpandedTopEntity Identifier
expandedTopEntity <-
            HasCallStack =>
[(Maybe Id, FilteredHWType)]
-> (Maybe Id, FilteredHWType)
-> Maybe TopEntity
-> NetlistMonad (ExpandedTopEntity Identifier)
[(Maybe Id, FilteredHWType)]
-> (Maybe Id, FilteredHWType)
-> Maybe TopEntity
-> NetlistMonad (ExpandedTopEntity Identifier)
expandTopEntityOrErrM [(Maybe Id, FilteredHWType)]
forall a. [(Maybe a, FilteredHWType)]
ettArgs (Maybe Id, FilteredHWType)
forall a. (Maybe a, FilteredHWType)
ettRes (TopEntityT -> Maybe TopEntity
topAnnotation TopEntityT
topEntity)

        [Declaration]
instDecls <-
          Id
-> ExpandedTopEntity Identifier
-> (Identifier, HWType)
-> [(Expr, HWType)]
-> [Declaration]
-> NetlistMonad [Declaration]
mkTopUnWrapper
            Id
fun ExpandedTopEntity Identifier
expandedTopEntity (Identifier
dstId, HWType
dstHWty)
            [(Expr, HWType)]
filteredTypeExprs [Declaration]
tickDecls

        [Declaration] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Declaration]
argDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
instDecls)

      | Bool
otherwise -> String -> NetlistMonad [Declaration]
forall a. HasCallStack => String -> a
error (String -> NetlistMonad [Declaration])
-> String -> NetlistMonad [Declaration]
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"under-applied TopEntity: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Id -> String
forall p. PrettyPrec p => p -> String
showPpr Id
fun
    (Bool
True, Maybe TopEntityT
Nothing) -> do
      BindingMap
normalized <- Getting BindingMap NetlistState BindingMap
-> NetlistMonad BindingMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting BindingMap NetlistState BindingMap
Lens' NetlistState BindingMap
bindings
      case Id -> BindingMap -> Maybe (Binding Term)
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
fun BindingMap
normalized of
        Maybe (Binding Term)
Nothing -> String -> NetlistMonad [Declaration]
forall a. HasCallStack => String -> a
error [I.i|
          Internal error: unknown normalized binder:

            #{showPpr fun}
        |]
        Just (Binding{Term
bindingTerm :: Term
bindingTerm :: forall a. Binding a -> a
bindingTerm}) -> do
          (ComponentMeta
_, Component Identifier
compName [(Identifier, HWType)]
compInps [(Usage, (Identifier, HWType), Maybe Expr)]
co [Declaration]
_) <- NetlistMonad (ComponentMeta, Component)
-> NetlistMonad (ComponentMeta, Component)
forall a. NetlistMonad a -> NetlistMonad a
preserveVarEnv (NetlistMonad (ComponentMeta, Component)
 -> NetlistMonad (ComponentMeta, Component))
-> NetlistMonad (ComponentMeta, Component)
-> NetlistMonad (ComponentMeta, Component)
forall a b. (a -> b) -> a -> b
$ HasCallStack => Id -> NetlistMonad (ComponentMeta, Component)
Id -> NetlistMonad (ComponentMeta, Component)
genComponent Id
fun
          let argTys :: [Type]
argTys = (Term -> Type) -> [Term] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm) [Term]
args
          [Maybe HWType]
argHWTys <- (Type -> NetlistMonad (Maybe HWType))
-> [Type] -> NetlistMonad [Maybe HWType]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> NetlistMonad (Maybe HWType)
coreTypeToHWTypeM' [Type]
argTys

          ([Expr]
argExprs, [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat -> [Declaration]
argDecls) <- [(Expr, [Declaration])] -> ([Expr], [[Declaration]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Expr, [Declaration])] -> ([Expr], [[Declaration]]))
-> NetlistMonad [(Expr, [Declaration])]
-> NetlistMonad ([Expr], [[Declaration]])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
            ((Term, Type) -> NetlistMonad (Expr, [Declaration]))
-> [(Term, Type)] -> NetlistMonad [(Expr, [Declaration])]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Term
e,Type
t) -> HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Concurrent (Identifier -> Type -> NetlistId
NetlistId Identifier
dstId Type
t) Term
e)
                 ([Term] -> [Type] -> [(Term, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Term]
args [Type]
argTys)

          -- Filter void arguments, but make sure to render their declarations:
          let
            argTypeExprs :: [(Maybe HWType, (Expr, Type))]
argTypeExprs = [Maybe HWType] -> [(Expr, Type)] -> [(Maybe HWType, (Expr, Type))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe HWType]
argHWTys ([Expr] -> [Type] -> [(Expr, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Expr]
argExprs [Type]
argTys)
            filteredTypeExprs :: [(Expr, Type)]
filteredTypeExprs = ((Maybe HWType, (Expr, Type)) -> (Expr, Type))
-> [(Maybe HWType, (Expr, Type))] -> [(Expr, Type)]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe HWType, (Expr, Type)) -> (Expr, Type)
forall a b. (a, b) -> b
snd ([(Maybe HWType, (Expr, Type))] -> [(Expr, Type)])
-> [(Maybe HWType, (Expr, Type))] -> [(Expr, Type)]
forall a b. (a -> b) -> a -> b
$ ((Maybe HWType, (Expr, Type)) -> Bool)
-> [(Maybe HWType, (Expr, Type))] -> [(Maybe HWType, (Expr, Type))]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Maybe HWType, (Expr, Type)) -> Bool)
-> (Maybe HWType, (Expr, Type))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Maybe HWType -> Bool
isVoidMaybe Bool
True (Maybe HWType -> Bool)
-> ((Maybe HWType, (Expr, Type)) -> Maybe HWType)
-> (Maybe HWType, (Expr, Type))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe HWType, (Expr, Type)) -> Maybe HWType
forall a b. (a, b) -> a
fst) [(Maybe HWType, (Expr, Type))]
argTypeExprs

          let compOutp :: Maybe (Identifier, HWType)
compOutp = (\(Usage
_,(Identifier, HWType)
x,Maybe Expr
_) -> (Identifier, HWType)
x) ((Usage, (Identifier, HWType), Maybe Expr) -> (Identifier, HWType))
-> Maybe (Usage, (Identifier, HWType), Maybe Expr)
-> Maybe (Identifier, HWType)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Usage, (Identifier, HWType), Maybe Expr)]
-> Maybe (Usage, (Identifier, HWType), Maybe Expr)
forall a. [a] -> Maybe a
listToMaybe [(Usage, (Identifier, HWType), Maybe Expr)]
co
          if [(Expr, Type)] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [(Expr, Type)]
filteredTypeExprs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [(Identifier, HWType)] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [(Identifier, HWType)]
compInps
            then do
              ([Expr]
argExprs',[Declaration]
argDecls') <- (([[Declaration]] -> [Declaration])
-> ([Expr], [[Declaration]]) -> ([Expr], [Declaration])
forall (p :: Type -> Type -> Type) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat (([Expr], [[Declaration]]) -> ([Expr], [Declaration]))
-> ([(Expr, [Declaration])] -> ([Expr], [[Declaration]]))
-> [(Expr, [Declaration])]
-> ([Expr], [Declaration])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Expr, [Declaration])] -> ([Expr], [[Declaration]])
forall a b. [(a, b)] -> ([a], [b])
unzip) ([(Expr, [Declaration])] -> ([Expr], [Declaration]))
-> NetlistMonad [(Expr, [Declaration])]
-> NetlistMonad ([Expr], [Declaration])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Expr, Type) -> NetlistMonad (Expr, [Declaration]))
-> [(Expr, Type)] -> NetlistMonad [(Expr, [Declaration])]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Identifier -> (Expr, Type) -> NetlistMonad (Expr, [Declaration])
toSimpleVar Identifier
dstId) [(Expr, Type)]
filteredTypeExprs
              let inpAssigns :: [(Expr, PortDirection, HWType, Expr)]
inpAssigns    = ((Identifier, HWType)
 -> Expr -> (Expr, PortDirection, HWType, Expr))
-> [(Identifier, HWType)]
-> [Expr]
-> [(Expr, PortDirection, HWType, Expr)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Identifier
i,HWType
t) Expr
e -> (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
i Maybe Modifier
forall a. Maybe a
Nothing,PortDirection
In,HWType
t,Expr
e)) [(Identifier, HWType)]
compInps [Expr]
argExprs'
                  outpAssign :: [(Expr, PortDirection, HWType, Expr)]
outpAssign    = case Maybe (Identifier, HWType)
compOutp of
                    Maybe (Identifier, HWType)
Nothing -> []
                    Just (Identifier
id_,HWType
hwtype) -> [(Identifier -> Maybe Modifier -> Expr
Identifier Identifier
id_ Maybe Modifier
forall a. Maybe a
Nothing,PortDirection
Out,HWType
hwtype,Identifier -> Maybe Modifier -> Expr
Identifier Identifier
dstId Maybe Modifier
forall a. Maybe a
Nothing)]
              let instLabel0 :: Text
instLabel0 = [Text] -> Text
StrictText.concat [Identifier -> Text
Id.toText Identifier
compName, Text
"_", Identifier -> Text
Id.toText Identifier
dstId]
              Text
instLabel1 <- Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
instLabel0 (Maybe Text -> Text)
-> NetlistMonad (Maybe Text) -> NetlistMonad Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Maybe Text) NetlistEnv (Maybe Text)
-> NetlistMonad (Maybe Text)
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting (Maybe Text) NetlistEnv (Maybe Text)
Lens' NetlistEnv (Maybe Text)
setName
              Text
instLabel2 <- Text -> NetlistMonad Text
affixName Text
instLabel1
              Identifier
instLabel3 <- Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic Text
instLabel2
              let portMap :: PortMap
portMap = [(Expr, PortDirection, HWType, Expr)] -> PortMap
NamedPortMap ([(Expr, PortDirection, HWType, Expr)]
outpAssign [(Expr, PortDirection, HWType, Expr)]
-> [(Expr, PortDirection, HWType, Expr)]
-> [(Expr, PortDirection, HWType, Expr)]
forall a. [a] -> [a] -> [a]
++ [(Expr, PortDirection, HWType, Expr)]
inpAssigns)
                  instDecl :: Declaration
instDecl = EntityOrComponent
-> Maybe Text
-> [Attr Text]
-> Identifier
-> Identifier
-> [(Expr, HWType, Expr)]
-> PortMap
-> Declaration
InstDecl EntityOrComponent
Entity Maybe Text
forall a. Maybe a
Nothing [] Identifier
compName Identifier
instLabel3 [] PortMap
portMap
              [(Expr, PortDirection, HWType, Expr)] -> NetlistMonad ()
declareInstUses [(Expr, PortDirection, HWType, Expr)]
outpAssign
              [Declaration] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Declaration]
argDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
argDecls' [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
instDecl])
            else
              let
                argsFiltered :: [Expr]
                argsFiltered :: [Expr]
argsFiltered = ((Expr, Type) -> Expr) -> [(Expr, Type)] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Expr, Type) -> Expr
forall a b. (a, b) -> a
fst [(Expr, Type)]
filteredTypeExprs
              in String -> NetlistMonad [Declaration]
forall a. HasCallStack => String -> a
error [I.i|
              Under-applied normalized function at component #{compName}:

              #{showPpr fun}

              Core:

              #{showPpr bindingTerm}

              Applied to arguments:
              #{showPpr args}

              Applied to filtered arguments:
              #{argsFiltered}

              Component inputs:
              #{compInps}
            |]
    (Bool, Maybe TopEntityT)
_ ->
      case [Term]
args of
        [] -> do
          -- TODO: Figure out what to do with zero-width constructs
          Declaration
assn <- HasCallStack => Identifier -> Expr -> NetlistMonad Declaration
Identifier -> Expr -> NetlistMonad Declaration
contAssign Identifier
dstId (Identifier -> Maybe Modifier -> Expr
Identifier (HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId Id
fun) Maybe Modifier
forall a. Maybe a
Nothing)
          [Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [Declaration
assn]
        [Term]
_ -> String -> NetlistMonad [Declaration]
forall a. HasCallStack => String -> a
error [I.i|
          Netlist generation encountered a local function. This should not
          happen. Function:

            #{showPpr fun}

          Arguments:

            #{showPpr args}

          Posssible user issues:

            * A top entity has an higher-order argument, e.g (Int -> Int) or
            Maybe (Int -> Int)

          Possible internal compiler issues:

            * 'bindOrLiftNonRep' failed to fire

            * 'caseCon' failed to eliminate something of a type such as
            "Maybe (Int -> Int)"
          |]

toSimpleVar :: Identifier
            -> (Expr,Type)
            -> NetlistMonad (Expr,[Declaration])
toSimpleVar :: Identifier -> (Expr, Type) -> NetlistMonad (Expr, [Declaration])
toSimpleVar Identifier
_ (e :: Expr
e@(Identifier Identifier
_ Maybe Modifier
Nothing),Type
_) = (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
e,[])
toSimpleVar Identifier
dstId (Expr
e,Type
ty) = do
  Identifier
argNm <- Identifier -> Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Identifier -> Text -> m Identifier
Id.suffix Identifier
dstId Text
"fun_arg"
  HWType
hTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(String
curLoc) Type
ty
  [Declaration]
argDecl <- HasCallStack =>
DeclarationType
-> Usage
-> Identifier
-> HWType
-> Expr
-> NetlistMonad [Declaration]
DeclarationType
-> Usage
-> Identifier
-> HWType
-> Expr
-> NetlistMonad [Declaration]
mkInit DeclarationType
Concurrent Usage
Cont Identifier
argNm HWType
hTy Expr
e
  (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
argNm Maybe Modifier
forall a. Maybe a
Nothing, [Declaration]
argDecl)

-- | Generate an expression for a term occurring on the RHS of a let-binder
mkExpr :: HasCallStack
       => Bool -- ^ Treat BlackBox expression as declaration
       -> DeclarationType
       -- ^ Should the returned declarations be concurrent or sequential?
       -> NetlistId -- ^ Name hint for the id to (potentially) assign the result to
       -> Term -- ^ Term to convert to an expression
       -> NetlistMonad (Expr,[Declaration]) -- ^ Returned expression and a list of generate BlackBox declarations
mkExpr :: Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
_ DeclarationType
_ NetlistId
_ (Term -> Term
stripTicks -> Core.Literal Literal
l) = do
  Int
iw <- Getting Int NetlistEnv Int -> NetlistMonad Int
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting Int NetlistEnv Int
Getter NetlistEnv Int
intWidth
  (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Int -> Literal -> Expr
mkLiteral Int
iw Literal
l, [])

mkExpr Bool
bbEasD DeclarationType
declType NetlistId
bndr Term
app =
 let (Term
appF,[Either Term Type]
args,[TickInfo]
ticks) = Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks Term
app
     ([Term]
tmArgs,[Type]
tyArgs) = [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Term Type]
args
 in  [TickInfo]
-> ([Declaration] -> NetlistMonad (Expr, [Declaration]))
-> NetlistMonad (Expr, [Declaration])
forall a.
[TickInfo] -> ([Declaration] -> NetlistMonad a) -> NetlistMonad a
withTicks [TickInfo]
ticks (([Declaration] -> NetlistMonad (Expr, [Declaration]))
 -> NetlistMonad (Expr, [Declaration]))
-> ([Declaration] -> NetlistMonad (Expr, [Declaration]))
-> NetlistMonad (Expr, [Declaration])
forall a b. (a -> b) -> a -> b
$ \[Declaration]
tickDecls -> do
  [HWType]
hwTys  <- (Type -> NetlistMonad HWType) -> [Type] -> NetlistMonad [HWType]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(String
curLoc)) (NetlistId -> [Type]
netlistTypes NetlistId
bndr)
  (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 hwTyA :: HWType
hwTyA = case [HWType]
hwTys of
        HWType
hwTy:[HWType]
_ -> HWType
hwTy
        [HWType]
_ -> String -> HWType
forall a. HasCallStack => String -> a
error (String
"internal error: unable to extract sufficient hwTys from: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NetlistId -> String
forall a. Show a => a -> String
show NetlistId
bndr)
  case Term
appF of
    Data DataCon
dc -> HasCallStack =>
DeclarationType
-> [HWType]
-> NetlistId
-> DataCon
-> [Term]
-> NetlistMonad (Expr, [Declaration])
DeclarationType
-> [HWType]
-> NetlistId
-> DataCon
-> [Term]
-> NetlistMonad (Expr, [Declaration])
mkDcApplication DeclarationType
declType [HWType]
hwTys NetlistId
bndr DataCon
dc [Term]
tmArgs
    Prim PrimInfo
pInfo -> Bool
-> Bool
-> DeclarationType
-> NetlistId
-> PrimInfo
-> [Either Term Type]
-> [Declaration]
-> NetlistMonad (Expr, [Declaration])
mkPrimitive Bool
False Bool
bbEasD DeclarationType
declType NetlistId
bndr PrimInfo
pInfo [Either Term Type]
args [Declaration]
tickDecls
    Var Id
f
      | [Term] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Term]
tmArgs ->
          if HWType -> Bool
isVoid HWType
hwTyA then
            (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
Noop, [])
          else do
            (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Identifier -> Maybe Modifier -> Expr
Identifier (HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId Id
f) Maybe Modifier
forall a. Maybe a
Nothing, [])
      | Bool -> Bool
not ([Type] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Type]
tyArgs) ->
          ClashException -> NetlistMonad (Expr, [Declaration])
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
"Not in normal form: "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Var-application with Type arguments:\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
app) Maybe String
forall a. Maybe a
Nothing)
      | Bool
otherwise -> do
          Identifier
argNm <- Identifier -> Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Identifier -> Text -> m Identifier
Id.suffix ((Identifier -> Identifier)
-> (Id -> Identifier) -> NetlistId -> Identifier
forall r.
HasCallStack =>
(Identifier -> r) -> (Id -> r) -> NetlistId -> r
netlistId1 Identifier -> Identifier
forall a. a -> a
id HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId NetlistId
bndr) Text
"fun_arg"
          [Declaration]
decls  <- HasCallStack =>
Identifier
-> Id -> [Term] -> [Declaration] -> NetlistMonad [Declaration]
Identifier
-> Id -> [Term] -> [Declaration] -> NetlistMonad [Declaration]
mkFunApp Identifier
argNm Id
f [Term]
tmArgs [Declaration]
tickDecls
          if HWType -> Bool
isVoid HWType
hwTyA then
            (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
Noop, [Declaration]
decls)
          else
            -- This net was already declared in the call to mkSelection.
            (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ( Identifier -> Maybe Modifier -> Expr
Identifier Identifier
argNm Maybe Modifier
forall a. Maybe a
Nothing
                   , Maybe Text -> Identifier -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Identifier
argNm HWType
hwTyA Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: [Declaration]
decls)
    Case Term
scrut Type
ty' [Alt
alt] -> Bool
-> NetlistId
-> Term
-> Type
-> Alt
-> NetlistMonad (Expr, [Declaration])
mkProjection Bool
bbEasD NetlistId
bndr Term
scrut Type
ty' Alt
alt
    Case Term
scrut Type
tyA (Alt
alt:[Alt]
alts) -> do
      Identifier
argNm <- Identifier -> Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Identifier -> Text -> m Identifier
Id.suffix ((Identifier -> Identifier)
-> (Id -> Identifier) -> NetlistId -> Identifier
forall r.
HasCallStack =>
(Identifier -> r) -> (Id -> r) -> NetlistId -> r
netlistId1 Identifier -> Identifier
forall a. a -> a
id HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId NetlistId
bndr) Text
"sel_arg"
      [Declaration]
decls  <- DeclarationType
-> NetlistId
-> Term
-> Type
-> NonEmpty Alt
-> [Declaration]
-> NetlistMonad [Declaration]
mkSelection DeclarationType
declType (Identifier -> Type -> NetlistId
NetlistId Identifier
argNm (HasCallStack => NetlistId -> Type
NetlistId -> Type
netlistTypes1 NetlistId
bndr))
                            Term
scrut Type
tyA (Alt
alt Alt -> [Alt] -> NonEmpty Alt
forall a. a -> [a] -> NonEmpty a
:| [Alt]
alts) [Declaration]
tickDecls
      if HWType -> Bool
isVoid HWType
hwTyA then
        (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
Noop, [Declaration]
decls)
      else
        -- This net was already declared in the call to mkSelection
        (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ( Identifier -> Maybe Modifier -> Expr
Identifier Identifier
argNm Maybe Modifier
forall a. Maybe a
Nothing
               , Maybe Text -> Identifier -> HWType -> Maybe Expr -> Declaration
NetDecl' Maybe Text
forall a. Maybe a
Nothing Identifier
argNm HWType
hwTyA Maybe Expr
forall a. Maybe a
NothingDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
decls)
    Letrec [LetBinding]
binders Term
body -> do
      [Declaration]
netDecls <- (LetBinding -> NetlistMonad [Declaration])
-> [LetBinding] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m [b]) -> [a] -> m [b]
concatMapM LetBinding -> NetlistMonad [Declaration]
mkNetDecl [LetBinding]
binders
      [Declaration]
decls    <- (LetBinding -> NetlistMonad [Declaration])
-> [LetBinding] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m [b]) -> [a] -> m [b]
concatMapM ((Id -> Term -> NetlistMonad [Declaration])
-> LetBinding -> NetlistMonad [Declaration]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (HasCallStack =>
DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
mkDeclarations' DeclarationType
declType)) [LetBinding]
binders
      (Expr
bodyE,[Declaration]
bodyDecls) <- HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
bbEasD DeclarationType
declType NetlistId
bndr (Term -> [Either Term Type] -> Term
mkApps (Term -> [TickInfo] -> Term
mkTicks Term
body [TickInfo]
ticks) [Either Term Type]
args)
      (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
bodyE,[Declaration]
netDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
decls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
bodyDecls)
    Term
_ -> ClashException -> NetlistMonad (Expr, [Declaration])
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
"Not in normal form: application of a Lambda-expression\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
app) Maybe String
forall a. Maybe a
Nothing)

-- | Generate an expression that projects a field out of a data-constructor.
--
-- Works for both product types, as sum-of-product types.
mkProjection
  :: Bool
  -- ^ Projection must bind to a simple variable
  -> NetlistId
  -- ^ Name hint for the signal to which the projection is (potentially) assigned
  -> Term
  -- ^ The subject/scrutinee of the projection
  -> Type
  -- ^ The type of the result
  -> Alt
  -- ^ The field to be projected
  -> NetlistMonad (Expr, [Declaration])
mkProjection :: Bool
-> NetlistId
-> Term
-> Type
-> Alt
-> NetlistMonad (Expr, [Declaration])
mkProjection Bool
mkDec NetlistId
bndr Term
scrut Type
altTy alt :: Alt
alt@(Pat
pat,Term
v) = do
  TyConMap
tcm <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
  let scrutTy :: Type
scrutTy = TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
scrut
      e :: Term
e = Term -> Type -> [Alt] -> Term
Case Term
scrut Type
scrutTy [Alt
alt]
  (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
  Id
varTm <- case Term
v of
    (Var Id
n) -> Id -> NetlistMonad Id
forall (m :: Type -> Type) a. Monad m => a -> m a
return Id
n
    Term
_ -> ClashException -> NetlistMonad Id
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
"Not in normal form: RHS of case-projection is not a variable:\n\n"
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
e) Maybe String
forall a. Maybe a
Nothing)
  HWType
sHwTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(String
curLoc) Type
scrutTy
  HWType
vHwTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(String
curLoc) Type
altTy
  Either [Declaration] (Identifier, Maybe Modifier, [Declaration])
scrutRendered <- do
    Identifier
scrutNm <-
      (Identifier -> NetlistMonad Identifier)
-> (Id -> NetlistMonad Identifier)
-> NetlistId
-> NetlistMonad Identifier
forall r.
HasCallStack =>
(Identifier -> r) -> (Id -> r) -> NetlistId -> r
netlistId1
        Identifier -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Identifier -> m Identifier
Id.next
        (\Id
b -> Identifier -> Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Identifier -> Text -> m Identifier
Id.suffix (HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId Id
b) Text
"projection")
        NetlistId
bndr
    (Expr
scrutExpr,[Declaration]
newDecls) <- HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Concurrent (Identifier -> Type -> NetlistId
NetlistId Identifier
scrutNm Type
scrutTy) Term
scrut
    case Expr
scrutExpr of
      Identifier Identifier
newId Maybe Modifier
modM ->
        Either [Declaration] (Identifier, Maybe Modifier, [Declaration])
-> NetlistMonad
     (Either [Declaration] (Identifier, Maybe Modifier, [Declaration]))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Identifier, Maybe Modifier, [Declaration])
-> Either [Declaration] (Identifier, Maybe Modifier, [Declaration])
forall a b. b -> Either a b
Right (Identifier
newId, Maybe Modifier
modM, [Declaration]
newDecls))
      Expr
Noop ->
        -- Scrutinee was a zero-width / void construct. We need to render its
        -- declarations, but it's no use assigning it to a new variable.
        -- TODO: Figure out whether we need to render alternatives too.
        -- TODO: seems useless?
        Either [Declaration] (Identifier, Maybe Modifier, [Declaration])
-> NetlistMonad
     (Either [Declaration] (Identifier, Maybe Modifier, [Declaration]))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Declaration]
-> Either [Declaration] (Identifier, Maybe Modifier, [Declaration])
forall a b. a -> Either a b
Left [Declaration]
newDecls)
      Expr
_ -> do
        [Declaration]
scrutDecl <- HasCallStack =>
DeclarationType
-> Usage
-> Identifier
-> HWType
-> Expr
-> NetlistMonad [Declaration]
DeclarationType
-> Usage
-> Identifier
-> HWType
-> Expr
-> NetlistMonad [Declaration]
mkInit DeclarationType
Concurrent Usage
Cont Identifier
scrutNm HWType
sHwTy Expr
scrutExpr
        Either [Declaration] (Identifier, Maybe Modifier, [Declaration])
-> NetlistMonad
     (Either [Declaration] (Identifier, Maybe Modifier, [Declaration]))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Identifier, Maybe Modifier, [Declaration])
-> Either [Declaration] (Identifier, Maybe Modifier, [Declaration])
forall a b. b -> Either a b
Right (Identifier
scrutNm, Maybe Modifier
forall a. Maybe a
Nothing, [Declaration]
newDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
scrutDecl))

  case Either [Declaration] (Identifier, Maybe Modifier, [Declaration])
scrutRendered of
    Left [Declaration]
newDecls -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Expr
Noop, [Declaration]
newDecls)
    Right (Identifier
selId, Maybe Modifier
modM, [Declaration]
decls) -> do
      let altVarId :: Identifier
altVarId = HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId Id
varTm
      Maybe Modifier
modifier <- case Pat
pat of
        DataPat DataCon
dc [TyVar]
exts [Id]
tms -> do
          let
            tms' :: [Id]
tms' =
              if [TyVar] -> [Id] -> Bool
forall a. [TyVar] -> [Var a] -> Bool
bindsExistentials [TyVar]
exts [Id]
tms then
                ClashException -> [Id]
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
"Not in normal form: Pattern binds existential variables:\n\n"
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
e) Maybe String
forall a. Maybe a
Nothing)
              else
                [Id]
tms
          [Maybe HWType]
argHWTys <- (Type -> NetlistMonad (Maybe HWType))
-> [Type] -> NetlistMonad [Maybe HWType]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> NetlistMonad (Maybe HWType)
coreTypeToHWTypeM' ((Id -> Type) -> [Id] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
forall a. HasType a => a -> Type
coreTypeOf [Id]
tms)
          let tmsBundled :: [(Maybe HWType, Id)]
tmsBundled   = [Maybe HWType] -> [Id] -> [(Maybe HWType, Id)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe HWType]
argHWTys [Id]
tms'
              tmsFiltered :: [(Maybe HWType, Id)]
tmsFiltered  = ((Maybe HWType, Id) -> Bool)
-> [(Maybe HWType, Id)] -> [(Maybe HWType, Id)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> (HWType -> Bool) -> Maybe HWType -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> Bool
not (Bool -> Bool) -> (HWType -> Bool) -> HWType -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HWType -> Bool
isVoid) (Maybe HWType -> Bool)
-> ((Maybe HWType, Id) -> Maybe HWType)
-> (Maybe HWType, Id)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe HWType, Id) -> Maybe HWType
forall a b. (a, b) -> a
fst) [(Maybe HWType, Id)]
tmsBundled
              tmsFiltered' :: [Id]
tmsFiltered' = ((Maybe HWType, Id) -> Id) -> [(Maybe HWType, Id)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe HWType, Id) -> Id
forall a b. (a, b) -> b
snd [(Maybe HWType, Id)]
tmsFiltered
          case Id -> [Id] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Id
varTm {varType :: Type
varType = Type
altTy} [Id]
tmsFiltered' of
            Maybe Int
Nothing -> Maybe Modifier -> NetlistMonad (Maybe Modifier)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe Modifier
forall a. Maybe a
Nothing
            Just Int
fI
              | HWType
sHwTy HWType -> HWType -> Bool
forall a. Eq a => a -> a -> Bool
/= HWType
vHwTy ->
                Maybe Modifier -> NetlistMonad (Maybe Modifier)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe Modifier -> NetlistMonad (Maybe Modifier))
-> Maybe Modifier -> NetlistMonad (Maybe Modifier)
forall a b. (a -> b) -> a -> b
$ Maybe Modifier -> Maybe Modifier -> Maybe Modifier
nestModifier Maybe Modifier
modM (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Indexed (HWType
sHwTy,DataCon -> Int
dcTag DataCon
dc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1,Int
fI)))
              -- When element and subject have the same HW-type,
              -- then the projections is just the identity
              | Bool
otherwise ->
                Maybe Modifier -> NetlistMonad (Maybe Modifier)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe Modifier -> NetlistMonad (Maybe Modifier))
-> Maybe Modifier -> NetlistMonad (Maybe Modifier)
forall a b. (a -> b) -> a -> b
$ Maybe Modifier -> Maybe Modifier -> Maybe Modifier
nestModifier Maybe Modifier
modM (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int) -> Modifier
DC (Maybe HWType -> HWType
Void Maybe HWType
forall a. Maybe a
Nothing,Int
0)))
        Pat
_ -> ClashException -> NetlistMonad (Maybe Modifier)
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
"Not in normal form: Unexpected pattern in case-projection:\n\n"
               String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
e) Maybe String
forall a. Maybe a
Nothing)
      let extractExpr :: Expr
extractExpr = Identifier -> Maybe Modifier -> Expr
Identifier (Identifier
-> (Modifier -> Identifier) -> Maybe Modifier -> Identifier
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Identifier
altVarId (Identifier -> Modifier -> Identifier
forall a b. a -> b -> a
const Identifier
selId) Maybe Modifier
modifier) Maybe Modifier
modifier
      case NetlistId
bndr of
        NetlistId Identifier
scrutNm Type
_ | Bool
mkDec -> do
          Identifier
scrutNm' <- Identifier -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Identifier -> m Identifier
Id.next Identifier
scrutNm
          [Declaration]
scrutDecl <- HasCallStack =>
DeclarationType
-> Usage
-> Identifier
-> HWType
-> Expr
-> NetlistMonad [Declaration]
DeclarationType
-> Usage
-> Identifier
-> HWType
-> Expr
-> NetlistMonad [Declaration]
mkInit DeclarationType
Concurrent Usage
Cont Identifier
scrutNm' HWType
vHwTy Expr
extractExpr
          (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
scrutNm' Maybe Modifier
forall a. Maybe a
Nothing, [Declaration]
scrutDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
decls)
        MultiId {} -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error String
"mkProjection: MultiId"
        NetlistId
_ -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
extractExpr,[Declaration]
decls)
  where
    nestModifier :: Maybe Modifier -> Maybe Modifier -> Maybe Modifier
nestModifier Maybe Modifier
Nothing  Maybe Modifier
m          = Maybe Modifier
m
    nestModifier Maybe Modifier
m Maybe Modifier
Nothing           = Maybe Modifier
m
    nestModifier (Just Modifier
m1) (Just Modifier
m2) = Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just (Modifier -> Modifier -> Modifier
Nested Modifier
m1 Modifier
m2)

-- | Generate an expression for a DataCon application occurring on the RHS of a let-binder
mkDcApplication
    :: HasCallStack
    => DeclarationType
    -> [HWType]
    -- ^ HWType of the LHS of the let-binder, can multiple types when we're
    -- creating a "split" product type (e.g. a tuple of a Clock and Reset)
    -> NetlistId
    -- ^ Name hint for result id
    -> DataCon
    -- ^ Applied DataCon
    -> [Term]
    -- ^ DataCon Arguments
    -> NetlistMonad (Expr,[Declaration])
    -- ^ Returned expression and a list of generate BlackBox declarations
mkDcApplication :: DeclarationType
-> [HWType]
-> NetlistId
-> DataCon
-> [Term]
-> NetlistMonad (Expr, [Declaration])
mkDcApplication DeclarationType
declType [HWType
dstHType] NetlistId
bndr DataCon
dc [Term]
args = do
  let dcNm :: Text
dcNm = Name DataCon -> Text
forall a. Name a -> Text
nameOcc (DataCon -> Name DataCon
dcName DataCon
dc)
  TyConMap
tcm <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
  let argTys :: [Type]
argTys = (Term -> Type) -> [Term] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm) [Term]
args
  Identifier
argNm <- (Identifier -> NetlistMonad Identifier)
-> (Id -> NetlistMonad Identifier)
-> NetlistId
-> NetlistMonad Identifier
forall r.
HasCallStack =>
(Identifier -> r) -> (Id -> r) -> NetlistId -> r
netlistId1 Identifier -> NetlistMonad Identifier
forall (m :: Type -> Type) a. Monad m => a -> m a
return (\Id
b -> Identifier -> Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Identifier -> Text -> m Identifier
Id.suffix (HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId Id
b) Text
"_dc_arg") NetlistId
bndr
  [Maybe HWType]
argHWTys <- (Type -> NetlistMonad (Maybe HWType))
-> [Type] -> NetlistMonad [Maybe HWType]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> NetlistMonad (Maybe HWType)
coreTypeToHWTypeM' [Type]
argTys

  ([Expr]
argExprs, [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat -> [Declaration]
argDecls) <- [(Expr, [Declaration])] -> ([Expr], [[Declaration]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Expr, [Declaration])] -> ([Expr], [[Declaration]]))
-> NetlistMonad [(Expr, [Declaration])]
-> NetlistMonad ([Expr], [[Declaration]])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
    ((Term, Type) -> NetlistMonad (Expr, [Declaration]))
-> [(Term, Type)] -> NetlistMonad [(Expr, [Declaration])]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Term
e,Type
t) -> HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
declType (Identifier -> Type -> NetlistId
NetlistId Identifier
argNm Type
t) Term
e) ([Term] -> [Type] -> [(Term, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Term]
args [Type]
argTys)

  -- Filter void arguments, but make sure to render their declarations:
  let
    filteredTypeExprDecls :: [(Maybe HWType, Expr)]
filteredTypeExprDecls =
      ((Maybe HWType, Expr) -> Bool)
-> [(Maybe HWType, Expr)] -> [(Maybe HWType, Expr)]
forall a. (a -> Bool) -> [a] -> [a]
filter
        (Bool -> Bool
not (Bool -> Bool)
-> ((Maybe HWType, Expr) -> Bool) -> (Maybe HWType, Expr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Maybe HWType -> Bool
isVoidMaybe Bool
True (Maybe HWType -> Bool)
-> ((Maybe HWType, Expr) -> Maybe HWType)
-> (Maybe HWType, Expr)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe HWType, Expr) -> Maybe HWType
forall a b. (a, b) -> a
fst)
        ([Maybe HWType] -> [Expr] -> [(Maybe HWType, Expr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe HWType]
argHWTys [Expr]
argExprs)

    ([Maybe HWType]
hWTysFiltered, [Expr]
argExprsFiltered) = [(Maybe HWType, Expr)] -> ([Maybe HWType], [Expr])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Maybe HWType, Expr)]
filteredTypeExprDecls

  (Expr -> (Expr, [Declaration]))
-> NetlistMonad Expr -> NetlistMonad (Expr, [Declaration])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (,[Declaration]
argDecls) (NetlistMonad Expr -> NetlistMonad (Expr, [Declaration]))
-> NetlistMonad Expr -> NetlistMonad (Expr, [Declaration])
forall a b. (a -> b) -> a -> b
$! case ([Maybe HWType]
hWTysFiltered,[Expr]
argExprsFiltered) of
    -- Is the DC just a newtype wrapper?
    ([Just HWType
argHwTy],[Expr
argExpr]) | HWType
argHwTy HWType -> HWType -> Bool
forall a. Eq a => a -> a -> Bool
== HWType
dstHType ->
      Expr -> NetlistMonad Expr
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Modifier -> [Expr] -> Expr
HW.DataCon HWType
dstHType ((HWType, Int) -> Modifier
DC (Maybe HWType -> HWType
Void Maybe HWType
forall a. Maybe a
Nothing,-Int
1)) [Expr
argExpr])
    ([Maybe HWType], [Expr])
_ -> case HWType
dstHType of
      SP Text
_ [(Text, [HWType])]
dcArgPairs -> do
        let dcI :: Int
dcI      = DataCon -> Int
dcTag DataCon
dc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
            dcArgs :: [HWType]
dcArgs   = (Text, [HWType]) -> [HWType]
forall a b. (a, b) -> b
snd ((Text, [HWType]) -> [HWType]) -> (Text, [HWType]) -> [HWType]
forall a b. (a -> b) -> a -> b
$ String -> [(Text, [HWType])] -> Int -> (Text, [HWType])
forall a. HasCallStack => String -> [a] -> Int -> a
indexNote ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"No DC with tag: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
dcI) [(Text, [HWType])]
dcArgPairs Int
dcI
        case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([HWType] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [HWType]
dcArgs) ([Expr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Expr]
argExprsFiltered) of
          Ordering
EQ -> Expr -> NetlistMonad Expr
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Modifier -> [Expr] -> Expr
HW.DataCon HWType
dstHType ((HWType, Int) -> Modifier
DC (HWType
dstHType,Int
dcI)) [Expr]
argExprsFiltered)
          Ordering
LT -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Over-applied constructor: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
StrictText.unpack Text
dcNm
          Ordering
GT -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Under-applied constructor: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
StrictText.unpack Text
dcNm
      Product Text
_ Maybe [Text]
_ [HWType]
dcArgs ->
        case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([HWType] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [HWType]
dcArgs) ([Expr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Expr]
argExprsFiltered) of
          Ordering
EQ -> Expr -> NetlistMonad Expr
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Modifier -> [Expr] -> Expr
HW.DataCon HWType
dstHType ((HWType, Int) -> Modifier
DC (HWType
dstHType,Int
0)) [Expr]
argExprsFiltered)
          Ordering
LT -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Over-applied constructor: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
StrictText.unpack Text
dcNm
          Ordering
GT -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Under-applied constructor:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
StrictText.unpack Text
dcNm
                                , String
"dcArgs=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines [String
" - " String -> String -> String
forall a. [a] -> [a] -> [a]
++ HWType -> String
forall a. Show a => a -> String
show HWType
x | HWType
x <- [HWType]
dcArgs]
                                , String
"argExprs=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines [String
" - " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
x | Expr
x <- [Expr]
argExprs]
                                , String
"hWTysFilt=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines [String
" - " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe HWType -> String
forall a. Show a => a -> String
show Maybe HWType
x | Maybe HWType
x <- [Maybe HWType]
hWTysFiltered]
                                , String
"argExprsFilt=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines [String
" - " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
x | Expr
x <- [Expr]
argExprsFiltered]
                                ]
      CustomProduct Text
_ DataRepr'
_ Int
_ Maybe [Text]
_ [(Integer, HWType)]
dcArgs ->
        case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([(Integer, HWType)] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [(Integer, HWType)]
dcArgs) ([Expr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Expr]
argExprsFiltered) of
          Ordering
EQ -> Expr -> NetlistMonad Expr
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Modifier -> [Expr] -> Expr
HW.DataCon HWType
dstHType ((HWType, Int) -> Modifier
DC (HWType
dstHType,Int
0)) [Expr]
argExprsFiltered)
          Ordering
LT -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Over-applied constructor: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
StrictText.unpack Text
dcNm
          Ordering
GT -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Under-applied constructor: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
StrictText.unpack Text
dcNm
      Sum Text
_ [Text]
_ ->
        Expr -> NetlistMonad Expr
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Modifier -> [Expr] -> Expr
HW.DataCon HWType
dstHType ((HWType, Int) -> Modifier
DC (HWType
dstHType,DataCon -> Int
dcTag DataCon
dc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) [])
      CustomSP Text
_ DataRepr'
_ Int
_ [(ConstrRepr', Text, [HWType])]
dcArgsTups -> do
        -- Safely get item from list, or err with note
        let dcI :: Int
dcI    = DataCon -> Int
dcTag DataCon
dc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        let note :: String
note   = $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"No DC with tag: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
dcI
        let argTup :: (ConstrRepr', Text, [HWType])
argTup = String
-> [(ConstrRepr', Text, [HWType])]
-> Int
-> (ConstrRepr', Text, [HWType])
forall a. HasCallStack => String -> [a] -> Int -> a
indexNote String
note [(ConstrRepr', Text, [HWType])]
dcArgsTups Int
dcI
        let (ConstrRepr'
_, Text
_, [HWType]
dcArgs) = (ConstrRepr', Text, [HWType])
argTup

        case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([HWType] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [HWType]
dcArgs) ([Expr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Expr]
argExprsFiltered) of
          Ordering
EQ -> Expr -> NetlistMonad Expr
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Modifier -> [Expr] -> Expr
HW.DataCon HWType
dstHType ((HWType, Int) -> Modifier
DC (HWType
dstHType, Int
dcI)) [Expr]
argExprsFiltered)
          Ordering
LT -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Over-applied constructor: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
StrictText.unpack Text
dcNm
          Ordering
GT -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Under-applied constructor: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
StrictText.unpack Text
dcNm

      CustomSum Text
_ DataRepr'
_ Int
_ [(ConstrRepr', Text)]
_ ->
        Expr -> NetlistMonad Expr
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Modifier -> [Expr] -> Expr
HW.DataCon HWType
dstHType ((HWType, Int) -> Modifier
DC (HWType
dstHType, DataCon -> Int
dcTag DataCon
dc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) [])
      Enable Text
_ ->
        case [Expr]
argExprsFiltered of
          [Expr
x] -> Expr -> NetlistMonad Expr
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Modifier -> [Expr] -> Expr
HW.DataCon HWType
dstHType ((HWType, Int) -> Modifier
DC (HWType
dstHType,DataCon -> Int
dcTag DataCon
dc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) [Expr
x])
          [Expr]
_   -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"unexpected arguments to Enable: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Expr] -> String
forall a. Show a => a -> String
show [Expr]
argExprsFiltered
      HWType
Bool ->
        let dc' :: Expr
dc' = case DataCon -> Int
dcTag DataCon
dc of
                   Int
1  -> Maybe (HWType, Int) -> Literal -> Expr
HW.Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (Bool -> Literal
BoolLit Bool
False)
                   Int
2  -> Maybe (HWType, Int) -> Literal -> Expr
HW.Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (Bool -> Literal
BoolLit Bool
True)
                   Int
tg -> String -> Expr
forall a. HasCallStack => String -> a
error (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"unknown bool literal: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DataCon -> String
forall p. PrettyPrec p => p -> String
showPpr DataCon
dc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(tag: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
tg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
        in  Expr -> NetlistMonad Expr
forall (m :: Type -> Type) a. Monad m => a -> m a
return Expr
dc'
      Vector Int
0 HWType
_ -> Expr -> NetlistMonad Expr
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Modifier -> [Expr] -> Expr
HW.DataCon HWType
dstHType Modifier
VecAppend [])
      Vector Int
1 HWType
_ -> case [Expr]
argExprsFiltered of
                      [Expr
e] -> Expr -> NetlistMonad Expr
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Modifier -> [Expr] -> Expr
HW.DataCon HWType
dstHType Modifier
VecAppend [Expr
e])
                      [Expr]
_ -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Unexpected number of arguments for `Cons`: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Term] -> String
forall p. PrettyPrec p => p -> String
showPpr [Term]
args
      Vector Int
_ HWType
_ -> case [Expr]
argExprsFiltered of
                      [Expr
e1,Expr
e2] -> Expr -> NetlistMonad Expr
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Modifier -> [Expr] -> Expr
HW.DataCon HWType
dstHType Modifier
VecAppend [Expr
e1,Expr
e2])
                      [Expr]
_ -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Unexpected number of arguments for `Cons`: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Term] -> String
forall p. PrettyPrec p => p -> String
showPpr [Term]
args
      MemBlob Int
_ Int
_ ->
        case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
6 ([Expr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Expr]
argExprsFiltered) of
          Ordering
EQ -> Expr -> NetlistMonad Expr
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Modifier -> [Expr] -> Expr
HW.DataCon HWType
dstHType ((HWType, Int) -> Modifier
DC (HWType
dstHType,Int
0)) [Expr]
argExprsFiltered)
          Ordering
LT -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Over-applied constructor"
          Ordering
GT -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Under-applied constructor"
      RTree Int
0 HWType
_ -> case [Expr]
argExprsFiltered of
                      [Expr
e] -> Expr -> NetlistMonad Expr
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Modifier -> [Expr] -> Expr
HW.DataCon HWType
dstHType Modifier
RTreeAppend [Expr
e])
                      [Expr]
_ -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Unexpected number of arguments for `LR`: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Term] -> String
forall p. PrettyPrec p => p -> String
showPpr [Term]
args
      RTree Int
_ HWType
_ -> case [Expr]
argExprsFiltered of
                      [Expr
e1,Expr
e2] -> Expr -> NetlistMonad Expr
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Modifier -> [Expr] -> Expr
HW.DataCon HWType
dstHType Modifier
RTreeAppend [Expr
e1,Expr
e2])
                      [Expr]
_ -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Unexpected number of arguments for `BR`: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Term] -> String
forall p. PrettyPrec p => p -> String
showPpr [Term]
args
      HWType
String ->
        let dc' :: Expr
dc' = case DataCon -> Int
dcTag DataCon
dc of
                    Int
1 -> Maybe (HWType, Int) -> Literal -> Expr
HW.Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (String -> Literal
StringLit String
"")
                    Int
_ -> String -> Expr
forall a. HasCallStack => String -> a
error (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"mkDcApplication undefined for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (HWType, DataCon, Int, [Term], [Maybe HWType]) -> String
forall a. Show a => a -> String
show (HWType
dstHType,DataCon
dc,DataCon -> Int
dcTag DataCon
dc,[Term]
args,[Maybe HWType]
argHWTys)
        in  Expr -> NetlistMonad Expr
forall (m :: Type -> Type) a. Monad m => a -> m a
return Expr
dc'
      Void {} -> Expr -> NetlistMonad Expr
forall (m :: Type -> Type) a. Monad m => a -> m a
return Expr
Noop
      Signed Int
_
#if MIN_VERSION_base(4,15,0)
        | dcNm == "GHC.Num.Integer.IS"
#else
        | Text
dcNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Integer.Type.S#"
#endif
        , (Expr
a:[Expr]
_) <- [Expr]
argExprsFiltered
        -> Expr -> NetlistMonad Expr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Expr
a
        -- ByteArray# are non-translatable / void, except when they're literals
#if MIN_VERSION_base(4,15,0)
        | dcNm == "GHC.Num.Integer.IP"
#else
        | Text
dcNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Integer.Type.Jp#"
#endif
        , (a :: Expr
a@(HW.Literal Maybe (HWType, Int)
Nothing (NumLit Integer
_)):[Expr]
_) <- [Expr]
argExprs
        -> Expr -> NetlistMonad Expr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Expr
a
#if MIN_VERSION_base(4,15,0)
        | dcNm == "GHC.Num.Integer.IN"
#else
        | Text
dcNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Integer.Type.Jn#"
#endif
        -- ByteArray# are non-translatable / void, except when they're literals
        , (HW.Literal Maybe (HWType, Int)
Nothing (NumLit Integer
i):[Expr]
_) <- [Expr]
argExprs
        -> Expr -> NetlistMonad Expr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe (HWType, Int) -> Literal -> Expr
HW.Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (Integer -> Literal
NumLit (Integer -> Integer
forall a. Num a => a -> a
negate Integer
i)))
      Unsigned Int
_
#if MIN_VERSION_base(4,15,0)
        | dcNm == "GHC.Num.Natural.NS"
#else
        | Text
dcNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Natural.NatS#"
#endif
        , (Expr
a:[Expr]
_) <- [Expr]
argExprsFiltered
        -> Expr -> NetlistMonad Expr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Expr
a
#if MIN_VERSION_base(4,15,0)
        | dcNm == "GHC.Num.Natural.NB"
#else
        | Text
dcNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Natural.NatJ#"
#endif
        -- ByteArray# are non-translatable / void, except when they're literals
        , (a :: Expr
a@(HW.Literal Maybe (HWType, Int)
Nothing (NumLit Integer
_)):[Expr]
_) <- [Expr]
argExprs
        -> Expr -> NetlistMonad Expr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Expr
a
      HWType
_ ->
        String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"mkDcApplication undefined for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (HWType, DataCon, [Term], [Maybe HWType]) -> String
forall a. Show a => a -> String
show (HWType
dstHType,DataCon
dc,[Term]
args,[Maybe HWType]
argHWTys)

-- Handle MultiId assignment
mkDcApplication DeclarationType
declType [HWType]
dstHTypes (MultiId [Id]
argNms) DataCon
_ [Term]
args = do
  TyConMap
tcm                 <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
  let argTys :: [Type]
argTys          = (Term -> Type) -> [Term] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm) [Term]
args
  [Maybe HWType]
argHWTys            <- (Type -> NetlistMonad (Maybe HWType))
-> [Type] -> NetlistMonad [Maybe HWType]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> NetlistMonad (Maybe HWType)
coreTypeToHWTypeM' [Type]
argTys
  -- Filter out the arguments of hwtype `Void` and only translate
  -- them to the intermediate HDL afterwards
  let argsBundled :: [(Maybe HWType, (NetlistId, Term))]
argsBundled   = [Maybe HWType]
-> [(NetlistId, Term)] -> [(Maybe HWType, (NetlistId, Term))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe HWType]
argHWTys ([NetlistId] -> [Term] -> [(NetlistId, Term)]
forall a b. HasCallStack => [a] -> [b] -> [(a, b)]
zipEqual ((Id -> NetlistId) -> [Id] -> [NetlistId]
forall a b. (a -> b) -> [a] -> [b]
map Id -> NetlistId
CoreId [Id]
argNms) [Term]
args)
      ([Maybe HWType]
_hWTysFiltered,[(NetlistId, Term)]
argsFiltered) = [(Maybe HWType, (NetlistId, Term))]
-> ([Maybe HWType], [(NetlistId, Term)])
forall a b. [(a, b)] -> ([a], [b])
unzip
        (((Maybe HWType, (NetlistId, Term)) -> Bool)
-> [(Maybe HWType, (NetlistId, Term))]
-> [(Maybe HWType, (NetlistId, Term))]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> (HWType -> Bool) -> Maybe HWType -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Bool -> Bool
not (Bool -> Bool) -> (HWType -> Bool) -> HWType -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HWType -> Bool
isVoid) (Maybe HWType -> Bool)
-> ((Maybe HWType, (NetlistId, Term)) -> Maybe HWType)
-> (Maybe HWType, (NetlistId, Term))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe HWType, (NetlistId, Term)) -> Maybe HWType
forall a b. (a, b) -> a
fst) [(Maybe HWType, (NetlistId, Term))]
argsBundled)
  ([Expr]
argExprs,[Declaration]
argDecls) <- ([(Expr, [Declaration])] -> ([Expr], [Declaration]))
-> NetlistMonad [(Expr, [Declaration])]
-> NetlistMonad ([Expr], [Declaration])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (([[Declaration]] -> [Declaration])
-> ([Expr], [[Declaration]]) -> ([Expr], [Declaration])
forall (p :: Type -> Type -> Type) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat (([Expr], [[Declaration]]) -> ([Expr], [Declaration]))
-> ([(Expr, [Declaration])] -> ([Expr], [[Declaration]]))
-> [(Expr, [Declaration])]
-> ([Expr], [Declaration])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Expr, [Declaration])] -> ([Expr], [[Declaration]])
forall a b. [(a, b)] -> ([a], [b])
unzip) (NetlistMonad [(Expr, [Declaration])]
 -> NetlistMonad ([Expr], [Declaration]))
-> NetlistMonad [(Expr, [Declaration])]
-> NetlistMonad ([Expr], [Declaration])
forall a b. (a -> b) -> a -> b
$!
                         ((NetlistId, Term) -> NetlistMonad (Expr, [Declaration]))
-> [(NetlistId, Term)] -> NetlistMonad [(Expr, [Declaration])]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((NetlistId -> Term -> NetlistMonad (Expr, [Declaration]))
-> (NetlistId, Term) -> NetlistMonad (Expr, [Declaration])
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
declType)) [(NetlistId, Term)]
argsFiltered
  if [HWType] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [HWType]
dstHTypes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Expr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Expr]
argExprs then do
    [Declaration]
assns <- ((NetlistId, Expr) -> NetlistMonad (Maybe Declaration))
-> [(NetlistId, Expr)] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM
                  (\case (NetlistId
_,Expr
Noop) -> Maybe Declaration -> NetlistMonad (Maybe Declaration)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe Declaration
forall a. Maybe a
Nothing
                         (NetlistId
dstId,Expr
e) -> let nm :: Identifier
nm = (Identifier -> Identifier)
-> (Id -> Identifier) -> NetlistId -> Identifier
forall r.
HasCallStack =>
(Identifier -> r) -> (Id -> r) -> NetlistId -> r
netlistId1 Identifier -> Identifier
forall a. a -> a
id HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId NetlistId
dstId
                                       in case Expr
e of
                                            Identifier Identifier
nm0 Maybe Modifier
Nothing
                                              | Identifier
nm Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Identifier
nm0 -> Maybe Declaration -> NetlistMonad (Maybe Declaration)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe Declaration
forall a. Maybe a
Nothing
                                            Expr
_ -> Declaration -> Maybe Declaration
forall a. a -> Maybe a
Just (Declaration -> Maybe Declaration)
-> NetlistMonad Declaration -> NetlistMonad (Maybe Declaration)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> case DeclarationType
declType of
                                                            DeclarationType
Concurrent -> HasCallStack => Identifier -> Expr -> NetlistMonad Declaration
Identifier -> Expr -> NetlistMonad Declaration
contAssign Identifier
nm Expr
e
                                                            DeclarationType
Sequential -> HasCallStack =>
Blocking -> Identifier -> Expr -> NetlistMonad Declaration
Blocking -> Identifier -> Expr -> NetlistMonad Declaration
procAssign Blocking
Blocking Identifier
nm Expr
e)
                  ([NetlistId] -> [Expr] -> [(NetlistId, Expr)]
forall a b. HasCallStack => [a] -> [b] -> [(a, b)]
zipEqual ((Id -> NetlistId) -> [Id] -> [NetlistId]
forall a b. (a -> b) -> [a] -> [b]
map Id -> NetlistId
CoreId [Id]
argNms) [Expr]
argExprs)
    (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
Noop,[Declaration]
argDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
assns)
  else
    String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error String
"internal error"

mkDcApplication DeclarationType
_ [HWType]
_ NetlistId
_ DataCon
_ [Term]
_ = String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error String
"internal error"