{-|
  Copyright   :  (C) 2012-2016, University of Twente,
                     2016-2017, Myrtle Software Ltd,
                     2017-2018, Google Inc.
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>

  Create Netlists out of normalized CoreHW Terms
-}

{-# 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                    (join)
import           Control.Monad.IO.Class           (liftIO)
import           Control.Monad.Reader             (runReaderT)
import           Control.Monad.State.Strict       (State, runStateT)
import           Data.Binary.IEEE754              (floatToWord, doubleToWord)
import           Data.Char                        (ord)
import           Data.Either                      (partitionEithers, rights)
import           Data.HashMap.Strict              (HashMap)
import qualified Data.HashMap.Strict              as HashMapS
import qualified Data.HashMap.Lazy                as HashMap
import           Data.List                        (elemIndex, partition, sortOn)
import           Data.Maybe
  (catMaybes, listToMaybe, mapMaybe, fromMaybe)
import qualified Data.Set                         as Set
import           Data.Primitive.ByteArray         (ByteArray (..))
import qualified Data.Text                        as StrictText
import qualified Data.Vector.Primitive            as PV
import           GHC.Integer.GMP.Internals        (Integer (..), BigNat (..))
import           System.FilePath                  ((</>), (<.>))
import           Text.Read                        (readMaybe)

import           Outputable                       (ppr, showSDocUnsafe)
import           SrcLoc                           (isGoodSrcSpan)

import           Clash.Annotations.Primitive      (extractPrim)
import           Clash.Annotations.BitRepresentation.ClashLib
  (coreToType')
import           Clash.Annotations.BitRepresentation.Internal
  (CustomReprs, DataRepr'(..), ConstrRepr'(..), getDataRepr, getConstrRepr)
import           Clash.Annotations.TopEntity      (TopEntity (..))
import           Clash.Core.DataCon               (DataCon (..))
import           Clash.Core.Literal               (Literal (..))
import           Clash.Core.Name                  (Name(..))
import           Clash.Core.Pretty                (showPpr)
import           Clash.Core.Term
  (Alt, Pat (..), Term (..), TickInfo (..), PrimInfo(primName), collectArgs, collectArgsTicks, collectTicks)
import qualified Clash.Core.Term                  as Core
import           Clash.Core.Type
  (Type (..), coreView1, splitFunForallTy, splitCoreFunForallTy)
import           Clash.Core.TyCon                 (TyConMap)
import           Clash.Core.Util
  (mkApps, mkTicks, splitShouldSplit, stripTicks, termType)
import           Clash.Core.Var                   (Id, Var (..), isGlobalId)
import           Clash.Core.VarEnv
  (VarEnv, eltsVarEnv, emptyInScopeSet, emptyVarEnv, extendVarEnv, lookupVarEnv,
   lookupVarEnv', mkVarEnv)
import           Clash.Driver.Types               (BindingMap, Binding(..), ClashOpts (..))
import           Clash.Netlist.BlackBox
import           Clash.Netlist.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
  :: Bool
  -- ^ Whether this we're compiling a testbench (suppresses certain warnings)
  -> ClashOpts
  -- ^ Options Clash was called with
  -> CustomReprs
  -- ^ Custom bit representations for certain types
  -> BindingMap
  -- ^ Global binders
  -> [TopEntityT]
  -- ^ All the TopEntities
  -> CompiledPrimMap
  -- ^ Primitive definitions
  -> TyConMap
  -- ^ TyCon cache
  -> (CustomReprs -> TyConMap -> Type ->
      State HWMap (Maybe (Either String FilteredHWType)))
  -- ^ Hardcoded Type -> HWType translator
  -> Int
  -- ^ Int/Word/Integer bit-width
  -> (IdType -> Identifier -> Identifier)
  -- ^ valid identifiers
  -> (IdType -> Identifier -> Identifier -> Identifier)
  -- ^ extend valid identifiers
  -> Bool
  -- ^ Whether the backend supports ifThenElse expressions
  -> SomeBackend
  -- ^ The current HDL backend
  -> HashMap Identifier Word
  -- ^ Seen components
  -> FilePath
  -- ^ HDL dir
  -> (Maybe Identifier,Maybe Identifier)
  -- ^ Component name prefix
  -> Id
  -- ^ Name of the @topEntity@
  -> IO ([([Bool],SrcSpan,HashMap Identifier Word,Component)],HashMap Identifier Word)
genNetlist :: Bool
-> ClashOpts
-> CustomReprs
-> BindingMap
-> [TopEntityT]
-> CompiledPrimMap
-> TyConMap
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> Int
-> (IdType -> Identifier -> Identifier)
-> (IdType -> Identifier -> Identifier -> Identifier)
-> Bool
-> SomeBackend
-> HashMap Identifier Word
-> String
-> (Maybe Identifier, Maybe Identifier)
-> Id
-> IO
     ([([Bool], SrcSpan, HashMap Identifier Word, Component)],
      HashMap Identifier Word)
genNetlist isTb :: Bool
isTb opts :: ClashOpts
opts reprs :: CustomReprs
reprs globals :: BindingMap
globals tops :: [TopEntityT]
tops primMap :: CompiledPrimMap
primMap tcm :: TyConMap
tcm typeTrans :: CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
typeTrans iw :: Int
iw mkId :: IdType -> Identifier -> Identifier
mkId extId :: IdType -> Identifier -> Identifier -> Identifier
extId ite :: Bool
ite be :: SomeBackend
be seen :: HashMap Identifier Word
seen env :: String
env prefixM :: (Maybe Identifier, Maybe Identifier)
prefixM topEntity :: Id
topEntity = do
  (_,s :: NetlistState
s) <- Bool
-> ClashOpts
-> CustomReprs
-> BindingMap
-> VarEnv TopEntityT
-> CompiledPrimMap
-> TyConMap
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> Int
-> (IdType -> Identifier -> Identifier)
-> (IdType -> Identifier -> Identifier -> Identifier)
-> Bool
-> SomeBackend
-> HashMap Identifier Word
-> String
-> (Maybe Identifier, Maybe Identifier)
-> NetlistMonad
     ([Bool], SrcSpan, HashMap Identifier Word, Component)
-> IO
     (([Bool], SrcSpan, HashMap Identifier Word, Component),
      NetlistState)
forall a.
Bool
-> ClashOpts
-> CustomReprs
-> BindingMap
-> VarEnv TopEntityT
-> CompiledPrimMap
-> TyConMap
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> Int
-> (IdType -> Identifier -> Identifier)
-> (IdType -> Identifier -> Identifier -> Identifier)
-> Bool
-> SomeBackend
-> HashMap Identifier Word
-> String
-> (Maybe Identifier, Maybe Identifier)
-> NetlistMonad a
-> IO (a, NetlistState)
runNetlistMonad Bool
isTb ClashOpts
opts CustomReprs
reprs BindingMap
globals VarEnv TopEntityT
topEntityMap
             CompiledPrimMap
primMap TyConMap
tcm CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
typeTrans Int
iw IdType -> Identifier -> Identifier
mkId IdType -> Identifier -> Identifier -> Identifier
extId Bool
ite SomeBackend
be HashMap Identifier Word
seen String
env (Maybe Identifier, Maybe Identifier)
prefixM (NetlistMonad ([Bool], SrcSpan, HashMap Identifier Word, Component)
 -> IO
      (([Bool], SrcSpan, HashMap Identifier Word, Component),
       NetlistState))
-> NetlistMonad
     ([Bool], SrcSpan, HashMap Identifier Word, Component)
-> IO
     (([Bool], SrcSpan, HashMap Identifier Word, Component),
      NetlistState)
forall a b. (a -> b) -> a -> b
$
             HasCallStack =>
Id
-> NetlistMonad
     ([Bool], SrcSpan, HashMap Identifier Word, Component)
Id
-> NetlistMonad
     ([Bool], SrcSpan, HashMap Identifier Word, Component)
genComponent Id
topEntity
  ([([Bool], SrcSpan, HashMap Identifier Word, Component)],
 HashMap Identifier Word)
-> IO
     ([([Bool], SrcSpan, HashMap Identifier Word, Component)],
      HashMap Identifier Word)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ( VarEnv ([Bool], SrcSpan, HashMap Identifier Word, Component)
-> [([Bool], SrcSpan, HashMap Identifier Word, Component)]
forall a. VarEnv a -> [a]
eltsVarEnv (VarEnv ([Bool], SrcSpan, HashMap Identifier Word, Component)
 -> [([Bool], SrcSpan, HashMap Identifier Word, Component)])
-> VarEnv ([Bool], SrcSpan, HashMap Identifier Word, Component)
-> [([Bool], SrcSpan, HashMap Identifier Word, Component)]
forall a b. (a -> b) -> a -> b
$ NetlistState
-> VarEnv ([Bool], SrcSpan, HashMap Identifier Word, Component)
_components NetlistState
s
         , NetlistState -> HashMap Identifier Word
_seenComps NetlistState
s
         )
  where
    topEntityMap :: VarEnv TopEntityT
    topEntityMap :: VarEnv TopEntityT
topEntityMap = [(Id, TopEntityT)] -> VarEnv TopEntityT
forall a b. [(Var a, b)] -> VarEnv b
mkVarEnv ([Id] -> [TopEntityT] -> [(Id, TopEntityT)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((TopEntityT -> Id) -> [TopEntityT] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map TopEntityT -> Id
topId [TopEntityT]
tops) [TopEntityT]
tops)

-- | Run a NetlistMonad action in a given environment
runNetlistMonad
  :: Bool
  -- ^ Whether this we're compiling a testbench (suppresses certain warnings)
  -> ClashOpts
  -- ^ Options Clash was called with
  -> CustomReprs
  -- ^ Custom bit representations for certain types
  -> BindingMap
  -- ^ Global binders
  -> VarEnv TopEntityT
  -- ^ TopEntity annotations
  -> CompiledPrimMap
  -- ^ Primitive Definitions
  -> TyConMap
  -- ^ TyCon cache
  -> (CustomReprs -> TyConMap -> Type ->
      State HWMap (Maybe (Either String FilteredHWType)))
  -- ^ Hardcode Type -> HWType translator
  -> Int
  -- ^ Int/Word/Integer bit-width
  -> (IdType -> Identifier -> Identifier)
  -- ^ valid identifiers
  -> (IdType -> Identifier -> Identifier -> Identifier)
  -- ^ extend valid identifiers
  -> Bool
  -- ^ Whether the backend supports ifThenElse expressions
  -> SomeBackend
  -- ^ The current HDL backend
  -> HashMap Identifier Word
  -- ^ Seen components
  -> FilePath
  -- ^ HDL dir
  -> (Maybe Identifier,Maybe Identifier)
  -- ^ Component name prefix
  -> NetlistMonad a
  -- ^ Action to run
  -> IO (a, NetlistState)
runNetlistMonad :: Bool
-> ClashOpts
-> CustomReprs
-> BindingMap
-> VarEnv TopEntityT
-> CompiledPrimMap
-> TyConMap
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> Int
-> (IdType -> Identifier -> Identifier)
-> (IdType -> Identifier -> Identifier -> Identifier)
-> Bool
-> SomeBackend
-> HashMap Identifier Word
-> String
-> (Maybe Identifier, Maybe Identifier)
-> NetlistMonad a
-> IO (a, NetlistState)
runNetlistMonad isTb :: Bool
isTb opts :: ClashOpts
opts reprs :: CustomReprs
reprs s :: BindingMap
s tops :: VarEnv TopEntityT
tops p :: CompiledPrimMap
p tcm :: TyConMap
tcm typeTrans :: CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
typeTrans iw :: Int
iw mkId :: IdType -> Identifier -> Identifier
mkId extId :: IdType -> Identifier -> Identifier -> Identifier
extId ite :: Bool
ite be :: SomeBackend
be seenIds_ :: HashMap Identifier Word
seenIds_ env :: String
env prefixM :: (Maybe Identifier, Maybe Identifier)
prefixM
  = (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 (Identifier -> Identifier -> Maybe Identifier -> NetlistEnv
NetlistEnv "" "" Maybe Identifier
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' =
      BindingMap
-> Int
-> VarEnv ([Bool], SrcSpan, HashMap Identifier Word, Component)
-> CompiledPrimMap
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> TyConMap
-> (Identifier, SrcSpan)
-> Int
-> (IdType -> Identifier -> Identifier)
-> (IdType -> Identifier -> Identifier -> Identifier)
-> HashMap Identifier Word
-> HashMap Identifier Word
-> Set Identifier
-> VarEnv Identifier
-> VarEnv TopEntityT
-> String
-> Int
-> (Maybe Identifier, Maybe Identifier)
-> CustomReprs
-> ClashOpts
-> Bool
-> Bool
-> SomeBackend
-> HWMap
-> NetlistState
NetlistState
        BindingMap
s 0 VarEnv ([Bool], SrcSpan, HashMap Identifier Word, Component)
forall a. VarEnv a
emptyVarEnv CompiledPrimMap
p CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
typeTrans TyConMap
tcm (Identifier
StrictText.empty,SrcSpan
noSrcSpan) Int
iw IdType -> Identifier -> Identifier
mkId
        IdType -> Identifier -> Identifier -> Identifier
extId HashMap Identifier Word
forall k v. HashMap k v
HashMapS.empty HashMap Identifier Word
seenIds' Set Identifier
forall a. Set a
Set.empty VarEnv Identifier
names VarEnv TopEntityT
tops String
env 0 (Maybe Identifier, Maybe Identifier)
prefixM CustomReprs
reprs ClashOpts
opts Bool
isTb Bool
ite SomeBackend
be
        HWMap
forall k v. HashMap k v
HashMapS.empty

    (seenIds' :: HashMap Identifier Word
seenIds',names :: VarEnv Identifier
names) = Bool
-> (IdType -> Identifier -> Identifier)
-> (Maybe Identifier, Maybe Identifier)
-> HashMap Identifier Word
-> VarEnv Identifier
-> BindingMap
-> (HashMap Identifier Word, VarEnv Identifier)
genNames (ClashOpts -> Bool
opt_newInlineStrat ClashOpts
opts) IdType -> Identifier -> Identifier
mkId (Maybe Identifier, Maybe Identifier)
prefixM HashMap Identifier Word
seenIds_
                                VarEnv Identifier
forall a. VarEnv a
emptyVarEnv BindingMap
s

genNames :: Bool
         -> (IdType -> Identifier -> Identifier)
         -> (Maybe Identifier,Maybe Identifier)
         -> HashMap Identifier Word
         -> VarEnv Identifier
         -> BindingMap
         -> (HashMap Identifier Word, VarEnv Identifier)
genNames :: Bool
-> (IdType -> Identifier -> Identifier)
-> (Maybe Identifier, Maybe Identifier)
-> HashMap Identifier Word
-> VarEnv Identifier
-> BindingMap
-> (HashMap Identifier Word, VarEnv Identifier)
genNames newInlineStrat :: Bool
newInlineStrat mkId :: IdType -> Identifier -> Identifier
mkId prefixM :: (Maybe Identifier, Maybe Identifier)
prefixM s0 :: HashMap Identifier Word
s0 m0 :: VarEnv Identifier
m0 = (Binding
 -> (HashMap Identifier Word, VarEnv Identifier)
 -> (HashMap Identifier Word, VarEnv Identifier))
-> (HashMap Identifier Word, VarEnv Identifier)
-> BindingMap
-> (HashMap Identifier Word, VarEnv Identifier)
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Binding
-> (HashMap Identifier Word, VarEnv Identifier)
-> (HashMap Identifier Word, VarEnv Identifier)
go (HashMap Identifier Word
s0,VarEnv Identifier
m0)
  where
    go :: Binding
-> (HashMap Identifier Word, VarEnv Identifier)
-> (HashMap Identifier Word, VarEnv Identifier)
go b :: Binding
b (s :: HashMap Identifier Word
s,m :: VarEnv Identifier
m) =
      let nm' :: Identifier
nm' = Bool
-> HashMap Identifier Word
-> (IdType -> Identifier -> Identifier)
-> (Maybe Identifier, Maybe Identifier)
-> Id
-> Identifier
genComponentName Bool
newInlineStrat HashMap Identifier Word
s IdType -> Identifier -> Identifier
mkId (Maybe Identifier, Maybe Identifier)
prefixM (Binding -> Id
bindingId Binding
b)
          s' :: HashMap Identifier Word
s'  = Identifier
-> Word -> HashMap Identifier Word -> HashMap Identifier Word
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMapS.insert Identifier
nm' 0 HashMap Identifier Word
s
          m' :: VarEnv Identifier
m'  = Id -> Identifier -> VarEnv Identifier -> VarEnv Identifier
forall b a. Var b -> a -> VarEnv a -> VarEnv a
extendVarEnv (Binding -> Id
bindingId Binding
b) Identifier
nm' VarEnv Identifier
m
      in (HashMap Identifier Word
s', VarEnv Identifier
m')

-- | Generate a component for a given function (caching)
genComponent
  :: HasCallStack
  => Id
  -- ^ Name of the function
  -> NetlistMonad ([Bool],SrcSpan,HashMap Identifier Word,Component)
genComponent :: Id
-> NetlistMonad
     ([Bool], SrcSpan, HashMap Identifier Word, Component)
genComponent compName :: Id
compName = do
  Maybe Binding
compExprM <- Id -> BindingMap -> Maybe Binding
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
compName (BindingMap -> Maybe Binding)
-> NetlistMonad BindingMap -> NetlistMonad (Maybe Binding)
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
compExprM of
    Nothing -> do
      (_,sp :: 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
     ([Bool], SrcSpan, HashMap Identifier Word, Component)
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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 b :: Binding
b -> do
      Id
-> Lens'
     NetlistState
     (VarEnv ([Bool], SrcSpan, HashMap Identifier Word, Component))
-> NetlistMonad
     ([Bool], SrcSpan, HashMap Identifier Word, Component)
-> NetlistMonad
     ([Bool], SrcSpan, HashMap Identifier Word, Component)
forall s (m :: Type -> Type) k v.
(MonadState s m, Uniquable k) =>
k -> Lens' s (UniqMap v) -> m v -> m v
makeCachedU Id
compName Lens'
  NetlistState
  (VarEnv ([Bool], SrcSpan, HashMap Identifier Word, Component))
components (NetlistMonad ([Bool], SrcSpan, HashMap Identifier Word, Component)
 -> NetlistMonad
      ([Bool], SrcSpan, HashMap Identifier Word, Component))
-> NetlistMonad
     ([Bool], SrcSpan, HashMap Identifier Word, Component)
-> NetlistMonad
     ([Bool], SrcSpan, HashMap Identifier Word, Component)
forall a b. (a -> b) -> a -> b
$ HasCallStack =>
Id
-> Term
-> NetlistMonad
     ([Bool], SrcSpan, HashMap Identifier Word, Component)
Id
-> Term
-> NetlistMonad
     ([Bool], SrcSpan, HashMap Identifier Word, Component)
genComponentT Id
compName (Binding -> Term
bindingTerm Binding
b)

-- | Generate a component for a given function
genComponentT
  :: HasCallStack
  => Id
  -- ^ Name of the function
  -> Term
  -- ^ Corresponding term
  -> NetlistMonad ([Bool],SrcSpan,HashMap Identifier Word,Component)
genComponentT :: Id
-> Term
-> NetlistMonad
     ([Bool], SrcSpan, HashMap Identifier Word, Component)
genComponentT compName :: Id
compName componentExpr :: Term
componentExpr = do
  (Int -> Identity Int) -> NetlistState -> Identity NetlistState
Lens' NetlistState Int
varCount ((Int -> Identity Int) -> NetlistState -> Identity NetlistState)
-> Int -> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= 0
  Identifier
componentName1 <- (VarEnv Identifier -> Id -> Identifier
forall a b. VarEnv a -> Var b -> a
`lookupVarEnv'` Id
compName) (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
  Maybe (Maybe TopEntity)
topEntMM <- (TopEntityT -> Maybe TopEntity)
-> Maybe TopEntityT -> Maybe (Maybe TopEntity)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap TopEntityT -> Maybe TopEntity
topAnnotation (Maybe TopEntityT -> Maybe (Maybe TopEntity))
-> (VarEnv TopEntityT -> Maybe TopEntityT)
-> VarEnv TopEntityT
-> Maybe (Maybe TopEntity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> VarEnv TopEntityT -> Maybe TopEntityT
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
compName (VarEnv TopEntityT -> Maybe (Maybe TopEntity))
-> NetlistMonad (VarEnv TopEntityT)
-> NetlistMonad (Maybe (Maybe TopEntity))
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
  (Maybe Identifier, Maybe Identifier)
prefixM <- Getting
  (Maybe Identifier, Maybe Identifier)
  NetlistState
  (Maybe Identifier, Maybe Identifier)
-> NetlistMonad (Maybe Identifier, Maybe Identifier)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
  (Maybe Identifier, Maybe Identifier)
  NetlistState
  (Maybe Identifier, Maybe Identifier)
Lens' NetlistState (Maybe Identifier, Maybe Identifier)
componentPrefix
  let componentName2 :: Identifier
componentName2 = case ((Maybe Identifier, Maybe Identifier)
prefixM,Maybe (Maybe TopEntity) -> Maybe TopEntity
forall (m :: Type -> Type) a. Monad m => m (m a) -> m a
join Maybe (Maybe TopEntity)
topEntMM) of
                         ((Just p :: Identifier
p,_),Just ann :: TopEntity
ann) -> Identifier
p Identifier -> Identifier -> Identifier
`StrictText.append` String -> Identifier
StrictText.pack ('_'Char -> String -> String
forall a. a -> [a] -> [a]
:TopEntity -> String
t_name TopEntity
ann)
                         (_,Just ann :: TopEntity
ann) -> String -> Identifier
StrictText.pack (TopEntity -> String
t_name TopEntity
ann)
                         _ -> Identifier
componentName1
  SrcSpan
sp <- (Binding -> SrcSpan
bindingLoc (Binding -> SrcSpan)
-> (BindingMap -> Binding) -> BindingMap -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BindingMap -> Id -> Binding
forall a b. VarEnv a -> Var b -> a
`lookupVarEnv'` Id
compName)) (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
componentName2,SrcSpan
sp)

  TyConMap
tcm <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache

  -- HACK: Determine resulttype of this function by looking at its definition
  -- in topEntityAnns, instead of looking at its last binder (which obscures
  -- any attributes [see: Clash.Annotations.SynthesisAttributes]).
  Maybe TopEntityT
topEntityTypeM <- Id -> VarEnv TopEntityT -> Maybe TopEntityT
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
compName (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 topEntityTypeM' :: Maybe Type
topEntityTypeM' = ([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. Var a -> Type
varType (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
topEntityTypeM

  (HashMap Identifier Word -> Identity (HashMap Identifier Word))
-> NetlistState -> Identity NetlistState
Lens' NetlistState (HashMap Identifier Word)
seenIds ((HashMap Identifier Word -> Identity (HashMap Identifier Word))
 -> NetlistState -> Identity NetlistState)
-> HashMap Identifier Word -> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= HashMap Identifier Word
forall k v. HashMap k v
HashMapS.empty
  (wereVoids :: [Bool]
wereVoids,compInps :: [(Identifier, HWType)]
compInps,argWrappers :: [Declaration]
argWrappers,compOutps :: [(Identifier, HWType)]
compOutps,resUnwrappers :: [Declaration]
resUnwrappers,binders :: [LetBinding]
binders,resultM :: Maybe Id
resultM) <-
    case TyConMap -> Term -> Either String ([Id], [LetBinding], Id)
splitNormalized TyConMap
tcm Term
componentExpr of
      Right (args :: [Id]
args, binds :: [LetBinding]
binds, res :: Id
res) -> do
        let varType' :: Type
varType'   = Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe (Id -> Type
forall a. Var a -> Type
varType Id
res) Maybe Type
topEntityTypeM'
        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)
topEntMM (([Id]
args, [LetBinding]
binds, Id
res{varType :: Type
varType=Type
varType'}))
      Left err :: 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 ($curLoc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err) Maybe String
forall a. Maybe a
Nothing)

  [Declaration]
netDecls <- ([Maybe Declaration] -> [Declaration])
-> NetlistMonad [Maybe Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe Declaration] -> [Declaration]
forall a. [Maybe a] -> [a]
catMaybes (NetlistMonad [Maybe Declaration] -> NetlistMonad [Declaration])
-> ([LetBinding] -> NetlistMonad [Maybe Declaration])
-> [LetBinding]
-> NetlistMonad [Declaration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LetBinding -> NetlistMonad (Maybe Declaration))
-> [LetBinding] -> NetlistMonad [Maybe Declaration]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LetBinding -> NetlistMonad (Maybe Declaration)
mkNetDecl ([LetBinding] -> NetlistMonad [Declaration])
-> [LetBinding] -> NetlistMonad [Declaration]
forall a b. (a -> b) -> a -> b
$ (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 result :: Id
result -> do
      Just (NetDecl' _ rw :: WireOrReg
rw _ _ rIM :: Maybe Expr
rIM) <- LetBinding -> NetlistMonad (Maybe Declaration)
mkNetDecl (LetBinding -> NetlistMonad (Maybe Declaration))
-> ([LetBinding] -> LetBinding)
-> [LetBinding]
-> NetlistMonad (Maybe Declaration)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LetBinding] -> LetBinding
forall a. [a] -> a
head ([LetBinding] -> NetlistMonad (Maybe Declaration))
-> [LetBinding] -> NetlistMonad (Maybe Declaration)
forall a b. (a -> b) -> a -> b
$ (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

      let (compOutps' :: [(WireOrReg, (Identifier, HWType), Maybe Expr)]
compOutps',resUnwrappers' :: [Declaration]
resUnwrappers') = case [(Identifier, HWType)]
compOutps of
            [oport :: (Identifier, HWType)
oport] -> ([(WireOrReg
rw,(Identifier, HWType)
oport,Maybe Expr
rIM)],[Declaration]
resUnwrappers)
            _       -> let NetDecl n :: Maybe Identifier
n res :: Identifier
res resTy :: HWType
resTy = [Declaration] -> Declaration
forall a. [a] -> a
head [Declaration]
resUnwrappers
                       in  (((Identifier, HWType)
 -> (WireOrReg, (Identifier, HWType), Maybe Expr))
-> [(Identifier, HWType)]
-> [(WireOrReg, (Identifier, HWType), Maybe Expr)]
forall a b. (a -> b) -> [a] -> [b]
map (WireOrReg
Wire,,Maybe Expr
forall a. Maybe a
Nothing) [(Identifier, HWType)]
compOutps
                           ,Maybe Identifier
-> WireOrReg
-> Identifier
-> Either Identifier HWType
-> Maybe Expr
-> Declaration
NetDecl' Maybe Identifier
n WireOrReg
rw Identifier
res (HWType -> Either Identifier HWType
forall a b. b -> Either a b
Right HWType
resTy) Maybe Expr
forall a. Maybe a
NothingDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration] -> [Declaration]
forall a. [a] -> [a]
tail [Declaration]
resUnwrappers
                           )
          component :: Component
component      = Identifier
-> [(Identifier, HWType)]
-> [(WireOrReg, (Identifier, HWType), Maybe Expr)]
-> [Declaration]
-> Component
Component Identifier
componentName2 [(Identifier, HWType)]
compInps [(WireOrReg, (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')
      HashMap Identifier Word
ids <- Getting
  (HashMap Identifier Word) NetlistState (HashMap Identifier Word)
-> NetlistMonad (HashMap Identifier Word)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
  (HashMap Identifier Word) NetlistState (HashMap Identifier Word)
Lens' NetlistState (HashMap Identifier Word)
seenIds
      ([Bool], SrcSpan, HashMap Identifier Word, Component)
-> NetlistMonad
     ([Bool], SrcSpan, HashMap Identifier Word, Component)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Bool]
wereVoids, SrcSpan
sp, HashMap Identifier Word
ids, 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.
    Nothing -> do
      let component :: Component
component = Identifier
-> [(Identifier, HWType)]
-> [(WireOrReg, (Identifier, HWType), Maybe Expr)]
-> [Declaration]
-> Component
Component Identifier
componentName2 [(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)
      HashMap Identifier Word
ids <- Getting
  (HashMap Identifier Word) NetlistState (HashMap Identifier Word)
-> NetlistMonad (HashMap Identifier Word)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
  (HashMap Identifier Word) NetlistState (HashMap Identifier Word)
Lens' NetlistState (HashMap Identifier Word)
seenIds
      ([Bool], SrcSpan, HashMap Identifier Word, Component)
-> NetlistMonad
     ([Bool], SrcSpan, HashMap Identifier Word, Component)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Bool]
wereVoids, SrcSpan
sp, HashMap Identifier Word
ids, Component
component)

mkNetDecl :: (Id, Term) -> NetlistMonad (Maybe Declaration)
mkNetDecl :: LetBinding -> NetlistMonad (Maybe Declaration)
mkNetDecl (id_ :: Id
id_,tm :: Term
tm) = NetlistMonad (Maybe Declaration)
-> NetlistMonad (Maybe Declaration)
forall a. NetlistMonad a -> NetlistMonad a
preserveVarEnv (NetlistMonad (Maybe Declaration)
 -> NetlistMonad (Maybe Declaration))
-> NetlistMonad (Maybe Declaration)
-> NetlistMonad (Maybe Declaration)
forall a b. (a -> b) -> a -> b
$ do
  let typ :: Type
typ             = Id -> Type
forall a. Var a -> Type
varType Id
id_
  HWType
hwTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(curLoc) Type
typ
  WireOrReg
wr   <- Term -> NetlistMonad WireOrReg
termToWireOrReg Term
tm
  Maybe Expr
rIM  <- LetBinding -> NetlistMonad (Maybe Expr)
getResInit (Id
id_,Term
tm)
  if HWType -> Bool
isVoid HWType
hwTy
     then Maybe Declaration -> NetlistMonad (Maybe Declaration)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe Declaration
forall a. Maybe a
Nothing
     else Maybe Declaration -> NetlistMonad (Maybe Declaration)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe Declaration -> NetlistMonad (Maybe Declaration))
-> (Declaration -> Maybe Declaration)
-> Declaration
-> NetlistMonad (Maybe Declaration)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> Maybe Declaration
forall a. a -> Maybe a
Just (Declaration -> NetlistMonad (Maybe Declaration))
-> Declaration -> NetlistMonad (Maybe Declaration)
forall a b. (a -> b) -> a -> b
$ Maybe Identifier
-> WireOrReg
-> Identifier
-> Either Identifier HWType
-> Maybe Expr
-> Declaration
NetDecl' (SrcSpan -> Maybe Identifier
addSrcNote SrcSpan
sp)
             WireOrReg
wr
             (Id -> Identifier
id2identifier Id
id_)
             (HWType -> Either Identifier HWType
forall a b. b -> Either a b
Right HWType
hwTy)
             Maybe Expr
rIM

  where
    nm :: Name Term
nm = Id -> Name Term
forall a. Var a -> Name a
varName Id
id_
    sp :: SrcSpan
sp = case Term
tm of {Tick (SrcSpan s :: SrcSpan
s) _ -> SrcSpan
s; _ -> Name Term -> SrcSpan
forall a. Name a -> SrcSpan
nameLoc Name Term
nm}

    termToWireOrReg :: Term -> NetlistMonad WireOrReg
    termToWireOrReg :: Term -> NetlistMonad WireOrReg
termToWireOrReg (Term -> Term
stripTicks -> Case scrut :: Term
scrut _ alts0 :: [Alt]
alts0@(_:_:_)) = do
      TyConMap
tcm <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
      let scrutTy :: Type
scrutTy = TyConMap -> Term -> Type
termType TyConMap
tcm Term
scrut
      HWType
scrutHTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(curLoc) Type
scrutTy
      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
      case HWType -> [Alt] -> Maybe (Term, Term)
iteAlts HWType
scrutHTy [Alt]
alts0 of
        Just _ | Bool
ite -> WireOrReg -> NetlistMonad WireOrReg
forall (m :: Type -> Type) a. Monad m => a -> m a
return WireOrReg
Wire
        _ -> WireOrReg -> NetlistMonad WireOrReg
forall (m :: Type -> Type) a. Monad m => a -> m a
return WireOrReg
Reg
    termToWireOrReg (Term -> (Term, [Either Term Type])
collectArgs -> (Prim p :: PrimInfo
p,_)) = do
      Maybe GuardedCompiledPrimitive
bbM <- Identifier -> CompiledPrimMap -> Maybe GuardedCompiledPrimitive
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup (PrimInfo -> Identifier
primName PrimInfo
p) (CompiledPrimMap -> Maybe GuardedCompiledPrimitive)
-> NetlistMonad CompiledPrimMap
-> NetlistMonad (Maybe GuardedCompiledPrimitive)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting CompiledPrimMap NetlistState CompiledPrimMap
-> NetlistMonad CompiledPrimMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting CompiledPrimMap NetlistState CompiledPrimMap
Lens' NetlistState CompiledPrimMap
primitives
      case Maybe GuardedCompiledPrimitive
bbM of
        Just (GuardedCompiledPrimitive -> Maybe CompiledPrimitive
forall a. PrimitiveGuard a -> Maybe a
extractPrim -> Just BlackBox {..}) | Bool
outputReg -> WireOrReg -> NetlistMonad WireOrReg
forall (m :: Type -> Type) a. Monad m => a -> m a
return WireOrReg
Reg
        _ | PrimInfo -> Identifier
primName PrimInfo
p Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Explicit.SimIO.mealyIO" -> WireOrReg -> NetlistMonad WireOrReg
forall (m :: Type -> Type) a. Monad m => a -> m a
return WireOrReg
Reg
        _ -> WireOrReg -> NetlistMonad WireOrReg
forall (m :: Type -> Type) a. Monad m => a -> m a
return WireOrReg
Wire
    termToWireOrReg _ = WireOrReg -> NetlistMonad WireOrReg
forall (m :: Type -> Type) a. Monad m => a -> m a
return WireOrReg
Wire

    addSrcNote :: SrcSpan -> Maybe Identifier
addSrcNote loc :: SrcSpan
loc = if SrcSpan -> Bool
isGoodSrcSpan SrcSpan
loc
                        then Identifier -> Maybe Identifier
forall a. a -> Maybe a
Just (String -> Identifier
StrictText.pack (SDoc -> String
showSDocUnsafe (SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
loc)))
                        else Maybe Identifier
forall a. Maybe a
Nothing

    -- Set the initialization value of a signal when a primitive wants to set it
    getResInit
      :: (Id,Term) -> NetlistMonad (Maybe Expr)
    getResInit :: LetBinding -> NetlistMonad (Maybe Expr)
getResInit (i :: Id
i,Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks -> (k :: Term
k,args :: [Either Term Type]
args,ticks :: [TickInfo]
ticks)) = case Term
k of
      Prim p :: PrimInfo
p -> HasCallStack => Identifier -> NetlistMonad CompiledPrimitive
Identifier -> NetlistMonad CompiledPrimitive
extractPrimWarnOrFail (PrimInfo -> Identifier
primName PrimInfo
p) NetlistMonad CompiledPrimitive
-> (CompiledPrimitive -> NetlistMonad (Maybe Expr))
-> NetlistMonad (Maybe Expr)
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Identifier -> CompiledPrimitive -> NetlistMonad (Maybe Expr)
forall a c d.
Identifier -> Primitive a BlackBox c d -> NetlistMonad (Maybe Expr)
go (PrimInfo -> Identifier
primName PrimInfo
p)
      _ -> Maybe Expr -> NetlistMonad (Maybe Expr)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe Expr
forall a. Maybe a
Nothing
     where
      go :: Identifier -> Primitive a BlackBox c d -> NetlistMonad (Maybe Expr)
go pNm :: Identifier
pNm (BlackBox {resultInit :: forall a b c d. Primitive a b c d -> Maybe b
resultInit = Just nmD :: BlackBox
nmD}) = [TickInfo]
-> ([Declaration] -> NetlistMonad (Maybe Expr))
-> NetlistMonad (Maybe Expr)
forall a.
[TickInfo] -> ([Declaration] -> NetlistMonad a) -> NetlistMonad a
withTicks [TickInfo]
ticks (([Declaration] -> NetlistMonad (Maybe Expr))
 -> NetlistMonad (Maybe Expr))
-> ([Declaration] -> NetlistMonad (Maybe Expr))
-> NetlistMonad (Maybe Expr)
forall a b. (a -> b) -> a -> b
$ \_ -> do
        (bbCtx :: BlackBoxContext
bbCtx,_) <- Identifier
-> Id
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext Identifier
pNm Id
i [Either Term Type]
args
        (bbTempl :: BlackBox
bbTempl,templDecl :: [Declaration]
templDecl) <- Identifier
-> BlackBox
-> BlackBoxContext
-> NetlistMonad (BlackBox, [Declaration])
prepareBlackBox Identifier
pNm BlackBox
nmD BlackBoxContext
bbCtx
        case [Declaration]
templDecl of
          [] -> Maybe Expr -> NetlistMonad (Maybe Expr)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr -> Maybe Expr
forall a. a -> Maybe a
Just (Identifier
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Identifier, Identifier), BlackBox)]
-> BlackBox
-> BlackBoxContext
-> Bool
-> Expr
BlackBoxE Identifier
pNm [] [] [] BlackBox
bbTempl BlackBoxContext
bbCtx Bool
False))
          _  -> do
            (_,sloc :: 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 (Maybe Expr)
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sloc
                    ([String] -> String
unwords [ $(curLoc)
                             , "signal initialization requires declarations:\n"
                             , [Declaration] -> String
forall a. Show a => a -> String
show [Declaration]
templDecl
                             ])
                    Maybe String
forall a. Maybe a
Nothing)
      go _ _ = Maybe Expr -> NetlistMonad (Maybe Expr)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe Expr
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' _declType :: DeclarationType
_declType bndr :: Id
bndr (Term -> (Term, [TickInfo])
collectTicks -> (Var v :: Id
v,ticks :: [TickInfo]
ticks)) =
  [TickInfo]
-> ([Declaration] -> NetlistMonad [Declaration])
-> NetlistMonad [Declaration]
forall a.
[TickInfo] -> ([Declaration] -> NetlistMonad a) -> NetlistMonad a
withTicks [TickInfo]
ticks (([Declaration] -> NetlistMonad [Declaration])
 -> NetlistMonad [Declaration])
-> ([Declaration] -> NetlistMonad [Declaration])
-> NetlistMonad [Declaration]
forall a b. (a -> b) -> a -> b
$ \tickDecls :: [Declaration]
tickDecls -> do
  HasCallStack =>
Identifier
-> Id -> [Term] -> [Declaration] -> NetlistMonad [Declaration]
Identifier
-> Id -> [Term] -> [Declaration] -> NetlistMonad [Declaration]
mkFunApp (Id -> Identifier
id2identifier Id
bndr) Id
v [] [Declaration]
tickDecls

mkDeclarations' _declType :: DeclarationType
_declType _bndr :: Id
_bndr e :: Term
e@(Term -> (Term, [TickInfo])
collectTicks -> (Case _ _ [],_)) = do
  (_,sp :: 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 [ $(curLoc)
                    , "Not in normal form: Case-decompositions with an"
                    , "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' declType :: DeclarationType
declType bndr :: Id
bndr (Term -> (Term, [TickInfo])
collectTicks -> (Case scrut :: Term
scrut altTy :: Type
altTy alts :: [Alt]
alts@(_:_:_),ticks :: [TickInfo]
ticks)) =
  [TickInfo]
-> ([Declaration] -> NetlistMonad [Declaration])
-> NetlistMonad [Declaration]
forall a.
[TickInfo] -> ([Declaration] -> NetlistMonad a) -> NetlistMonad a
withTicks [TickInfo]
ticks (([Declaration] -> NetlistMonad [Declaration])
 -> NetlistMonad [Declaration])
-> ([Declaration] -> NetlistMonad [Declaration])
-> NetlistMonad [Declaration]
forall a b. (a -> b) -> a -> b
$ \tickDecls :: [Declaration]
tickDecls -> do
  DeclarationType
-> NetlistId
-> Term
-> Type
-> [Alt]
-> [Declaration]
-> NetlistMonad [Declaration]
mkSelection DeclarationType
declType (Id -> NetlistId
CoreId Id
bndr) Term
scrut Type
altTy [Alt]
alts [Declaration]
tickDecls

mkDeclarations' declType :: DeclarationType
declType bndr :: Id
bndr app :: Term
app = do
  let (appF :: Term
appF,args0 :: [Either Term Type]
args0,ticks :: [TickInfo]
ticks) = Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks Term
app
      (args :: [Term]
args,tyArgs :: [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 f :: 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 (Id -> Identifier
id2identifier Id
bndr) Id
f [Term]
args)
      | Bool
otherwise   -> do
        (_,sp :: 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 ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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)
    _ -> do
      (exprApp :: Expr
exprApp,declsApp0 :: [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 = Id -> Identifier
id2identifier Id
bndr
          assn :: [Declaration]
assn  =
            case Expr
exprApp of
              Identifier _ Nothing ->
                -- Supplied 'bndr' was used to assign a result to, so we
                -- don't have to manually turn it into a declaration
                []
              Noop ->
                -- Rendered expression rendered a "noop" - a list of
                -- declarations without a result. Used for things like
                -- mealy IO / inline assertions.
                []
              _ ->
                -- Turn returned expression into declaration by assigning
                -- it to 'dstId'
                [Identifier -> Expr -> Declaration
Assignment Identifier
dstId Expr
exprApp]
      [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
  -> [Alt]
  -> [Declaration]
  -> NetlistMonad [Declaration]
mkSelection :: DeclarationType
-> NetlistId
-> Term
-> Type
-> [Alt]
-> [Declaration]
-> NetlistMonad [Declaration]
mkSelection declType :: DeclarationType
declType bndr :: NetlistId
bndr scrut :: Term
scrut altTy :: Type
altTy alts0 :: [Alt]
alts0 tickDecls :: [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 Id -> Identifier
id2identifier NetlistId
bndr
  TyConMap
tcm <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
  let scrutTy :: Type
scrutTy = TyConMap -> Term -> Type
termType TyConMap
tcm Term
scrut
  HWType
scrutHTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(curLoc) Type
scrutTy
  Identifier
scrutId  <- IdType -> Identifier -> Identifier -> NetlistMonad Identifier
extendIdentifier IdType
Extended Identifier
dstId "_selection"
  (_,sp :: 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' $(curLoc) Type
altTy
  case HWType -> [Alt] -> Maybe (Term, Term)
iteAlts HWType
scrutHTy [Alt]
alts0 of
    Just (altT :: Term
altT,altF :: Term
altF)
      | Bool
ite
      , DeclarationType
Concurrent <- DeclarationType
declType
      -> do
      (scrutExpr :: Expr
scrutExpr,scrutDecls :: [Declaration]
scrutDecls) <- case HWType
scrutHTy of
        SP {} -> (Expr -> Expr) -> (Expr, [Declaration]) -> (Expr, [Declaration])
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (SrcSpan -> HWType -> Pat -> Expr -> Expr
mkScrutExpr SrcSpan
sp HWType
scrutHTy (Alt -> Pat
forall a b. (a, b) -> a
fst ([Alt] -> Alt
forall a. [a] -> a
last [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
        _ -> 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 <- IdType -> Identifier -> Identifier -> NetlistMonad Identifier
extendIdentifier IdType
Extended Identifier
dstId "_sel_alt_t"
      Identifier
altFId <- IdType -> Identifier -> Identifier -> NetlistMonad Identifier
extendIdentifier IdType
Extended Identifier
dstId "_sel_alt_f"
      (altTExpr :: Expr
altTExpr,altTDecls :: [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
      (altFExpr :: Expr
altFExpr,altFDecls :: [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
          -> [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]
++
                [Identifier -> Expr -> Declaration
Assignment Identifier
dstId (Expr -> Expr -> Expr -> Expr
IfThenElse Expr
scrutExpr Expr
altTExpr Expr
altFExpr)]
    _ -> do
      CustomReprs
reprs <- Getting CustomReprs NetlistState CustomReprs
-> NetlistMonad CustomReprs
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting CustomReprs NetlistState CustomReprs
Lens' NetlistState CustomReprs
customReprs
      let alts1 :: [Alt]
alts1 = ([Alt] -> [Alt]
reorderDefault ([Alt] -> [Alt]) -> ([Alt] -> [Alt]) -> [Alt] -> [Alt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyConMap -> CustomReprs -> Type -> [Alt] -> [Alt]
reorderCustom TyConMap
tcm CustomReprs
reprs Type
scrutTy) [Alt]
alts0
      (scrutExpr :: Expr
scrutExpr,scrutDecls :: [Declaration]
scrutDecls) <- (Expr -> Expr) -> (Expr, [Declaration]) -> (Expr, [Declaration])
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (SrcSpan -> HWType -> Pat -> Expr -> Expr
mkScrutExpr SrcSpan
sp HWType
scrutHTy (Alt -> Pat
forall a b. (a, b) -> a
fst ([Alt] -> Alt
forall a. [a] -> a
head [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
      (exprs :: [(Maybe Literal, Expr)]
exprs,altsDecls :: [[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) [Alt]
alts1
      case DeclarationType
declType of
        Sequential -> do
          -- Assign to the result in every branch
          let (altNets :: [[Declaration]]
altNets,exprAlts :: [(Maybe Literal, [Seq])]
exprAlts) = [([Declaration], (Maybe Literal, [Seq]))]
-> ([[Declaration]], [(Maybe Literal, [Seq])])
forall a b. [(a, b)] -> ([a], [b])
unzip (((Maybe Literal, Expr)
 -> [Declaration] -> ([Declaration], (Maybe Literal, [Seq])))
-> [(Maybe Literal, Expr)]
-> [[Declaration]]
-> [([Declaration], (Maybe Literal, [Seq]))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Identifier
-> (Maybe Literal, Expr)
-> [Declaration]
-> ([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]]
        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
              -> [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]
++ [Identifier
-> HWType
-> Expr
-> HWType
-> [(Maybe Literal, Expr)]
-> Declaration
CondAssignment Identifier
dstId HWType
altHTy Expr
scrutExpr HWType
scrutHTy [(Maybe Literal, Expr)]
exprs]
 where
  mkCondExpr :: HWType -> (Pat,Term) -> NetlistMonad ((Maybe HW.Literal,Expr),[Declaration])
  mkCondExpr :: HWType
-> Alt -> NetlistMonad ((Maybe Literal, Expr), [Declaration])
mkCondExpr scrutHTy :: HWType
scrutHTy (pat :: Pat
pat,alt :: Term
alt) = do
    Identifier
altId <- IdType -> Identifier -> Identifier -> NetlistMonad Identifier
extendIdentifier IdType
Extended
               ((Identifier -> Identifier)
-> (Id -> Identifier) -> NetlistId -> Identifier
forall r.
HasCallStack =>
(Identifier -> r) -> (Id -> r) -> NetlistId -> r
netlistId1 Identifier -> Identifier
forall a. a -> a
id Id -> Identifier
id2identifier NetlistId
bndr)
               "_sel_alt"
    (altExpr :: Expr
altExpr,altDecls :: [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
      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 dc :: DataCon
dc _ _ -> (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 i :: 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 i :: 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 w :: 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 c :: 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 i :: 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 w :: 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  (NaturalLiteral n :: 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)
      _  -> do
        (_,sp :: 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 ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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 sp :: SrcSpan
sp scrutHTy :: HWType
scrutHTy pat :: Pat
pat scrutE :: Expr
scrutE = case Pat
pat of
    DataPat dc :: DataCon
dc _ _ -> 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
- 1))
                      in case Expr
scrutE of
                          Identifier scrutId :: Identifier
scrutId Nothing -> Identifier -> Maybe Modifier -> Expr
Identifier Identifier
scrutId Maybe Modifier
modifier
                          _ -> ClashException -> Expr
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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)
    _ -> Expr
scrutE

  altAssign :: Identifier -> (Maybe HW.Literal,Expr) -> [Declaration]
            -> ([Declaration],(Maybe HW.Literal,[Seq]))
  altAssign :: Identifier
-> (Maybe Literal, Expr)
-> [Declaration]
-> ([Declaration], (Maybe Literal, [Seq]))
altAssign i :: Identifier
i (m :: Maybe Literal
m,expr :: Expr
expr) ds :: [Declaration]
ds =
    let (nets :: [Declaration]
nets,rest :: [Declaration]
rest) = (Declaration -> Bool)
-> [Declaration] -> ([Declaration], [Declaration])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Declaration -> Bool
isNet [Declaration]
ds
        assn :: [Seq]
assn = case Expr
expr of { Noop -> []; _ -> [Declaration -> Seq
SeqDecl (Identifier -> Expr -> Declaration
Assignment Identifier
i Expr
expr)] }
    in  ([Declaration]
nets,(Maybe Literal
m,(Declaration -> Seq) -> [Declaration] -> [Seq]
forall a b. (a -> b) -> [a] -> [b]
map Declaration -> Seq
SeqDecl [Declaration]
rest [Seq] -> [Seq] -> [Seq]
forall a. [a] -> [a] -> [a]
++ [Seq]
assn))
   where
    isNet :: Declaration -> Bool
isNet NetDecl' {} = Bool
True
    isNet _ = Bool
False

-- GHC puts default patterns in the first position, we want them in the
-- last position.
reorderDefault
  :: [(Pat, Term)]
  -> [(Pat, Term)]
reorderDefault :: [Alt] -> [Alt]
reorderDefault ((DefaultPat,e :: Term
e):alts' :: [Alt]
alts') = [Alt]
alts' [Alt] -> [Alt] -> [Alt]
forall a. [a] -> [a] -> [a]
++ [(Pat
DefaultPat,Term
e)]
reorderDefault alts' :: [Alt]
alts'                  = [Alt]
alts'

reorderCustom
  :: TyConMap
  -> CustomReprs
  -> Type
  -> [(Pat, Term)]
  -> [(Pat, Term)]
reorderCustom :: TyConMap -> CustomReprs -> Type -> [Alt] -> [Alt]
reorderCustom tcm :: TyConMap
tcm reprs :: CustomReprs
reprs (TyConMap -> Type -> Maybe Type
coreView1 TyConMap
tcm -> Just ty :: Type
ty) alts :: [Alt]
alts =
  TyConMap -> CustomReprs -> Type -> [Alt] -> [Alt]
reorderCustom TyConMap
tcm CustomReprs
reprs Type
ty [Alt]
alts
reorderCustom _tcm :: TyConMap
_tcm reprs :: CustomReprs
reprs (Type -> Either String Type'
coreToType' -> Right typeName :: Type'
typeName) alts :: [Alt]
alts =
  case Type' -> CustomReprs -> Maybe DataRepr'
getDataRepr Type'
typeName CustomReprs
reprs of
    Just (DataRepr' _name :: Type'
_name _size :: Int
_size _constrReprs :: [ConstrRepr']
_constrReprs) ->
      (Alt -> Int) -> [Alt] -> [Alt]
forall b a. Ord b => (a -> b) -> [a] -> [a]
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) [Alt]
alts
    Nothing ->
      [Alt]
alts
reorderCustom _tcm :: TyConMap
_tcm _reprs :: CustomReprs
_reprs _type :: Type
_type alts :: [Alt]
alts =
  [Alt]
alts

patPos
  :: CustomReprs
  -> Pat
  -> Int
patPos :: CustomReprs -> Pat -> Int
patPos _reprs :: CustomReprs
_reprs DefaultPat = -1
patPos _reprs :: CustomReprs
_reprs (LitPat _) = 0
patPos reprs :: CustomReprs
reprs pat :: Pat
pat@(DataPat dataCon :: DataCon
dataCon _ _) =
  -- We sort data patterns by their syntactical order
  let name :: Identifier
name = Name DataCon -> Identifier
forall a. Name a -> Identifier
nameOcc (Name DataCon -> Identifier) -> Name DataCon -> Identifier
forall a b. (a -> b) -> a -> b
$ DataCon -> Name DataCon
dcName DataCon
dataCon in
  case Identifier -> CustomReprs -> Maybe ConstrRepr'
getConstrRepr Identifier
name CustomReprs
reprs of
    Nothing ->
      -- TODO: err
      String -> Int
forall a. HasCallStack => String -> a
error (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Pat -> String
forall a. Show a => a -> String
show Pat
pat)
    Just (ConstrRepr' _name :: Identifier
_name n :: Int
n _mask :: Integer
_mask _value :: Integer
_value _anns :: [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 dstId :: Identifier
dstId fun :: Id
fun args :: [Term]
args tickDecls :: [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 NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
  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
    (True, Just topEntity :: TopEntityT
topEntity)
      | let ty :: Type
ty = Id -> Type
forall a. Var a -> Type
varType (TopEntityT -> Id
topId TopEntityT
topEntity)
      , let (fArgTys0 :: [Either TyVar Type]
fArgTys0,fResTy :: 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
        let annM :: Maybe TopEntity
annM = TopEntityT -> Maybe TopEntity
topAnnotation TopEntityT
topEntity
        [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' $(curLoc)) [Type]
fArgTys1
        (argExprs :: [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 (\(e :: Term
e,t :: 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 :: [(HWType, Expr)]
filteredTypeExprs = ((HWType, Expr) -> Bool) -> [(HWType, Expr)] -> [(HWType, Expr)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((HWType, Expr) -> Bool) -> (HWType, Expr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HWType -> Bool
isVoid (HWType -> Bool)
-> ((HWType, Expr) -> HWType) -> (HWType, Expr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HWType, Expr) -> HWType
forall a b. (a, b) -> a
fst) ([HWType] -> [Expr] -> [(HWType, Expr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [HWType]
argHWTys [Expr]
argExprs)
          (hWTysFiltered :: [HWType]
hWTysFiltered, argExprsFiltered :: [Expr]
argExprsFiltered) = [(HWType, Expr)] -> ([HWType], [Expr])
forall a b. [(a, b)] -> ([a], [b])
unzip [(HWType, Expr)]
filteredTypeExprs

        HWType
dstHWty  <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(curLoc) Type
fResTy
        String
env  <- Getting String NetlistState String -> NetlistMonad String
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting String NetlistState String
Lens' NetlistState String
hdlDir
        IdType -> Identifier -> Identifier
mkId <- Getting
  (IdType -> Identifier -> Identifier)
  NetlistState
  (IdType -> Identifier -> Identifier)
-> NetlistMonad (IdType -> Identifier -> Identifier)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
  (IdType -> Identifier -> Identifier)
  NetlistState
  (IdType -> Identifier -> Identifier)
Lens' NetlistState (IdType -> Identifier -> Identifier)
mkIdentifierFn
        (Maybe Identifier, Maybe Identifier)
prefixM <- Getting
  (Maybe Identifier, Maybe Identifier)
  NetlistState
  (Maybe Identifier, Maybe Identifier)
-> NetlistMonad (Maybe Identifier, Maybe Identifier)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
  (Maybe Identifier, Maybe Identifier)
  NetlistState
  (Maybe Identifier, Maybe Identifier)
Lens' NetlistState (Maybe Identifier, Maybe Identifier)
componentPrefix
        Bool
newInlineStrat <- ClashOpts -> Bool
opt_newInlineStrat (ClashOpts -> Bool) -> NetlistMonad ClashOpts -> NetlistMonad Bool
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting ClashOpts NetlistState ClashOpts -> NetlistMonad ClashOpts
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting ClashOpts NetlistState ClashOpts
Lens' NetlistState ClashOpts
clashOpts
        let topName :: String
topName = Identifier -> String
StrictText.unpack
                      (Bool
-> (IdType -> Identifier -> Identifier)
-> (Maybe Identifier, Maybe Identifier)
-> Maybe TopEntity
-> Id
-> Identifier
genTopComponentName Bool
newInlineStrat IdType -> Identifier -> Identifier
mkId (Maybe Identifier, Maybe Identifier)
prefixM Maybe TopEntity
annM Id
fun)
            modName :: String
modName = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '.')
                                (Identifier -> String
StrictText.unpack (Name Term -> Identifier
forall a. Name a -> Identifier
nameOcc (Id -> Name Term
forall a. Var a -> Name a
varName Id
fun)))
        String
manFile <- case Maybe TopEntity
annM of
          Just _  -> String -> NetlistMonad String
forall (m :: Type -> Type) a. Monad m => a -> m a
return (String
env String -> String -> String
</> ".." String -> String -> String
</> String
modName String -> String -> String
</> String
topName String -> String -> String
</> String
topName String -> String -> String
<.> "manifest")
          Nothing -> String -> NetlistMonad String
forall (m :: Type -> Type) a. Monad m => a -> m a
return (String
env String -> String -> String
</> String
topName String -> String -> String
<.> "manifest")
        Just man :: Manifest
man <- String -> Maybe Manifest
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Manifest)
-> NetlistMonad String -> NetlistMonad (Maybe Manifest)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String -> NetlistMonad String
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (String -> IO String
readFile String
manFile)
        [Declaration]
instDecls <- Id
-> Maybe TopEntity
-> Manifest
-> (Identifier, HWType)
-> [(Expr, HWType)]
-> [Declaration]
-> NetlistMonad [Declaration]
mkTopUnWrapper Id
fun Maybe TopEntity
annM Manifest
man (Identifier
dstId,HWType
dstHWty)
                       ([Expr] -> [HWType] -> [(Expr, HWType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Expr]
argExprsFiltered [HWType]
hWTysFiltered)
                       [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
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "under-applied TopEntity: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Id -> String
forall p. PrettyPrec p => p -> String
showPpr Id
fun
    (True, 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
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
fun BindingMap
normalized of
        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 :: Binding -> Term
bindingTerm}) -> do
          (_,_,_,Component compName :: Identifier
compName compInps :: [(Identifier, HWType)]
compInps co :: [(WireOrReg, (Identifier, HWType), Maybe Expr)]
co _) <- NetlistMonad ([Bool], SrcSpan, HashMap Identifier Word, Component)
-> NetlistMonad
     ([Bool], SrcSpan, HashMap Identifier Word, Component)
forall a. NetlistMonad a -> NetlistMonad a
preserveVarEnv (NetlistMonad ([Bool], SrcSpan, HashMap Identifier Word, Component)
 -> NetlistMonad
      ([Bool], SrcSpan, HashMap Identifier Word, Component))
-> NetlistMonad
     ([Bool], SrcSpan, HashMap Identifier Word, Component)
-> NetlistMonad
     ([Bool], SrcSpan, HashMap Identifier Word, Component)
forall a b. (a -> b) -> a -> b
$ HasCallStack =>
Id
-> NetlistMonad
     ([Bool], SrcSpan, HashMap Identifier Word, Component)
Id
-> NetlistMonad
     ([Bool], SrcSpan, HashMap Identifier Word, Component)
genComponent Id
fun
          let argTys :: [Type]
argTys = (Term -> Type) -> [Term] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (TyConMap -> Term -> Type
termType 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

          (argExprs :: [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 (\(e :: Term
e,t :: 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, (Type, Expr))]
argTypeExprs = [Maybe HWType] -> [(Type, Expr)] -> [(Maybe HWType, (Type, Expr))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe HWType]
argHWTys ([Type] -> [Expr] -> [(Type, Expr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
argTys [Expr]
argExprs)
            filteredTypeExprs :: [(Type, Expr)]
filteredTypeExprs = (Maybe HWType -> Bool)
-> [(Maybe HWType, (Type, Expr))] -> [(Type, Expr)]
forall a b. (a -> Bool) -> [(a, b)] -> [b]
filterOnFst (Bool -> Bool
not (Bool -> Bool) -> (Maybe HWType -> Bool) -> Maybe HWType -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Maybe HWType -> Bool
isVoidMaybe Bool
True) [(Maybe HWType, (Type, Expr))]
argTypeExprs
            (argTysFiltered :: [Type]
argTysFiltered, argsFiltered :: [Expr]
argsFiltered) = [(Type, Expr)] -> ([Type], [Expr])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Type, Expr)]
filteredTypeExprs

          let compOutp :: Maybe (Identifier, HWType)
compOutp = (\(_,x :: (Identifier, HWType)
x,_) -> (Identifier, HWType)
x) ((WireOrReg, (Identifier, HWType), Maybe Expr)
 -> (Identifier, HWType))
-> Maybe (WireOrReg, (Identifier, HWType), Maybe Expr)
-> Maybe (Identifier, HWType)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(WireOrReg, (Identifier, HWType), Maybe Expr)]
-> Maybe (WireOrReg, (Identifier, HWType), Maybe Expr)
forall a. [a] -> Maybe a
listToMaybe [(WireOrReg, (Identifier, HWType), Maybe Expr)]
co
          if [Type] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Type]
argTysFiltered 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
              (argExprs' :: [Expr]
argExprs',argDecls' :: [Declaration]
argDecls') <- (([[Declaration]] -> [Declaration])
-> ([Expr], [[Declaration]]) -> ([Expr], [Declaration])
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, 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] -> [(Expr, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Expr]
argsFiltered [Type]
argTysFiltered)
              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 (\(i :: Identifier
i,t :: HWType
t) e :: 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
                    Nothing -> []
                    Just (id_ :: Identifier
id_,hwtype :: 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)]
              Identifier
instLabel0 <- IdType -> Identifier -> Identifier -> NetlistMonad Identifier
extendIdentifier IdType
Basic Identifier
compName (String -> Identifier
StrictText.pack "_" Identifier -> Identifier -> Identifier
`StrictText.append` Identifier
dstId)
              Identifier
instLabel1 <- Identifier -> Maybe Identifier -> Identifier
forall a. a -> Maybe a -> a
fromMaybe Identifier
instLabel0 (Maybe Identifier -> Identifier)
-> NetlistMonad (Maybe Identifier) -> NetlistMonad Identifier
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Maybe Identifier) NetlistEnv (Maybe Identifier)
-> NetlistMonad (Maybe Identifier)
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting (Maybe Identifier) NetlistEnv (Maybe Identifier)
Lens' NetlistEnv (Maybe Identifier)
setName
              Identifier
instLabel2 <- Identifier -> NetlistMonad Identifier
affixName Identifier
instLabel1
              Identifier
instLabel3 <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Basic Identifier
instLabel2
              let instDecl :: Declaration
instDecl = EntityOrComponent
-> Maybe Identifier
-> Identifier
-> Identifier
-> [(Expr, HWType, Expr)]
-> [(Expr, PortDirection, HWType, Expr)]
-> Declaration
InstDecl EntityOrComponent
Entity Maybe Identifier
forall a. Maybe a
Nothing Identifier
compName Identifier
instLabel3 [] ([(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)
              [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 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}
            |]
    _ ->
      case [Term]
args of
        [] ->
          -- TODO: Figure out what to do with zero-width constructs
          [Declaration] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [Identifier -> Expr -> Declaration
Assignment Identifier
dstId (Identifier -> Maybe Modifier -> Expr
Identifier (Name Term -> Identifier
forall a. Name a -> Identifier
nameOcc (Name Term -> Identifier) -> Name Term -> Identifier
forall a b. (a -> b) -> a -> b
$ Id -> Name Term
forall a. Var a -> Name a
varName Id
fun) Maybe Modifier
forall a. Maybe a
Nothing)]
        _ -> 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 _ (e :: Expr
e@(Identifier _ _),_) = (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
e,[])
toSimpleVar dstId :: Identifier
dstId (e :: Expr
e,ty :: Type
ty) = do
  Identifier
argNm <- IdType -> Identifier -> Identifier -> NetlistMonad Identifier
extendIdentifier IdType
Extended
             Identifier
dstId
             "_fun_arg"
  Identifier
argNm' <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Extended Identifier
argNm
  HWType
hTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(curLoc) Type
ty
  let argDecl :: Declaration
argDecl         = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
argNm' HWType
hTy
      argAssn :: Declaration
argAssn         = Identifier -> Expr -> Declaration
Assignment Identifier
argNm' 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,Declaration
argAssn])

-- | 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 -- ^ Id to 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 _ _ _ (Term -> Term
stripTicks -> Core.Literal l :: Literal
l) = do
  Int
iw <- Getting Int NetlistState Int -> NetlistMonad Int
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting Int NetlistState Int
Lens' NetlistState Int
intWidth
  case Literal
l of
    IntegerLiteral i :: Integer
i -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (HWType, Int) -> Literal -> Expr
HW.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
Signed Int
iw,Int
iw)) (Literal -> Expr) -> Literal -> Expr
forall a b. (a -> b) -> a -> b
$ Integer -> Literal
NumLit Integer
i, [])
    IntLiteral i :: Integer
i     -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (HWType, Int) -> Literal -> Expr
HW.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
Signed Int
iw,Int
iw)) (Literal -> Expr) -> Literal -> Expr
forall a b. (a -> b) -> a -> b
$ Integer -> Literal
NumLit Integer
i, [])
    WordLiteral w :: Integer
w    -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (HWType, Int) -> Literal -> Expr
HW.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
Unsigned Int
iw,Int
iw)) (Literal -> Expr) -> Literal -> Expr
forall a b. (a -> b) -> a -> b
$ Integer -> Literal
NumLit Integer
w, [])
    Int64Literal i :: Integer
i   -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (HWType, Int) -> Literal -> Expr
HW.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
Signed 64,64)) (Literal -> Expr) -> Literal -> Expr
forall a b. (a -> b) -> a -> b
$ Integer -> Literal
NumLit Integer
i, [])
    Word64Literal w :: Integer
w  -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (HWType, Int) -> Literal -> Expr
HW.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
Unsigned 64,64)) (Literal -> Expr) -> Literal -> Expr
forall a b. (a -> b) -> a -> b
$ Integer -> Literal
NumLit Integer
w, [])
    CharLiteral c :: Char
c    -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (HWType, Int) -> Literal -> Expr
HW.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
Unsigned 21,21)) (Literal -> Expr) -> (Int -> Literal) -> Int -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> Expr) -> Int -> Expr
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c, [])
    FloatLiteral r :: Rational
r   -> let f :: Float
f = Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
r :: Float
                            i :: Integer
i = Word32 -> Integer
forall a. Integral a => a -> Integer
toInteger (Float -> Word32
floatToWord Float
f)
                        in  (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (HWType, Int) -> Literal -> Expr
HW.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
BitVector 32,32)) (Integer -> Literal
NumLit Integer
i), [])
    DoubleLiteral r :: Rational
r  -> let d :: Double
d = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
r :: Double
                            i :: Integer
i = Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Double -> Word64
doubleToWord Double
d)
                        in  (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (HWType, Int) -> Literal -> Expr
HW.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
BitVector 64,64)) (Integer -> Literal
NumLit Integer
i), [])
    NaturalLiteral n :: Integer
n -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (HWType, Int) -> Literal -> Expr
HW.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
Unsigned Int
iw,Int
iw)) (Literal -> Expr) -> Literal -> Expr
forall a b. (a -> b) -> a -> b
$ Integer -> Literal
NumLit Integer
n, [])
    ByteArrayLiteral (PV.Vector _ _ (ByteArray ba :: ByteArray#
ba)) -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (HWType, Int) -> Literal -> Expr
HW.Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (Integer -> Literal
NumLit (BigNat -> Integer
Jp# (ByteArray# -> BigNat
BN# ByteArray#
ba))),[])
    _ -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error (String -> NetlistMonad (Expr, [Declaration]))
-> String -> NetlistMonad (Expr, [Declaration])
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "not an integer or char literal"

mkExpr bbEasD :: Bool
bbEasD declType :: DeclarationType
declType bndr :: NetlistId
bndr app :: Term
app =
 let (appF :: Term
appF,args :: [Either Term Type]
args,ticks :: [TickInfo]
ticks) = Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks Term
app
     (tmArgs :: [Term]
tmArgs,tyArgs :: [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
$ \tickDecls :: [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' $(curLoc)) (NetlistId -> [Type]
netlistTypes NetlistId
bndr)
  (_,sp :: 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 = [HWType] -> HWType
forall a. [a] -> a
head [HWType]
hwTys
  case Term
appF of
    Data dc :: DataCon
dc -> HasCallStack =>
[HWType]
-> NetlistId
-> DataCon
-> [Term]
-> NetlistMonad (Expr, [Declaration])
[HWType]
-> NetlistId
-> DataCon
-> [Term]
-> NetlistMonad (Expr, [Declaration])
mkDcApplication [HWType]
hwTys NetlistId
bndr DataCon
dc [Term]
tmArgs
    Prim pInfo :: PrimInfo
pInfo -> Bool
-> Bool
-> NetlistId
-> PrimInfo
-> [Either Term Type]
-> [Declaration]
-> NetlistMonad (Expr, [Declaration])
mkPrimitive Bool
False Bool
bbEasD NetlistId
bndr PrimInfo
pInfo [Either Term Type]
args [Declaration]
tickDecls
    Var f :: 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
            (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Identifier -> Maybe Modifier -> Expr
Identifier (Name Term -> Identifier
forall a. Name a -> Identifier
nameOcc (Name Term -> Identifier) -> Name Term -> Identifier
forall a b. (a -> b) -> a -> b
$ Id -> Name Term
forall a. Var a -> Name a
varName 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 ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Not in normal form: "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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
argNm0 <- IdType -> Identifier -> Identifier -> NetlistMonad Identifier
extendIdentifier IdType
Extended ((Identifier -> Identifier)
-> (Id -> Identifier) -> NetlistId -> Identifier
forall r.
HasCallStack =>
(Identifier -> r) -> (Id -> r) -> NetlistId -> r
netlistId1 Identifier -> Identifier
forall a. a -> a
id Id -> Identifier
id2identifier NetlistId
bndr)
                                     "_fun_arg"
          Identifier
argNm1 <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Extended Identifier
argNm0
          [Declaration]
decls  <- HasCallStack =>
Identifier
-> Id -> [Term] -> [Declaration] -> NetlistMonad [Declaration]
Identifier
-> Id -> [Term] -> [Declaration] -> NetlistMonad [Declaration]
mkFunApp Identifier
argNm1 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
            (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ( Identifier -> Maybe Modifier -> Expr
Identifier Identifier
argNm1 Maybe Modifier
forall a. Maybe a
Nothing
                   , Maybe Identifier
-> WireOrReg
-> Identifier
-> Either Identifier HWType
-> Maybe Expr
-> Declaration
NetDecl' Maybe Identifier
forall a. Maybe a
Nothing WireOrReg
Wire Identifier
argNm1 (HWType -> Either Identifier HWType
forall a b. b -> Either a b
Right HWType
hwTyA) Maybe Expr
forall a. Maybe a
NothingDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
decls)
    Case scrut :: Term
scrut ty' :: Type
ty' [alt :: Alt
alt] -> Bool
-> NetlistId
-> Term
-> Type
-> Alt
-> NetlistMonad (Expr, [Declaration])
mkProjection Bool
bbEasD NetlistId
bndr Term
scrut Type
ty' Alt
alt
    Case scrut :: Term
scrut tyA :: Type
tyA alts :: [Alt]
alts -> do
      TyConMap
tcm <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
      let scrutTy :: Type
scrutTy = TyConMap -> Term -> Type
termType TyConMap
tcm Term
scrut
      HWType
scrutHTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(curLoc) Type
scrutTy
      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
      let wr :: WireOrReg
wr = case HWType -> [Alt] -> Maybe (Term, Term)
iteAlts HWType
scrutHTy [Alt]
alts of
                 Just _ | Bool
ite -> WireOrReg
Wire
                 _ -> WireOrReg
Reg
      Identifier
argNm0 <- IdType -> Identifier -> Identifier -> NetlistMonad Identifier
extendIdentifier IdType
Extended ((Identifier -> Identifier)
-> (Id -> Identifier) -> NetlistId -> Identifier
forall r.
HasCallStack =>
(Identifier -> r) -> (Id -> r) -> NetlistId -> r
netlistId1 Identifier -> Identifier
forall a. a -> a
id Id -> Identifier
id2identifier NetlistId
bndr) "_sel_arg"
      Identifier
argNm1 <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Extended Identifier
argNm0
      [Declaration]
decls  <- DeclarationType
-> NetlistId
-> Term
-> Type
-> [Alt]
-> [Declaration]
-> NetlistMonad [Declaration]
mkSelection DeclarationType
declType (Identifier -> Type -> NetlistId
NetlistId Identifier
argNm1 (HasCallStack => NetlistId -> Type
NetlistId -> Type
netlistTypes1 NetlistId
bndr))
                            Term
scrut Type
tyA [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
        (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ( Identifier -> Maybe Modifier -> Expr
Identifier Identifier
argNm1 Maybe Modifier
forall a. Maybe a
Nothing
               , Maybe Identifier
-> WireOrReg
-> Identifier
-> Either Identifier HWType
-> Maybe Expr
-> Declaration
NetDecl' Maybe Identifier
forall a. Maybe a
Nothing WireOrReg
wr Identifier
argNm1 (HWType -> Either Identifier HWType
forall a b. b -> Either a b
Right HWType
hwTyA) Maybe Expr
forall a. Maybe a
NothingDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
decls)
    Letrec binders :: [LetBinding]
binders body :: Term
body -> do
      [Declaration]
netDecls <- ([Maybe Declaration] -> [Declaration])
-> NetlistMonad [Maybe Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe Declaration] -> [Declaration]
forall a. [Maybe a] -> [a]
catMaybes (NetlistMonad [Maybe Declaration] -> NetlistMonad [Declaration])
-> NetlistMonad [Maybe Declaration] -> NetlistMonad [Declaration]
forall a b. (a -> b) -> a -> b
$ (LetBinding -> NetlistMonad (Maybe Declaration))
-> [LetBinding] -> NetlistMonad [Maybe Declaration]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LetBinding -> NetlistMonad (Maybe Declaration)
mkNetDecl [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
      (bodyE :: Expr
bodyE,bodyDecls :: [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)
    _ -> ClashException -> NetlistMonad (Expr, [Declaration])
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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
  -- ^ 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 mkDec :: Bool
mkDec bndr :: NetlistId
bndr scrut :: Term
scrut altTy :: Type
altTy alt :: Alt
alt@(pat :: Pat
pat,v :: Term
v) = do
  TyConMap
tcm <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
  let scrutTy :: Type
scrutTy = TyConMap -> Term -> Type
termType TyConMap
tcm Term
scrut
      e :: Term
e = Term -> Type -> [Alt] -> Term
Case Term
scrut Type
scrutTy [Alt
alt]
  (_,sp :: 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 n :: Id
n) -> Id -> NetlistMonad Id
forall (m :: Type -> Type) a. Monad m => a -> m a
return Id
n
    _ -> ClashException -> NetlistMonad Id
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                "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' $(curLoc) Type
scrutTy
  HWType
vHwTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(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) a. Monad m => a -> m a
return
        (\b :: Id
b -> IdType -> Identifier -> Identifier -> NetlistMonad Identifier
extendIdentifier IdType
Extended (Id -> Identifier
id2identifier Id
b) "_projection")
        NetlistId
bndr
    (scrutExpr :: Expr
scrutExpr,newDecls :: [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 newId :: Identifier
newId modM :: 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))
      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)
      _ -> do
        Identifier
scrutNm' <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Extended Identifier
scrutNm
        let scrutDecl :: Declaration
scrutDecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
scrutNm' HWType
sHwTy
            scrutAssn :: Declaration
scrutAssn = Identifier -> Expr -> Declaration
Assignment Identifier
scrutNm' 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, Declaration
scrutAssn]))

  case Either [Declaration] (Identifier, Maybe Modifier, [Declaration])
scrutRendered of
    Left newDecls :: [Declaration]
newDecls -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Expr
Noop, [Declaration]
newDecls)
    Right (selId :: Identifier
selId, modM :: Maybe Modifier
modM, decls :: [Declaration]
decls) -> do
      let altVarId :: Identifier
altVarId = Name Term -> Identifier
forall a. Name a -> Identifier
nameOcc (Id -> Name Term
forall a. Var a -> Name a
varName Id
varTm)
      Maybe Modifier
modifier <- case Pat
pat of
        DataPat dc :: DataCon
dc exts :: [TyVar]
exts tms :: [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 ($(curLoc)
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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. Var a -> Type
varType [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
            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 fI :: 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
- 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,0)))
        _ -> ClashException -> NetlistMonad (Maybe Modifier)
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp ($(curLoc)
               String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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 scrutNm :: Identifier
scrutNm _ | Bool
mkDec -> do
          Identifier
scrutNm' <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Extended Identifier
scrutNm
          let scrutDecl :: Declaration
scrutDecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
scrutNm' HWType
vHwTy
              scrutAssn :: Declaration
scrutAssn = Identifier -> Expr -> Declaration
Assignment Identifier
scrutNm' 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
scrutDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:Declaration
scrutAssnDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
decls)
        MultiId {} -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error "mkProjection: MultiId"
        _ -> (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 Nothing  m :: Maybe Modifier
m          = Maybe Modifier
m
    nestModifier m :: Maybe Modifier
m Nothing           = Maybe Modifier
m
    nestModifier (Just m1 :: Modifier
m1) (Just m2 :: 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
    => [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
    -- ^ Id to assign the result to
    -> DataCon
    -- ^ Applied DataCon
    -> [Term]
    -- ^ DataCon Arguments
    -> NetlistMonad (Expr,[Declaration])
    -- ^ Returned expression and a list of generate BlackBox declarations
mkDcApplication :: [HWType]
-> NetlistId
-> DataCon
-> [Term]
-> NetlistMonad (Expr, [Declaration])
mkDcApplication [dstHType :: HWType
dstHType] bndr :: NetlistId
bndr dc :: DataCon
dc args :: [Term]
args = do
  let dcNm :: Identifier
dcNm = Name DataCon -> Identifier
forall a. Name a -> Identifier
nameOcc (DataCon -> Name DataCon
dcName DataCon
dc)
  TyConMap
tcm <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
  let argTys :: [Type]
argTys = (Term -> Type) -> [Term] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (TyConMap -> Term -> Type
termType 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 (\b :: Id
b -> IdType -> Identifier -> Identifier -> NetlistMonad Identifier
extendIdentifier IdType
Extended (Name Term -> Identifier
forall a. Name a -> Identifier
nameOcc (Id -> Name Term
forall a. Var a -> Name a
varName Id
b)) "_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

  (argExprs :: [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 (\(e :: Term
e,t :: 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
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)

    (hWTysFiltered :: [Maybe HWType]
hWTysFiltered, argExprsFiltered :: [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 argHwTy :: HWType
argHwTy],[argExpr :: 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,-1)) [Expr
argExpr])
    _ -> case HWType
dstHType of
      SP _ dcArgPairs :: [(Identifier, [HWType])]
dcArgPairs -> do
        let dcI :: Int
dcI      = DataCon -> Int
dcTag DataCon
dc Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
            dcArgs :: [HWType]
dcArgs   = (Identifier, [HWType]) -> [HWType]
forall a b. (a, b) -> b
snd ((Identifier, [HWType]) -> [HWType])
-> (Identifier, [HWType]) -> [HWType]
forall a b. (a -> b) -> a -> b
$ String -> [(Identifier, [HWType])] -> Int -> (Identifier, [HWType])
forall a. HasCallStack => String -> [a] -> Int -> a
indexNote ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "No DC with tag: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
dcI) [(Identifier, [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
          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)
          LT -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Over-applied constructor"
          GT -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Under-applied constructor"
      Product _ _ dcArgs :: [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
          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,0)) [Expr]
argExprsFiltered)
          LT -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Over-applied constructor"
          GT -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Under-applied constructor"
      CustomProduct _ _ _ _ dcArgs :: [(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
          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,0)) [Expr]
argExprsFiltered)
          LT -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Over-applied constructor"
          GT -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Under-applied constructor"
      Sum _ _ ->
        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
- 1)) [])
      CustomSP _ _ _ dcArgsTups :: [(ConstrRepr', Identifier, [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
- 1
        let note :: String
note   = $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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', Identifier, [HWType])
argTup = String
-> [(ConstrRepr', Identifier, [HWType])]
-> Int
-> (ConstrRepr', Identifier, [HWType])
forall a. HasCallStack => String -> [a] -> Int -> a
indexNote String
note [(ConstrRepr', Identifier, [HWType])]
dcArgsTups Int
dcI
        let (_, _, dcArgs :: [HWType]
dcArgs) = (ConstrRepr', Identifier, [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
          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)
          LT -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Over-applied constructor"
          GT -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Under-applied constructor"

      CustomSum _ _ _ _ ->
        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
- 1)) [])
      Bool ->
        let dc' :: Expr
dc' = case DataCon -> Int
dcTag DataCon
dc of
                   1  -> Maybe (HWType, Int) -> Literal -> Expr
HW.Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (Bool -> Literal
BoolLit Bool
False)
                   2  -> Maybe (HWType, Int) -> Literal -> Expr
HW.Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (Bool -> Literal
BoolLit Bool
True)
                   tg :: Int
tg -> String -> Expr
forall a. HasCallStack => String -> a
error (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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]
++ "(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]
++ ")"
        in  Expr -> NetlistMonad Expr
forall (m :: Type -> Type) a. Monad m => a -> m a
return Expr
dc'
      Vector 0 _ -> 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 1 _ -> case [Expr]
argExprsFiltered of
                      [e :: 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])
                      _ -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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 _ _ -> case [Expr]
argExprsFiltered of
                      [e1 :: Expr
e1,e2 :: 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])
                      _ -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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
      RTree 0 _ -> case [Expr]
argExprsFiltered of
                      [e :: 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])
                      _ -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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 _ _ -> case [Expr]
argExprsFiltered of
                      [e1 :: Expr
e1,e2 :: 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])
                      _ -> String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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
      String ->
        let dc' :: Expr
dc' = case DataCon -> Int
dcTag DataCon
dc of
                    1 -> Maybe (HWType, Int) -> Literal -> Expr
HW.Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (String -> Literal
StringLit "")
                    _ -> String -> Expr
forall a. HasCallStack => String -> a
error (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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 _
        | Identifier
dcNm Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== "GHC.Integer.Type.S#"
        -> Expr -> NetlistMonad Expr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Expr] -> Expr
forall a. [a] -> a
head [Expr]
argExprsFiltered)
        -- ByteArray# are non-translatable / void, except when they're literals
        | Identifier
dcNm Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== "GHC.Integer.Type.Jp#"
        , HW.Literal Nothing (NumLit _) <- [Expr] -> Expr
forall a. [a] -> a
head [Expr]
argExprs
        -> Expr -> NetlistMonad Expr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Expr] -> Expr
forall a. [a] -> a
head [Expr]
argExprs)
        | Identifier
dcNm Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== "GHC.Integer.Type.Jn#"
        -- ByteArray# are non-translatable / void, except when they're literals
        , HW.Literal Nothing (NumLit i :: Integer
i) <- [Expr] -> Expr
forall a. [a] -> a
head [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 _
        | Identifier
dcNm Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== "GHC.Natural.NatS#"
        -> Expr -> NetlistMonad Expr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Expr] -> Expr
forall a. [a] -> a
head [Expr]
argExprsFiltered)
        | Identifier
dcNm Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== "GHC.Natural.NatJ#"
        -- ByteArray# are non-translatable / void, except when they're literals
        , HW.Literal Nothing (NumLit _) <- [Expr] -> Expr
forall a. [a] -> a
head [Expr]
argExprs
        -> Expr -> NetlistMonad Expr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Expr] -> Expr
forall a. [a] -> a
head [Expr]
argExprs)
      _ ->
        String -> NetlistMonad Expr
forall a. HasCallStack => String -> a
error (String -> NetlistMonad Expr) -> String -> NetlistMonad Expr
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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 dstHTypes :: [HWType]
dstHTypes (MultiId argNms :: [Id]
argNms) _ args :: [Term]
args = do
  TyConMap
tcm                 <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
  let argTys :: [Type]
argTys          = (Term -> Type) -> [Term] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (TyConMap -> Term -> Type
termType 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. [a] -> [b] -> [(a, b)]
zipEqual ((Id -> NetlistId) -> [Id] -> [NetlistId]
forall a b. (a -> b) -> [a] -> [b]
map Id -> NetlistId
CoreId [Id]
argNms) [Term]
args)
      (_hWTysFiltered :: [Maybe HWType]
_hWTysFiltered,argsFiltered :: [(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)
  (argExprs :: [Expr]
argExprs,argDecls :: [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 (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, 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
Concurrent)) [(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
    let assns :: [Declaration]
assns = ((NetlistId, Expr) -> Maybe Declaration)
-> [(NetlistId, Expr)] -> [Declaration]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
                  (\case (_,Noop) -> Maybe Declaration
forall a. Maybe a
Nothing
                         (dstId :: NetlistId
dstId,e :: 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 Id -> Identifier
id2identifier NetlistId
dstId
                                      in  case Expr
e of
                                            Identifier nm0 :: Identifier
nm0 Nothing
                                              | Identifier
nm Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Identifier
nm0 -> Maybe Declaration
forall a. Maybe a
Nothing
                                            _ -> Declaration -> Maybe Declaration
forall a. a -> Maybe a
Just (Identifier -> Expr -> Declaration
Assignment Identifier
nm Expr
e))
                  ([NetlistId] -> [Expr] -> [(NetlistId, Expr)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((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 "internal error"

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