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

  Functions to create BlackBox Contexts and fill in BlackBox templates
-}

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

module Clash.Netlist.BlackBox where

import           Control.Exception             (throw)
import           Control.Lens                  ((<<%=),(%=))
import qualified Control.Lens                  as Lens
import           Control.Monad                 (when, replicateM)
import           Control.Monad.IO.Class        (liftIO)
import           Data.Char                     (ord)
import           Data.Either                   (lefts, partitionEithers)
import qualified Data.HashMap.Lazy             as HashMap
import qualified Data.IntMap                   as IntMap
import           Data.List                     (elemIndex, partition)
import           Data.Maybe                    (catMaybes, fromJust, fromMaybe)
import           Data.Semigroup.Monad
import qualified Data.Set                      as Set
import           Data.Text.Lazy                (fromStrict)
import qualified Data.Text.Lazy                as Text
import           Data.Text                     (unpack)
import qualified Data.Text                     as TextS
import           GHC.Stack
  (callStack, prettyCallStack)
import qualified System.Console.ANSI           as ANSI
import           System.Console.ANSI
  ( hSetSGR, SGR(SetConsoleIntensity, SetColor), Color(Magenta)
  , ConsoleIntensity(BoldIntensity), ConsoleLayer(Foreground), ColorIntensity(Vivid))
import           System.IO
  (hPutStrLn, stderr, hFlush, hIsTerminalDevice)
import           TextShow                      (showt)
import           Util                          (OverridingBool(..))

import           Clash.Annotations.Primitive
  (PrimitiveGuard(HasBlackBox, WarnNonSynthesizable, WarnAlways, DontTranslate),
   extractPrim)
import           Clash.Annotations.TopEntity
  (TopEntity(Synthesize), PortName(PortName))
import           Clash.Core.DataCon            as D (dcTag)
import           Clash.Core.FreeVars           (freeIds)
import           Clash.Core.Literal            as L (Literal (..))
import           Clash.Core.Name
  (Name (..), mkUnsafeSystemName)
import           Clash.Core.Pretty             (showPpr)
import           Clash.Core.Subst              (extendIdSubst, mkSubst, substTm)
import           Clash.Core.Term               as C
  (PrimInfo (..), Term (..), WorkInfo (..), collectArgs, collectArgsTicks)
import           Clash.Core.Type               as C
  (Type (..), ConstTy (..), TypeView (..), mkFunTy, splitFunTys, splitFunTy, tyView)
import           Clash.Core.TyCon              as C (TyConMap, tyConDataCons)
import           Clash.Core.Util
  (collectBndrs, inverseTopSortLetBindings, isFun, mkApps, splitShouldSplit, termType)
import           Clash.Core.Var                as V
  (Id, Var (..), mkLocalId, modifyVarName)
import           Clash.Core.VarEnv
  (extendInScopeSet, mkInScopeSet, lookupVarEnv, uniqAway, unitVarSet)
import {-# SOURCE #-} Clash.Netlist
  (genComponent, mkDcApplication, mkDeclarations, mkExpr, mkNetDecl,
   mkProjection, mkSelection, mkFunApp, mkDeclarations')
import qualified Clash.Backend                 as Backend
import           Clash.Driver.Types
  (opt_primWarn, opt_color, ClashOpts)
import           Clash.Netlist.BlackBox.Types  as B
import           Clash.Netlist.BlackBox.Util   as B
import           Clash.Netlist.Id              (IdType (..))
import           Clash.Netlist.Types           as N
import           Clash.Netlist.Util            as N
import           Clash.Primitives.Types        as P
import qualified Clash.Primitives.Util         as P
import           Clash.Signal.Internal         (ActiveEdge (..))
import           Clash.Unique                  (lookupUniqMap')
import           Clash.Util

-- | Emits (colorized) warning to stderr
warn
  :: ClashOpts
  -> String
  -> IO ()
warn :: ClashOpts -> String -> IO ()
warn opts :: ClashOpts
opts msg :: String
msg = do
  -- TODO: Put in appropriate module
  Bool
useColor <-
    case ClashOpts -> OverridingBool
opt_color ClashOpts
opts of
      Always -> Bool -> IO Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
True
      Never  -> Bool -> IO Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False
      Auto   -> Handle -> IO Bool
hIsTerminalDevice Handle
stderr

  Handle -> [SGR] -> IO ()
hSetSGR Handle
stderr [ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity]
  Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when Bool
useColor (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> [SGR] -> IO ()
hSetSGR Handle
stderr [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Magenta]
  Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "[WARNING] " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
  Handle -> [SGR] -> IO ()
hSetSGR Handle
stderr [SGR
ANSI.Reset]
  Handle -> IO ()
hFlush Handle
stderr

-- | Generate the context for a BlackBox instantiation.
mkBlackBoxContext
  :: TextS.Text
  -- ^ Blackbox function name
  -> Id
  -- ^ Identifier binding the primitive/blackbox application
  -> [Either Term Type]
  -- ^ Arguments of the primitive/blackbox application
  -> NetlistMonad (BlackBoxContext,[Declaration])
mkBlackBoxContext :: Text
-> Id
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext bbName :: Text
bbName resId :: Id
resId args :: [Either Term Type]
args@([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts -> [Term]
termArgs) = do
    -- Make context inputs
    let resNm :: Text
resNm = Name Term -> Text
forall a. Name a -> Text
nameOcc (Id -> Name Term
forall a. Var a -> Name a
varName Id
resId)
    HWType
resTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(curLoc) (Id -> Type
forall a. Var a -> Type
V.varType Id
resId)
    (imps :: [(Expr, HWType, Bool)]
imps,impDecls :: [[Declaration]]
impDecls) <- [((Expr, HWType, Bool), [Declaration])]
-> ([(Expr, HWType, Bool)], [[Declaration]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([((Expr, HWType, Bool), [Declaration])]
 -> ([(Expr, HWType, Bool)], [[Declaration]]))
-> NetlistMonad [((Expr, HWType, Bool), [Declaration])]
-> NetlistMonad ([(Expr, HWType, Bool)], [[Declaration]])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Term -> NetlistMonad ((Expr, HWType, Bool), [Declaration]))
-> [Term] -> NetlistMonad [((Expr, HWType, Bool), [Declaration])]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Text -> Term -> NetlistMonad ((Expr, HWType, Bool), [Declaration])
mkArgument Text
resNm) [Term]
termArgs
    (funs :: IntMap
  [(Either BlackBox (Text, [Declaration]), WireOrReg,
    [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
    BlackBoxContext)]
funs,funDecls :: [[Declaration]]
funDecls) <-
      (IntMap
   [(Either BlackBox (Text, [Declaration]), WireOrReg,
     [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
     BlackBoxContext)]
 -> (Term, Int)
 -> NetlistMonad
      (IntMap
         [(Either BlackBox (Text, [Declaration]), WireOrReg,
           [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
           BlackBoxContext)],
       [Declaration]))
-> IntMap
     [(Either BlackBox (Text, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext)]
-> [(Term, Int)]
-> NetlistMonad
     (IntMap
        [(Either BlackBox (Text, [Declaration]), WireOrReg,
          [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
          BlackBoxContext)],
      [[Declaration]])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM
        (Type
-> IntMap
     [(Either BlackBox (Text, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext)]
-> (Term, Int)
-> NetlistMonad
     (IntMap
        [(Either BlackBox (Text, [Declaration]), WireOrReg,
          [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
          BlackBoxContext)],
      [Declaration])
addFunction (Id -> Type
forall a. Var a -> Type
V.varType Id
resId))
        IntMap
  [(Either BlackBox (Text, [Declaration]), WireOrReg,
    [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
    BlackBoxContext)]
forall a. IntMap a
IntMap.empty
        ([Term] -> [Int] -> [(Term, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Term]
termArgs [0..])

    -- Make context result
    let res :: Expr
res = Text -> Maybe Modifier -> Expr
Identifier Text
resNm Maybe Modifier
forall a. Maybe a
Nothing

    Int
lvl <- 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
curBBlvl
    (nm :: Text
nm,_) <- Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
-> NetlistMonad (Text, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
Lens' NetlistState (Text, SrcSpan)
curCompNm

    -- Set "context name" to value set by `Clash.Magic.setName`, default to the
    -- name of the closest binder
    Text
ctxName1 <- Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
resNm (Maybe Text -> Text)
-> NetlistMonad (Maybe Text) -> NetlistMonad Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Maybe Text) NetlistEnv (Maybe Text)
-> NetlistMonad (Maybe Text)
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting (Maybe Text) NetlistEnv (Maybe Text)
Lens' NetlistEnv (Maybe Text)
setName
    -- Update "context name" with prefixes and suffixes set by
    -- `Clash.Magic.prefixName` and `Clash.Magic.suffixName`
    Text
ctxName2 <- Text -> NetlistMonad Text
affixName Text
ctxName1

    (BlackBoxContext, [Declaration])
-> NetlistMonad (BlackBoxContext, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ( Text
-> (Expr, HWType)
-> [(Expr, HWType, Bool)]
-> IntMap
     [(Either BlackBox (Text, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext)]
-> [Text]
-> Int
-> Text
-> Maybe Text
-> BlackBoxContext
Context Text
bbName (Expr
res,HWType
resTy) [(Expr, HWType, Bool)]
imps IntMap
  [(Either BlackBox (Text, [Declaration]), WireOrReg,
    [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
    BlackBoxContext)]
funs [] Int
lvl Text
nm (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
ctxName2)
           , [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
impDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
funDecls
           )
  where
    addFunction :: Type
-> IntMap
     [(Either BlackBox (Text, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext)]
-> (Term, Int)
-> NetlistMonad
     (IntMap
        [(Either BlackBox (Text, [Declaration]), WireOrReg,
          [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
          BlackBoxContext)],
      [Declaration])
addFunction resTy :: Type
resTy im :: IntMap
  [(Either BlackBox (Text, [Declaration]), WireOrReg,
    [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
    BlackBoxContext)]
im (arg :: Term
arg,i :: Int
i) = 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
      if TyConMap -> Term -> Bool
isFun TyConMap
tcm Term
arg then do
        -- Only try to calculate function plurality when primitive actually
        -- exists. Here to prevent crashes on __INTERNAL__ primitives.
        Maybe GuardedCompiledPrimitive
prim <- Text
-> HashMap Text GuardedCompiledPrimitive
-> Maybe GuardedCompiledPrimitive
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
bbName (HashMap Text GuardedCompiledPrimitive
 -> Maybe GuardedCompiledPrimitive)
-> NetlistMonad (HashMap Text GuardedCompiledPrimitive)
-> NetlistMonad (Maybe GuardedCompiledPrimitive)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (HashMap Text GuardedCompiledPrimitive)
  NetlistState
  (HashMap Text GuardedCompiledPrimitive)
-> NetlistMonad (HashMap Text GuardedCompiledPrimitive)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
  (HashMap Text GuardedCompiledPrimitive)
  NetlistState
  (HashMap Text GuardedCompiledPrimitive)
Lens' NetlistState (HashMap Text GuardedCompiledPrimitive)
primitives
        Int
funcPlurality <-
          case GuardedCompiledPrimitive -> Maybe CompiledPrimitive
forall a. PrimitiveGuard a -> Maybe a
extractPrim (GuardedCompiledPrimitive -> Maybe CompiledPrimitive)
-> Maybe GuardedCompiledPrimitive
-> Maybe (Maybe CompiledPrimitive)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe GuardedCompiledPrimitive
prim of
            Just (Just p :: CompiledPrimitive
p) ->
              HasCallStack =>
CompiledPrimitive
-> [Either Term Type] -> Type -> Int -> NetlistMonad Int
CompiledPrimitive
-> [Either Term Type] -> Type -> Int -> NetlistMonad Int
P.getFunctionPlurality CompiledPrimitive
p [Either Term Type]
args Type
resTy Int
i
            _ ->
              Int -> NetlistMonad Int
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure 1

        (Int -> Identity Int) -> NetlistState -> Identity NetlistState
Lens' NetlistState Int
curBBlvl ((Int -> Identity Int) -> NetlistState -> Identity NetlistState)
-> Int -> NetlistMonad ()
forall s (m :: Type -> Type) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
Lens.+= 1
        (fs :: [(Either BlackBox (Text, [Declaration]), WireOrReg,
  [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
  BlackBoxContext)]
fs,ds :: [[Declaration]]
ds) <- [((Either BlackBox (Text, [Declaration]), WireOrReg,
   [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
   BlackBoxContext),
  [Declaration])]
-> ([(Either BlackBox (Text, [Declaration]), WireOrReg,
      [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
      BlackBoxContext)],
    [[Declaration]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([((Either BlackBox (Text, [Declaration]), WireOrReg,
    [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
    BlackBoxContext),
   [Declaration])]
 -> ([(Either BlackBox (Text, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext)],
     [[Declaration]]))
-> NetlistMonad
     [((Either BlackBox (Text, [Declaration]), WireOrReg,
        [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
        BlackBoxContext),
       [Declaration])]
-> NetlistMonad
     ([(Either BlackBox (Text, [Declaration]), WireOrReg,
        [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
        BlackBoxContext)],
      [[Declaration]])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> NetlistMonad
     ((Either BlackBox (Text, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext),
      [Declaration])
-> NetlistMonad
     [((Either BlackBox (Text, [Declaration]), WireOrReg,
        [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
        BlackBoxContext),
       [Declaration])]
forall (m :: Type -> Type) a. Applicative m => Int -> m a -> m [a]
replicateM Int
funcPlurality (HasCallStack =>
Id
-> Term
-> NetlistMonad
     ((Either BlackBox (Text, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext),
      [Declaration])
Id
-> Term
-> NetlistMonad
     ((Either BlackBox (Text, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext),
      [Declaration])
mkFunInput Id
resId Term
arg)
        (Int -> Identity Int) -> NetlistState -> Identity NetlistState
Lens' NetlistState Int
curBBlvl ((Int -> Identity Int) -> NetlistState -> Identity NetlistState)
-> Int -> NetlistMonad ()
forall s (m :: Type -> Type) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
Lens.-= 1

        let im' :: IntMap
  [(Either BlackBox (Text, [Declaration]), WireOrReg,
    [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
    BlackBoxContext)]
im' = Int
-> [(Either BlackBox (Text, [Declaration]), WireOrReg,
     [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
     BlackBoxContext)]
-> IntMap
     [(Either BlackBox (Text, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext)]
-> IntMap
     [(Either BlackBox (Text, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext)]
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
i [(Either BlackBox (Text, [Declaration]), WireOrReg,
  [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
  BlackBoxContext)]
fs IntMap
  [(Either BlackBox (Text, [Declaration]), WireOrReg,
    [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
    BlackBoxContext)]
im
        (IntMap
   [(Either BlackBox (Text, [Declaration]), WireOrReg,
     [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
     BlackBoxContext)],
 [Declaration])
-> NetlistMonad
     (IntMap
        [(Either BlackBox (Text, [Declaration]), WireOrReg,
          [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
          BlackBoxContext)],
      [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (IntMap
  [(Either BlackBox (Text, [Declaration]), WireOrReg,
    [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
    BlackBoxContext)]
im', [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
ds)
      else
        (IntMap
   [(Either BlackBox (Text, [Declaration]), WireOrReg,
     [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
     BlackBoxContext)],
 [Declaration])
-> NetlistMonad
     (IntMap
        [(Either BlackBox (Text, [Declaration]), WireOrReg,
          [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
          BlackBoxContext)],
      [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (IntMap
  [(Either BlackBox (Text, [Declaration]), WireOrReg,
    [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
    BlackBoxContext)]
im, [])

prepareBlackBox
  :: TextS.Text
  -> BlackBox
  -> BlackBoxContext
  -> NetlistMonad (BlackBox,[Declaration])
prepareBlackBox :: Text
-> BlackBox
-> BlackBoxContext
-> NetlistMonad (BlackBox, [Declaration])
prepareBlackBox _pNm :: Text
_pNm templ :: BlackBox
templ bbCtx :: BlackBoxContext
bbCtx =
  case BlackBoxContext -> BlackBox -> Maybe String
verifyBlackBoxContext BlackBoxContext
bbCtx BlackBox
templ of
    Nothing -> do
      (t2 :: BlackBox
t2,decls :: [Declaration]
decls) <-
        (BlackBoxTemplate -> NetlistMonad (BlackBox, [Declaration]))
-> (String
    -> Int
    -> TemplateFunction
    -> NetlistMonad (BlackBox, [Declaration]))
-> BlackBox
-> NetlistMonad (BlackBox, [Declaration])
forall r.
(BlackBoxTemplate -> r)
-> (String -> Int -> TemplateFunction -> r) -> BlackBox -> r
onBlackBox
          (((BlackBoxTemplate, [Declaration]) -> (BlackBox, [Declaration]))
-> NetlistMonad (BlackBoxTemplate, [Declaration])
-> NetlistMonad (BlackBox, [Declaration])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((BlackBoxTemplate -> BlackBox)
-> (BlackBoxTemplate, [Declaration]) -> (BlackBox, [Declaration])
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first BlackBoxTemplate -> BlackBox
BBTemplate) (NetlistMonad (BlackBoxTemplate, [Declaration])
 -> NetlistMonad (BlackBox, [Declaration]))
-> (BlackBoxTemplate
    -> NetlistMonad (BlackBoxTemplate, [Declaration]))
-> BlackBoxTemplate
-> NetlistMonad (BlackBox, [Declaration])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IdType -> Text -> NetlistMonad Text)
-> BlackBoxContext
-> BlackBoxTemplate
-> NetlistMonad (BlackBoxTemplate, [Declaration])
forall (m :: Type -> Type).
Monad m =>
(IdType -> Text -> m Text)
-> BlackBoxContext
-> BlackBoxTemplate
-> m (BlackBoxTemplate, [Declaration])
setSym IdType -> Text -> NetlistMonad Text
mkUniqueIdentifier BlackBoxContext
bbCtx)
          (\bbName :: String
bbName bbHash :: Int
bbHash bbFunc :: TemplateFunction
bbFunc -> (BlackBox, [Declaration]) -> NetlistMonad (BlackBox, [Declaration])
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (String -> Int -> TemplateFunction -> BlackBox
BBFunction String
bbName Int
bbHash TemplateFunction
bbFunc, []))
          BlackBox
templ
      (BlackBox, [Declaration]) -> NetlistMonad (BlackBox, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (BlackBox
t2,[Declaration]
decls)
    Just err0 :: String
err0 -> do
      (_,sp :: SrcSpan
sp) <- Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
-> NetlistMonad (Text, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
Lens' NetlistState (Text, SrcSpan)
curCompNm
      let err1 :: String
err1 = [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [ "Couldn't instantiate blackbox for "
                        , Text -> String
Data.Text.unpack (BlackBoxContext -> Text
bbName BlackBoxContext
bbCtx), ". Verification "
                        , "procedure reported:\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err0 ]
      ClashException -> NetlistMonad (BlackBox, [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]
++ String
err1) Maybe String
forall a. Maybe a
Nothing)

-- | Determine if a term represents a literal
isLiteral :: Term -> Bool
isLiteral :: Term -> Bool
isLiteral e :: Term
e = case Term -> (Term, [Either Term Type])
collectArgs Term
e of
  (Data _, args :: [Either Term Type]
args)   -> (Either Term Type -> Bool) -> [Either Term Type] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all ((Term -> Bool) -> (Type -> Bool) -> Either Term Type -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Term -> Bool
isLiteral (Bool -> Type -> Bool
forall a b. a -> b -> a
const Bool
True)) [Either Term Type]
args
  (Prim _, args :: [Either Term Type]
args) -> (Either Term Type -> Bool) -> [Either Term Type] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all ((Term -> Bool) -> (Type -> Bool) -> Either Term Type -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Term -> Bool
isLiteral (Bool -> Type -> Bool
forall a b. a -> b -> a
const Bool
True)) [Either Term Type]
args
  (C.Literal _,_)  -> Bool
True
  _                -> Bool
False

mkArgument
  :: Identifier
  -- ^ LHS of the original let-binder
  -> Term
  -> NetlistMonad ( (Expr,HWType,Bool)
                  , [Declaration]
                  )
mkArgument :: Text -> Term -> NetlistMonad ((Expr, HWType, Bool), [Declaration])
mkArgument bndr :: Text
bndr e :: Term
e = 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 ty :: Type
ty = TyConMap -> Term -> Type
termType TyConMap
tcm Term
e
    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
    Maybe HWType
hwTyM <- (FilteredHWType -> HWType) -> Maybe FilteredHWType -> Maybe HWType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap FilteredHWType -> HWType
stripFiltered (Maybe FilteredHWType -> Maybe HWType)
-> NetlistMonad (Maybe FilteredHWType)
-> NetlistMonad (Maybe HWType)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> NetlistMonad (Maybe FilteredHWType)
N.termHWTypeM Term
e
    let eTyMsg :: String
eTyMsg = "(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ " :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall p. PrettyPrec p => p -> String
showPpr Type
ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
    ((e' :: Expr
e',t :: HWType
t,l :: Bool
l),d :: [Declaration]
d) <- case Maybe HWType
hwTyM of
      Nothing
        | (Prim p :: PrimInfo
p,_) <- Term -> (Term, [Either Term Type])
collectArgs Term
e
        , PrimInfo -> Text
primName PrimInfo
p Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Transformations.removedArg"
        -> ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Text -> Maybe Modifier -> Expr
Identifier (PrimInfo -> Text
primName PrimInfo
p) Maybe Modifier
forall a. Maybe a
Nothing, Maybe HWType -> HWType
Void Maybe HWType
forall a. Maybe a
Nothing, Bool
False),[])
        | Bool
otherwise
        -> ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((String -> Expr
forall a. HasCallStack => String -> a
error ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Forced to evaluate untranslatable type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
eTyMsg), Maybe HWType -> HWType
Void Maybe HWType
forall a. Maybe a
Nothing, Bool
False), [])
      Just hwTy :: HWType
hwTy -> case Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks Term
e of
        (C.Var v :: Id
v,[],_) -> ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Text -> Maybe Modifier -> Expr
Identifier (Name Term -> Text
forall a. Name a -> Text
nameOcc (Id -> Name Term
forall a. Var a -> Name a
varName Id
v)) Maybe Modifier
forall a. Maybe a
Nothing,HWType
hwTy,Bool
False),[])
        (C.Literal (IntegerLiteral i :: Integer
i),[],_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Maybe (HWType, Int) -> Literal -> Expr
N.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
Signed Int
iw,Int
iw)) (Integer -> Literal
N.NumLit Integer
i),HWType
hwTy,Bool
True),[])
        (C.Literal (IntLiteral i :: Integer
i), [],_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Maybe (HWType, Int) -> Literal -> Expr
N.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
Signed Int
iw,Int
iw)) (Integer -> Literal
N.NumLit Integer
i),HWType
hwTy,Bool
True),[])
        (C.Literal (WordLiteral w :: Integer
w), [],_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Maybe (HWType, Int) -> Literal -> Expr
N.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
Unsigned Int
iw,Int
iw)) (Integer -> Literal
N.NumLit Integer
w),HWType
hwTy,Bool
True),[])
        (C.Literal (CharLiteral c :: Char
c), [],_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Maybe (HWType, Int) -> Literal -> Expr
N.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
Unsigned 21,21)) (Integer -> Literal
N.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),HWType
hwTy,Bool
True),[])
        (C.Literal (StringLiteral s :: String
s),[],_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Maybe (HWType, Int) -> Literal -> Expr
N.Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (String -> Literal
N.StringLit String
s),HWType
hwTy,Bool
True),[])
        (C.Literal (Int64Literal i :: Integer
i), [],_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Maybe (HWType, Int) -> Literal -> Expr
N.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
Signed 64,64)) (Integer -> Literal
N.NumLit Integer
i),HWType
hwTy,Bool
True),[])
        (C.Literal (Word64Literal i :: Integer
i), [],_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Maybe (HWType, Int) -> Literal -> Expr
N.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
Unsigned 64,64)) (Integer -> Literal
N.NumLit Integer
i),HWType
hwTy,Bool
True),[])
        (C.Literal (NaturalLiteral n :: Integer
n), [],_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Maybe (HWType, Int) -> Literal -> Expr
N.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
Unsigned Int
iw,Int
iw)) (Integer -> Literal
N.NumLit Integer
n),HWType
hwTy,Bool
True),[])
        (Prim pinfo :: PrimInfo
pinfo,args :: [Either Term Type]
args,ticks :: [TickInfo]
ticks) -> [TickInfo]
-> ([Declaration]
    -> NetlistMonad ((Expr, HWType, Bool), [Declaration]))
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall a.
[TickInfo] -> ([Declaration] -> NetlistMonad a) -> NetlistMonad a
withTicks [TickInfo]
ticks (([Declaration]
  -> NetlistMonad ((Expr, HWType, Bool), [Declaration]))
 -> NetlistMonad ((Expr, HWType, Bool), [Declaration]))
-> ([Declaration]
    -> NetlistMonad ((Expr, HWType, Bool), [Declaration]))
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall a b. (a -> b) -> a -> b
$ \tickDecls :: [Declaration]
tickDecls -> do
          (e' :: Expr
e',d :: [Declaration]
d) <- Bool
-> Bool
-> NetlistId
-> PrimInfo
-> [Either Term Type]
-> [Declaration]
-> NetlistMonad (Expr, [Declaration])
mkPrimitive Bool
True Bool
False (Text -> Type -> NetlistId
NetlistId Text
bndr Type
ty) PrimInfo
pinfo [Either Term Type]
args [Declaration]
tickDecls
          case Expr
e' of
            (Identifier _ _) -> ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Expr
e',HWType
hwTy,Bool
False), [Declaration]
d)
            _                -> ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Expr
e',HWType
hwTy,Term -> Bool
isLiteral Term
e), [Declaration]
d)
        (Data dc :: DataCon
dc, args :: [Either Term Type]
args,_) -> do
          (exprN :: Expr
exprN,dcDecls :: [Declaration]
dcDecls) <- HasCallStack =>
[HWType]
-> NetlistId
-> DataCon
-> [Term]
-> NetlistMonad (Expr, [Declaration])
[HWType]
-> NetlistId
-> DataCon
-> [Term]
-> NetlistMonad (Expr, [Declaration])
mkDcApplication [HWType
hwTy] (Text -> Type -> NetlistId
NetlistId Text
bndr Type
ty) DataCon
dc ([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args)
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Expr
exprN,HWType
hwTy,Term -> Bool
isLiteral Term
e),[Declaration]
dcDecls)
        (Case scrut :: Term
scrut ty' :: Type
ty' [alt :: Alt
alt],[],_) -> do
          (projection :: Expr
projection,decls :: [Declaration]
decls) <- Bool
-> NetlistId
-> Term
-> Type
-> Alt
-> NetlistMonad (Expr, [Declaration])
mkProjection Bool
False (Text -> Type -> NetlistId
NetlistId Text
bndr Type
ty) Term
scrut Type
ty' Alt
alt
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Expr
projection,HWType
hwTy,Bool
False),[Declaration]
decls)
        _ ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Text -> Maybe Modifier -> Expr
Identifier (String -> Text
forall a. HasCallStack => String -> a
error ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Forced to evaluate unexpected function argument: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
eTyMsg)) Maybe Modifier
forall a. Maybe a
Nothing
                  ,HWType
hwTy,Bool
False),[])
    ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Expr
e',HWType
t,Bool
l),[Declaration]
d)

-- | Extract a compiled primitive from a guarded primitive. Emit a warning if
-- the guard wants to, or fail entirely.
extractPrimWarnOrFail
  :: HasCallStack
  => TextS.Text
  -- ^ Name of primitive
  -> NetlistMonad CompiledPrimitive
extractPrimWarnOrFail :: Text -> NetlistMonad CompiledPrimitive
extractPrimWarnOrFail nm :: Text
nm = do
  Maybe GuardedCompiledPrimitive
prim <- Text
-> HashMap Text GuardedCompiledPrimitive
-> Maybe GuardedCompiledPrimitive
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
nm (HashMap Text GuardedCompiledPrimitive
 -> Maybe GuardedCompiledPrimitive)
-> NetlistMonad (HashMap Text GuardedCompiledPrimitive)
-> NetlistMonad (Maybe GuardedCompiledPrimitive)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (HashMap Text GuardedCompiledPrimitive)
  NetlistState
  (HashMap Text GuardedCompiledPrimitive)
-> NetlistMonad (HashMap Text GuardedCompiledPrimitive)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
  (HashMap Text GuardedCompiledPrimitive)
  NetlistState
  (HashMap Text GuardedCompiledPrimitive)
Lens' NetlistState (HashMap Text GuardedCompiledPrimitive)
primitives
  case Maybe GuardedCompiledPrimitive
prim of
    Just guardedPrim :: GuardedCompiledPrimitive
guardedPrim ->
      -- See if we need to warn the user, or error because we encountered
      -- a primitive the user explicitly requested not to translate
      GuardedCompiledPrimitive -> NetlistMonad CompiledPrimitive
go GuardedCompiledPrimitive
guardedPrim
    Nothing -> do
      -- Blackbox requested, but no blackbox found at all!
      (_,sp :: SrcSpan
sp) <- Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
-> NetlistMonad (Text, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
Lens' NetlistState (Text, SrcSpan)
curCompNm
      let msg :: String
msg = $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "No blackbox found for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
unpack Text
nm
             String -> String -> String
forall a. [a] -> [a] -> [a]
++ ". Did you forget to include directories containing "
             String -> String -> String
forall a. [a] -> [a] -> [a]
++ "primitives? You can use '-i/my/prim/dir' to achieve this."
             String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
debugIsOn then "\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n\n" else [])
      ClashException -> NetlistMonad CompiledPrimitive
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp String
msg Maybe String
forall a. Maybe a
Nothing)
 where
  go
    :: GuardedCompiledPrimitive
    -> NetlistMonad CompiledPrimitive
  go :: GuardedCompiledPrimitive -> NetlistMonad CompiledPrimitive
go (HasBlackBox cp :: CompiledPrimitive
cp) =
    CompiledPrimitive -> NetlistMonad CompiledPrimitive
forall (m :: Type -> Type) a. Monad m => a -> m a
return CompiledPrimitive
cp

  go DontTranslate = do
    (_,sp :: SrcSpan
sp) <- Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
-> NetlistMonad (Text, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
Lens' NetlistState (Text, SrcSpan)
curCompNm
    let msg :: String
msg = $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Clash was forced to translate '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
unpack Text
nm
           String -> String -> String
forall a. [a] -> [a] -> [a]
++ "', but this value was marked with DontTranslate. Did you forget"
           String -> String -> String
forall a. [a] -> [a] -> [a]
++ " to include a blackbox for one of the constructs using this?"
           String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
debugIsOn then "\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n\n" else [])
    ClashException -> NetlistMonad CompiledPrimitive
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp String
msg Maybe String
forall a. Maybe a
Nothing)

  go (WarnAlways warning :: String
warning cp :: CompiledPrimitive
cp) = do
    Bool
primWarn <- ClashOpts -> Bool
opt_primWarn (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
    Bool
seen <- Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Text
nm (Set Text -> Bool) -> NetlistMonad (Set Text) -> NetlistMonad Bool
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Set Text) NetlistState (Set Text)
-> NetlistMonad (Set Text)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Set Text) NetlistState (Set Text)
Lens' NetlistState (Set Text)
seenPrimitives
    ClashOpts
opts <- 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

    Bool -> NetlistMonad () -> NetlistMonad ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool
primWarn Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
seen)
      (NetlistMonad () -> NetlistMonad ())
-> NetlistMonad () -> NetlistMonad ()
forall a b. (a -> b) -> a -> b
$ IO () -> NetlistMonad ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO
      (IO () -> NetlistMonad ()) -> IO () -> NetlistMonad ()
forall a b. (a -> b) -> a -> b
$ ClashOpts -> String -> IO ()
warn ClashOpts
opts
      (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Dubious primitive instantiation for "
     String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
unpack Text
nm
     String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": "
     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
warning
     String -> String -> String
forall a. [a] -> [a] -> [a]
++ " (disable with -fclash-no-prim-warn)"

    (Set Text -> Identity (Set Text))
-> NetlistState -> Identity NetlistState
Lens' NetlistState (Set Text)
seenPrimitives ((Set Text -> Identity (Set Text))
 -> NetlistState -> Identity NetlistState)
-> (Set Text -> Set Text) -> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
Set.insert Text
nm

    CompiledPrimitive -> NetlistMonad CompiledPrimitive
forall (m :: Type -> Type) a. Monad m => a -> m a
return CompiledPrimitive
cp

  go (WarnNonSynthesizable warning :: String
warning cp :: CompiledPrimitive
cp) = do
    Bool
isTB <- 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
isTestBench
    if Bool
isTB then CompiledPrimitive -> NetlistMonad CompiledPrimitive
forall (m :: Type -> Type) a. Monad m => a -> m a
return CompiledPrimitive
cp else GuardedCompiledPrimitive -> NetlistMonad CompiledPrimitive
go (String -> CompiledPrimitive -> GuardedCompiledPrimitive
forall a. String -> a -> PrimitiveGuard a
WarnAlways String
warning CompiledPrimitive
cp)


mkPrimitive
  :: Bool
  -- ^ Put BlackBox expression in parenthesis
  -> Bool
  -- ^ Treat BlackBox expression as declaration
  -> NetlistId
  -- ^ Id to assign the result to
  -> PrimInfo
  -- ^ Primitive info
  -> [Either Term Type]
  -- ^ Arguments
  -> [Declaration]
  -- ^ Tick declarations
  -> NetlistMonad (Expr,[Declaration])
mkPrimitive :: Bool
-> Bool
-> NetlistId
-> PrimInfo
-> [Either Term Type]
-> [Declaration]
-> NetlistMonad (Expr, [Declaration])
mkPrimitive bbEParen :: Bool
bbEParen bbEasD :: Bool
bbEasD dst :: NetlistId
dst pInfo :: PrimInfo
pInfo args :: [Either Term Type]
args tickDecls :: [Declaration]
tickDecls =
  CompiledPrimitive -> NetlistMonad (Expr, [Declaration])
go (CompiledPrimitive -> NetlistMonad (Expr, [Declaration]))
-> NetlistMonad CompiledPrimitive
-> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< HasCallStack => Text -> NetlistMonad CompiledPrimitive
Text -> NetlistMonad CompiledPrimitive
extractPrimWarnOrFail (PrimInfo -> Text
primName PrimInfo
pInfo)
  where
    ty :: Type
ty = [Type] -> Type
forall a. [a] -> a
head (NetlistId -> [Type]
netlistTypes NetlistId
dst)

    go
      :: CompiledPrimitive
      -> NetlistMonad (Expr, [Declaration])
    go :: CompiledPrimitive -> NetlistMonad (Expr, [Declaration])
go =
      \case
        P.BlackBoxHaskell bbName :: Text
bbName wf :: WorkInfo
wf _usedArgs :: UsedArguments
_usedArgs funcName :: BlackBoxFunctionName
funcName (_fHash :: Int
_fHash, func :: BlackBoxFunction
func) -> do
          Either String (BlackBoxMeta, BlackBox)
bbFunRes <- BlackBoxFunction
func Bool
bbEasD (PrimInfo -> Text
primName PrimInfo
pInfo) [Either Term Type]
args Type
ty
          case Either String (BlackBoxMeta, BlackBox)
bbFunRes of
            Left err :: String
err -> do
              -- Blackbox template function returned an error:
              let err' :: String
err' = [String] -> String
unwords [ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Could not create blackbox"
                                 , "template using", BlackBoxFunctionName -> String
forall a. Show a => a -> String
show BlackBoxFunctionName
funcName, "for"
                                 , Text -> String
forall a. Show a => a -> String
show Text
bbName String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".", "Function reported: \n\n"
                                 , String
err ]
              (_,sp :: SrcSpan
sp) <- Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
-> NetlistMonad (Text, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
Lens' NetlistState (Text, SrcSpan)
curCompNm
              ClashException -> NetlistMonad (Expr, [Declaration])
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp String
err' Maybe String
forall a. Maybe a
Nothing)
            Right (BlackBoxMeta {..}, bbTemplate :: BlackBox
bbTemplate) ->
              -- Blackbox template generation succesful. Rerun 'go', but this time
              -- around with a 'normal' @BlackBox@
              CompiledPrimitive -> NetlistMonad (Expr, [Declaration])
go (Text
-> WorkInfo
-> RenderVoid
-> TemplateKind
-> ()
-> Bool
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [(Int, Int)]
-> [((Text, Text), BlackBox)]
-> Maybe BlackBox
-> Maybe BlackBox
-> BlackBox
-> CompiledPrimitive
forall a b c d.
Text
-> WorkInfo
-> RenderVoid
-> TemplateKind
-> c
-> Bool
-> [a]
-> [a]
-> [(Int, Int)]
-> [((Text, Text), b)]
-> Maybe b
-> Maybe b
-> b
-> Primitive a b c d
P.BlackBox
                    Text
bbName WorkInfo
wf RenderVoid
bbRenderVoid TemplateKind
bbKind () Bool
bbOutputReg [BlackBoxTemplate]
bbLibrary [BlackBoxTemplate]
bbImports
                    [(Int, Int)]
bbFunctionPlurality [((Text, Text), BlackBox)]
bbIncludes Maybe BlackBox
forall a. Maybe a
Nothing Maybe BlackBox
forall a. Maybe a
Nothing BlackBox
bbTemplate)
        p :: CompiledPrimitive
p@P.BlackBox {} ->
          case CompiledPrimitive -> TemplateKind
forall a b c d. Primitive a b c d -> TemplateKind
kind CompiledPrimitive
p of
            TDecl -> do
              let tempD :: BlackBox
tempD = CompiledPrimitive -> BlackBox
forall a b c d. Primitive a b c d -> b
template CompiledPrimitive
p
                  pNm :: Text
pNm = CompiledPrimitive -> Text
forall a b c d. Primitive a b c d -> Text
name CompiledPrimitive
p
              Maybe (Id, Text, [Declaration])
resM <- HasCallStack =>
Bool -> NetlistId -> NetlistMonad (Maybe (Id, Text, [Declaration]))
Bool -> NetlistId -> NetlistMonad (Maybe (Id, Text, [Declaration]))
resBndr1 Bool
True NetlistId
dst
              case Maybe (Id, Text, [Declaration])
resM of
                Just (dst' :: Id
dst',dstNm :: Text
dstNm,dstDecl :: [Declaration]
dstDecl) -> do
                  (bbCtx :: BlackBoxContext
bbCtx,ctxDcls :: [Declaration]
ctxDcls)   <- Text
-> Id
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext (PrimInfo -> Text
primName PrimInfo
pInfo) Id
dst' [Either Term Type]
args
                  (templ :: BlackBox
templ,templDecl :: [Declaration]
templDecl) <- Text
-> BlackBox
-> BlackBoxContext
-> NetlistMonad (BlackBox, [Declaration])
prepareBlackBox Text
pNm BlackBox
tempD BlackBoxContext
bbCtx
                  let bbDecl :: Declaration
bbDecl = Text
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> BlackBoxContext
-> Declaration
N.BlackBoxD Text
pNm (CompiledPrimitive -> [BlackBoxTemplate]
forall a b c d. Primitive a b c d -> [a]
libraries CompiledPrimitive
p) (CompiledPrimitive -> [BlackBoxTemplate]
forall a b c d. Primitive a b c d -> [a]
imports CompiledPrimitive
p)
                                           (CompiledPrimitive -> [((Text, Text), BlackBox)]
forall a b c d. Primitive a b c d -> [((Text, Text), b)]
includes CompiledPrimitive
p) BlackBox
templ BlackBoxContext
bbCtx
                  (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text -> Maybe Modifier -> Expr
Identifier Text
dstNm Maybe Modifier
forall a. Maybe a
Nothing,[Declaration]
dstDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
ctxDcls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
templDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
bbDecl])

                -- Render declarations as a Noop when requested
                Nothing | RenderVoid
RenderVoid <- CompiledPrimitive -> RenderVoid
forall a b c d. Primitive a b c d -> RenderVoid
renderVoid CompiledPrimitive
p -> do
                  let dst1 :: Id
dst1 = Type -> Name Term -> Id
mkLocalId Type
ty (Text -> Int -> Name Term
forall a. Text -> Int -> Name a
mkUnsafeSystemName "__VOID_TDECL_NOOP__" 0)
                  (bbCtx :: BlackBoxContext
bbCtx,ctxDcls :: [Declaration]
ctxDcls) <- Text
-> Id
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext (PrimInfo -> Text
primName PrimInfo
pInfo) Id
dst1 [Either Term Type]
args
                  (templ :: BlackBox
templ,templDecl :: [Declaration]
templDecl) <- Text
-> BlackBox
-> BlackBoxContext
-> NetlistMonad (BlackBox, [Declaration])
prepareBlackBox Text
pNm BlackBox
tempD BlackBoxContext
bbCtx
                  let bbDecl :: Declaration
bbDecl = Text
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> BlackBoxContext
-> Declaration
N.BlackBoxD Text
pNm (CompiledPrimitive -> [BlackBoxTemplate]
forall a b c d. Primitive a b c d -> [a]
libraries CompiledPrimitive
p) (CompiledPrimitive -> [BlackBoxTemplate]
forall a b c d. Primitive a b c d -> [a]
imports CompiledPrimitive
p)
                                           (CompiledPrimitive -> [((Text, Text), BlackBox)]
forall a b c d. Primitive a b c d -> [((Text, Text), b)]
includes CompiledPrimitive
p) BlackBox
templ BlackBoxContext
bbCtx
                  (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
Noop, [Declaration]
ctxDcls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
templDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
bbDecl])

                -- Otherwise don't render them
                Nothing -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
Noop,[])
            TExpr -> do
              let tempE :: BlackBox
tempE = CompiledPrimitive -> BlackBox
forall a b c d. Primitive a b c d -> b
template CompiledPrimitive
p
                  pNm :: Text
pNm = CompiledPrimitive -> Text
forall a b c d. Primitive a b c d -> Text
name CompiledPrimitive
p
              if Bool
bbEasD
                then do
                  Maybe (Id, Text, [Declaration])
resM <- HasCallStack =>
Bool -> NetlistId -> NetlistMonad (Maybe (Id, Text, [Declaration]))
Bool -> NetlistId -> NetlistMonad (Maybe (Id, Text, [Declaration]))
resBndr1 Bool
True NetlistId
dst
                  case Maybe (Id, Text, [Declaration])
resM of
                    Just (dst' :: Id
dst',dstNm :: Text
dstNm,dstDecl :: [Declaration]
dstDecl) -> do
                      (bbCtx :: BlackBoxContext
bbCtx,ctxDcls :: [Declaration]
ctxDcls)     <- Text
-> Id
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext (PrimInfo -> Text
primName PrimInfo
pInfo) Id
dst' [Either Term Type]
args
                      (bbTempl :: BlackBox
bbTempl,templDecl :: [Declaration]
templDecl) <- Text
-> BlackBox
-> BlackBoxContext
-> NetlistMonad (BlackBox, [Declaration])
prepareBlackBox Text
pNm BlackBox
tempE BlackBoxContext
bbCtx
                      let tmpAssgn :: Declaration
tmpAssgn = Text -> Expr -> Declaration
Assignment Text
dstNm
                                        (Text
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> BlackBoxContext
-> Bool
-> Expr
BlackBoxE Text
pNm (CompiledPrimitive -> [BlackBoxTemplate]
forall a b c d. Primitive a b c d -> [a]
libraries CompiledPrimitive
p) (CompiledPrimitive -> [BlackBoxTemplate]
forall a b c d. Primitive a b c d -> [a]
imports CompiledPrimitive
p)
                                                   (CompiledPrimitive -> [((Text, Text), BlackBox)]
forall a b c d. Primitive a b c d -> [((Text, Text), b)]
includes CompiledPrimitive
p) BlackBox
bbTempl BlackBoxContext
bbCtx
                                                   Bool
bbEParen)
                      (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text -> Maybe Modifier -> Expr
Identifier Text
dstNm Maybe Modifier
forall a. Maybe a
Nothing, [Declaration]
dstDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
ctxDcls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
templDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
tmpAssgn])

                    -- Render expression as a Noop when requested
                    Nothing | RenderVoid
RenderVoid <- CompiledPrimitive -> RenderVoid
forall a b c d. Primitive a b c d -> RenderVoid
renderVoid CompiledPrimitive
p -> do
                      let dst1 :: Id
dst1 = Type -> Name Term -> Id
mkLocalId Type
ty (Text -> Int -> Name Term
forall a. Text -> Int -> Name a
mkUnsafeSystemName "__VOID_TEXPRD_NOOP__" 0)
                      (bbCtx :: BlackBoxContext
bbCtx,ctxDcls :: [Declaration]
ctxDcls) <- Text
-> Id
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext (PrimInfo -> Text
primName PrimInfo
pInfo) Id
dst1 [Either Term Type]
args
                      (templ :: BlackBox
templ,templDecl :: [Declaration]
templDecl) <- Text
-> BlackBox
-> BlackBoxContext
-> NetlistMonad (BlackBox, [Declaration])
prepareBlackBox Text
pNm BlackBox
tempE BlackBoxContext
bbCtx
                      let bbDecl :: Declaration
bbDecl = Text
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> BlackBoxContext
-> Declaration
N.BlackBoxD Text
pNm (CompiledPrimitive -> [BlackBoxTemplate]
forall a b c d. Primitive a b c d -> [a]
libraries CompiledPrimitive
p) (CompiledPrimitive -> [BlackBoxTemplate]
forall a b c d. Primitive a b c d -> [a]
imports CompiledPrimitive
p)
                                               (CompiledPrimitive -> [((Text, Text), BlackBox)]
forall a b c d. Primitive a b c d -> [((Text, Text), b)]
includes CompiledPrimitive
p) BlackBox
templ BlackBoxContext
bbCtx
                      (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
Noop, [Declaration]
ctxDcls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
templDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
bbDecl])

                    -- Otherwise don't render them
                    Nothing -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text -> Maybe Modifier -> Expr
Identifier "__VOID_TEXPRD__" Maybe Modifier
forall a. Maybe a
Nothing,[])
                else do
                  Maybe (Id, Text, [Declaration])
resM <- HasCallStack =>
Bool -> NetlistId -> NetlistMonad (Maybe (Id, Text, [Declaration]))
Bool -> NetlistId -> NetlistMonad (Maybe (Id, Text, [Declaration]))
resBndr1 Bool
False NetlistId
dst
                  case Maybe (Id, Text, [Declaration])
resM of
                    Just (dst' :: Id
dst',_,_) -> do
                      (bbCtx :: BlackBoxContext
bbCtx,ctxDcls :: [Declaration]
ctxDcls)      <- Text
-> Id
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext (PrimInfo -> Text
primName PrimInfo
pInfo) Id
dst' [Either Term Type]
args
                      (bbTempl :: BlackBox
bbTempl,templDecl0 :: [Declaration]
templDecl0) <- Text
-> BlackBox
-> BlackBoxContext
-> NetlistMonad (BlackBox, [Declaration])
prepareBlackBox Text
pNm BlackBox
tempE BlackBoxContext
bbCtx
                      let templDecl1 :: [Declaration]
templDecl1 = case PrimInfo -> Text
primName PrimInfo
pInfo of
                            "Clash.Sized.Internal.BitVector.fromInteger#"
                              | [N.Literal _ (NumLit _), N.Literal _ _, N.Literal _ _] <- BlackBoxContext -> [Expr]
extractLiterals BlackBoxContext
bbCtx -> []
                            "Clash.Sized.Internal.BitVector.fromInteger##"
                              | [N.Literal _ _, N.Literal _ _] <- BlackBoxContext -> [Expr]
extractLiterals BlackBoxContext
bbCtx -> []
                            "Clash.Sized.Internal.Index.fromInteger#"
                              | [N.Literal _ (NumLit _), N.Literal _ _] <- BlackBoxContext -> [Expr]
extractLiterals BlackBoxContext
bbCtx -> []
                            "Clash.Sized.Internal.Signed.fromInteger#"
                              | [N.Literal _ (NumLit _), N.Literal _ _] <- BlackBoxContext -> [Expr]
extractLiterals BlackBoxContext
bbCtx -> []
                            "Clash.Sized.Internal.Unsigned.fromInteger#"
                              | [N.Literal _ (NumLit _), N.Literal _ _] <- BlackBoxContext -> [Expr]
extractLiterals BlackBoxContext
bbCtx -> []
                            _ -> [Declaration]
templDecl0
                      (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> BlackBoxContext
-> Bool
-> Expr
BlackBoxE Text
pNm (CompiledPrimitive -> [BlackBoxTemplate]
forall a b c d. Primitive a b c d -> [a]
libraries CompiledPrimitive
p) (CompiledPrimitive -> [BlackBoxTemplate]
forall a b c d. Primitive a b c d -> [a]
imports CompiledPrimitive
p) (CompiledPrimitive -> [((Text, Text), BlackBox)]
forall a b c d. Primitive a b c d -> [((Text, Text), b)]
includes CompiledPrimitive
p) BlackBox
bbTempl BlackBoxContext
bbCtx Bool
bbEParen,[Declaration]
ctxDcls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
templDecl1)
                    -- Render expression as a Noop when requested
                    Nothing | RenderVoid
RenderVoid <- CompiledPrimitive -> RenderVoid
forall a b c d. Primitive a b c d -> RenderVoid
renderVoid CompiledPrimitive
p -> do
                      let dst1 :: Id
dst1 = Type -> Name Term -> Id
mkLocalId Type
ty (Text -> Int -> Name Term
forall a. Text -> Int -> Name a
mkUnsafeSystemName "__VOID_TEXPRE_NOOP__" 0)
                      (bbCtx :: BlackBoxContext
bbCtx,ctxDcls :: [Declaration]
ctxDcls) <- Text
-> Id
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext (PrimInfo -> Text
primName PrimInfo
pInfo) Id
dst1 [Either Term Type]
args
                      (templ :: BlackBox
templ,templDecl :: [Declaration]
templDecl) <- Text
-> BlackBox
-> BlackBoxContext
-> NetlistMonad (BlackBox, [Declaration])
prepareBlackBox Text
pNm BlackBox
tempE BlackBoxContext
bbCtx
                      let bbDecl :: Declaration
bbDecl = Text
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> BlackBoxContext
-> Declaration
N.BlackBoxD Text
pNm (CompiledPrimitive -> [BlackBoxTemplate]
forall a b c d. Primitive a b c d -> [a]
libraries CompiledPrimitive
p) (CompiledPrimitive -> [BlackBoxTemplate]
forall a b c d. Primitive a b c d -> [a]
imports CompiledPrimitive
p)
                                               (CompiledPrimitive -> [((Text, Text), BlackBox)]
forall a b c d. Primitive a b c d -> [((Text, Text), b)]
includes CompiledPrimitive
p) BlackBox
templ BlackBoxContext
bbCtx
                      (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
Noop, [Declaration]
ctxDcls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
templDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
bbDecl])

                    -- Otherwise don't render them
                    Nothing -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text -> Maybe Modifier -> Expr
Identifier "__VOID__" Maybe Modifier
forall a. Maybe a
Nothing,[])
        P.Primitive pNm :: Text
pNm _ _
          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "GHC.Prim.tagToEnum#" -> do
              HWType
hwTy <- String -> Type -> NetlistMonad HWType
N.unsafeCoreTypeToHWTypeM' $(curLoc) Type
ty
              case [Either Term Type]
args of
                [Right (ConstTy (TyCon tcN :: TyConName
tcN)), Left (C.Literal (IntLiteral i :: Integer
i))] -> 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 dcs :: [DataCon]
dcs = TyCon -> [DataCon]
tyConDataCons (TyConMap
tcm TyConMap -> TyConName -> TyCon
forall a b. (HasCallStack, Uniquable a) => UniqMap b -> a -> b
`lookupUniqMap'` TyConName
tcN)
                      dc :: DataCon
dc  = [DataCon]
dcs [DataCon] -> Int -> DataCon
forall a. [a] -> Int -> a
!! Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i
                  (exprN :: Expr
exprN,dcDecls :: [Declaration]
dcDecls) <- HasCallStack =>
[HWType]
-> NetlistId
-> DataCon
-> [Term]
-> NetlistMonad (Expr, [Declaration])
[HWType]
-> NetlistId
-> DataCon
-> [Term]
-> NetlistMonad (Expr, [Declaration])
mkDcApplication [HWType
hwTy] NetlistId
dst DataCon
dc []
                  (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
exprN,[Declaration]
dcDecls)
                [Right _, Left scrut :: Term
scrut] -> 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
                  (scrutExpr :: Expr
scrutExpr,scrutDecls :: [Declaration]
scrutDecls) <-
                    HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Concurrent (Text -> Type -> NetlistId
NetlistId "c$tte_rhs" Type
scrutTy) Term
scrut
                  case Expr
scrutExpr of
                    Identifier id_ :: Text
id_ Nothing -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Either Text Text -> Expr
DataTag HWType
hwTy (Text -> Either Text Text
forall a b. a -> Either a b
Left Text
id_),[Declaration]
scrutDecls)
                    _ -> do
                      HWType
scrutHTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(curLoc) Type
scrutTy
                      Text
tmpRhs <- IdType -> Text -> NetlistMonad Text
mkUniqueIdentifier IdType
Extended "c$tte_rhs"
                      let netDeclRhs :: Declaration
netDeclRhs   = Maybe Text -> Text -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Text
tmpRhs HWType
scrutHTy
                          netAssignRhs :: Declaration
netAssignRhs = Text -> Expr -> Declaration
Assignment Text
tmpRhs Expr
scrutExpr
                      (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Either Text Text -> Expr
DataTag HWType
hwTy (Text -> Either Text Text
forall a b. a -> Either a b
Left Text
tmpRhs),[Declaration
netDeclRhs,Declaration
netAssignRhs] [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
scrutDecls)
                _ -> 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]
++ "tagToEnum: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show ((Either Term Type -> String) -> [Either Term Type] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> String) -> (Type -> String) -> Either Term Type -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Term -> String
forall p. PrettyPrec p => p -> String
showPpr Type -> String
forall p. PrettyPrec p => p -> String
showPpr) [Either Term Type]
args)
          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "GHC.Prim.dataToTag#" -> case [Either Term Type]
args of
              [Right _,Left (Data dc :: DataCon
dc)] -> 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
                (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (HWType, Int) -> Literal -> Expr
N.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
Signed Int
iw,Int
iw)) (Integer -> Literal
NumLit (Integer -> Literal) -> Integer -> Literal
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ DataCon -> Int
dcTag DataCon
dc Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1),[])
              [Right _,Left scrut :: Term
scrut] -> 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
                (scrutExpr :: Expr
scrutExpr,scrutDecls :: [Declaration]
scrutDecls) <-
                  HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Concurrent (Text -> Type -> NetlistId
NetlistId "c$dtt_rhs" Type
scrutTy) Term
scrut
                case Expr
scrutExpr of
                  Identifier id_ :: Text
id_ Nothing -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Either Text Text -> Expr
DataTag HWType
scrutHTy (Text -> Either Text Text
forall a b. b -> Either a b
Right Text
id_),[Declaration]
scrutDecls)
                  _ -> do
                    Text
tmpRhs  <- IdType -> Text -> NetlistMonad Text
mkUniqueIdentifier IdType
Extended "c$dtt_rhs"
                    let netDeclRhs :: Declaration
netDeclRhs   = Maybe Text -> Text -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Text
tmpRhs HWType
scrutHTy
                        netAssignRhs :: Declaration
netAssignRhs = Text -> Expr -> Declaration
Assignment Text
tmpRhs Expr
scrutExpr
                    (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Either Text Text -> Expr
DataTag HWType
scrutHTy (Text -> Either Text Text
forall a b. b -> Either a b
Right Text
tmpRhs),[Declaration
netDeclRhs,Declaration
netAssignRhs] [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
scrutDecls)
              _ -> 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]
++ "dataToTag: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show ((Either Term Type -> String) -> [Either Term Type] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> String) -> (Type -> String) -> Either Term Type -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Term -> String
forall p. PrettyPrec p => p -> String
showPpr Type -> String
forall p. PrettyPrec p => p -> String
showPpr) [Either Term Type]
args)

          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Explicit.SimIO.mealyIO" -> do
              Maybe (Id, Text, [Declaration])
resM <- HasCallStack =>
Bool -> NetlistId -> NetlistMonad (Maybe (Id, Text, [Declaration]))
Bool -> NetlistId -> NetlistMonad (Maybe (Id, Text, [Declaration]))
resBndr1 Bool
True NetlistId
dst
              case Maybe (Id, Text, [Declaration])
resM of
                Just (_,dstNm :: Text
dstNm,dstDecl :: [Declaration]
dstDecl) -> 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
                  [Declaration]
mealyDecls <- HasCallStack =>
Text
-> NetlistId -> TyConMap -> [Term] -> NetlistMonad [Declaration]
Text
-> NetlistId -> TyConMap -> [Term] -> NetlistMonad [Declaration]
collectMealy Text
dstNm NetlistId
dst TyConMap
tcm ([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args)
                  (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
Noop, [Declaration]
dstDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
mealyDecls)
                Nothing -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
Noop,[])

          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Explicit.SimIO.bindSimIO#" ->
              NetlistId -> [Term] -> NetlistMonad (Expr, [Declaration])
collectBindIO NetlistId
dst ([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args)

          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Explicit.SimIO.apSimIO#" -> do
              NetlistId -> [Term] -> [Term] -> NetlistMonad (Expr, [Declaration])
collectAppIO NetlistId
dst ([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args) []

          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Explicit.SimIO.fmapSimIO#" -> do
              Maybe (Id, Text, [Declaration])
resM <- HasCallStack =>
Bool -> NetlistId -> NetlistMonad (Maybe (Id, Text, [Declaration]))
Bool -> NetlistId -> NetlistMonad (Maybe (Id, Text, [Declaration]))
resBndr1 Bool
True NetlistId
dst
              case Maybe (Id, Text, [Declaration])
resM of
                Just (_,dstNm :: Text
dstNm,dstDecl :: [Declaration]
dstDecl) -> 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 (fun0 :: Term
fun0:arg0 :: Term
arg0:_) = [Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args
                      arg1 :: Term
arg1 = TyConMap -> Term -> Term
unSimIO TyConMap
tcm Term
arg0
                      fun1 :: Term
fun1 = case Term
fun0 of
                        Lam b :: Id
b bE :: Term
bE ->
                          let is0 :: InScopeSet
is0 = VarSet -> InScopeSet
mkInScopeSet (Getting VarSet Term Id -> (Id -> VarSet) -> Term -> VarSet
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting VarSet Term Id
Fold Term Id
freeIds Id -> VarSet
forall a. Var a -> VarSet
unitVarSet Term
fun0)
                              subst :: Subst
subst = Subst -> Id -> Term -> Subst
extendIdSubst (InScopeSet -> Subst
mkSubst InScopeSet
is0) Id
b Term
arg1
                          in  HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm "mkPrimitive.fmapSimIO" Subst
subst Term
bE
                        _ -> Term -> [Either Term Type] -> Term
mkApps Term
fun0 [Term -> Either Term Type
forall a b. a -> Either a b
Left Term
arg1]
                  (expr :: Expr
expr,bindDecls :: [Declaration]
bindDecls) <- HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Sequential NetlistId
dst Term
fun1
                  let assn :: [Declaration]
assn = case Expr
expr of
                               Noop -> []
                               _ -> [Text -> Expr -> Declaration
Assignment Text
dstNm Expr
expr]
                  (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text -> Maybe Modifier -> Expr
Identifier Text
dstNm Maybe Modifier
forall a. Maybe a
Nothing, [Declaration]
dstDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
bindDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
assn)
                Nothing -> do
                  let (_:arg0 :: Term
arg0:_) = [Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args
                  (_,bindDecls :: [Declaration]
bindDecls) <- HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
True DeclarationType
Sequential NetlistId
dst Term
arg0
                  (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
Noop, [Declaration]
bindDecls)

          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Explicit.SimIO.unSimIO#" ->
              HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Sequential NetlistId
dst ([Term] -> Term
forall a. [a] -> a
head ([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args))

          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Explicit.SimIO.pureSimIO#" -> do
              (expr :: Expr
expr,decls :: [Declaration]
decls) <- HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Sequential NetlistId
dst ([Term] -> Term
forall a. [a] -> a
head ([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args))
              Maybe ([Id], [Text], [Declaration])
resM <- Bool
-> NetlistId -> NetlistMonad (Maybe ([Id], [Text], [Declaration]))
resBndr Bool
True NetlistId
dst
              case Maybe ([Id], [Text], [Declaration])
resM of
                Just (_,dstNms :: [Text]
dstNms,dstDecl :: [Declaration]
dstDecl) -> case Expr
expr of
                  Noop ->
                    (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
Noop,[Declaration]
decls)
                  _ -> case [Text]
dstNms of
                    [dstNm :: Text
dstNm] ->
                      (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ( Text -> Maybe Modifier -> Expr
Identifier Text
dstNm Maybe Modifier
forall a. Maybe a
Nothing
                             , [Declaration]
dstDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
decls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Text -> Expr -> Declaration
Assignment Text
dstNm Expr
expr])
                    _ -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error "internal error"
                _ ->
                  (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
Noop,[Declaration]
decls)

          | Bool
otherwise ->
              (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> BlackBoxContext
-> Bool
-> Expr
BlackBoxE "" [] [] []
                        (BlackBoxTemplate -> BlackBox
BBTemplate [Text -> Element
Text (Text -> Element) -> Text -> Element
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ["NO_TRANSLATION_FOR:",Text -> Text
fromStrict Text
pNm]])
                        (Text -> BlackBoxContext
emptyBBContext Text
pNm) Bool
False,[])

    -- Do we need to create a new identifier to assign the result?
    --
    -- CoreId: No, this is an original LHS of a let-binder, and already has a
    --         corresponding NetDecl; unlike NetlistIds, it is not already
    --         assigned, it will be assigned by the BlackBox/Primitive.
    --
    -- NetlistId: This is a derived (either from an CoreId or other NetlistId)
    --            identifier created in the NetlistMonad that's already being
    --            used in an assignment, i.e. we cannot assign it again.
    --
    --            So if it is a declaration BlackBox (indicated by 'mkDec'),
    --            we will have to create a new NetlistId, create a NetDecl for
    --            it, and use this new NetlistId for the assignment inside the
    --            declaration BlackBox
    --
    -- MultiId: This is like a CoreId, but it's split over multiple identifiers
    --          because it was originally of a product type where the element
    --          types should not be part of an aggregate type in the generated
    --          HDL (e.g. Clocks should not be part of an aggregate, because
    --          tools like verilator don't like it)
    resBndr
      :: Bool
      -- Do we need to create and declare a new identifier in case we're given
      -- a NetlistId?
      -> NetlistId
      -- CoreId/NetlistId/MultiId
      -> NetlistMonad (Maybe ([Id],[Identifier],[Declaration]))
      -- Nothing when the binder would have type `Void`
    resBndr :: Bool
-> NetlistId -> NetlistMonad (Maybe ([Id], [Text], [Declaration]))
resBndr mkDec :: Bool
mkDec dst' :: NetlistId
dst' = do
      HWType
resHwTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(curLoc) Type
ty
      if HWType -> Bool
isVoid HWType
resHwTy then
        Maybe ([Id], [Text], [Declaration])
-> NetlistMonad (Maybe ([Id], [Text], [Declaration]))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe ([Id], [Text], [Declaration])
forall a. Maybe a
Nothing
      else
        case NetlistId
dst' of
          NetlistId dstL :: Text
dstL _ -> case Bool
mkDec of
            False -> do
              -- TODO: check that it's okay to use `mkUnsafeSystemName`
              let nm' :: Name a
nm' = Text -> Int -> Name a
forall a. Text -> Int -> Name a
mkUnsafeSystemName Text
dstL 0
                  id_ :: Id
id_ = Type -> Name Term -> Id
mkLocalId Type
ty Name Term
forall a. Name a
nm'
              Maybe ([Id], [Text], [Declaration])
-> NetlistMonad (Maybe ([Id], [Text], [Declaration]))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (([Id], [Text], [Declaration])
-> Maybe ([Id], [Text], [Declaration])
forall a. a -> Maybe a
Just ([Id
id_],[Text
dstL],[]))
            True -> do
              Text
nm1 <- IdType -> Text -> Text -> NetlistMonad Text
extendIdentifier IdType
Extended Text
dstL "_res"
              Text
nm2 <- IdType -> Text -> NetlistMonad Text
mkUniqueIdentifier IdType
Extended Text
nm1
              -- TODO: check that it's okay to use `mkUnsafeInternalName`
              let nm3 :: Name a
nm3 = Text -> Int -> Name a
forall a. Text -> Int -> Name a
mkUnsafeSystemName Text
nm2 0
                  id_ :: Id
id_ = Type -> Name Term -> Id
mkLocalId Type
ty Name Term
forall a. Name a
nm3
              Maybe Declaration
idDeclM <- LetBinding -> NetlistMonad (Maybe Declaration)
mkNetDecl (Id
id_,Term -> [Either Term Type] -> Term
mkApps (PrimInfo -> Term
Prim PrimInfo
pInfo) [Either Term Type]
args)
              case Maybe Declaration
idDeclM of
                Nothing     -> Maybe ([Id], [Text], [Declaration])
-> NetlistMonad (Maybe ([Id], [Text], [Declaration]))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe ([Id], [Text], [Declaration])
forall a. Maybe a
Nothing
                Just idDecl :: Declaration
idDecl -> Maybe ([Id], [Text], [Declaration])
-> NetlistMonad (Maybe ([Id], [Text], [Declaration]))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (([Id], [Text], [Declaration])
-> Maybe ([Id], [Text], [Declaration])
forall a. a -> Maybe a
Just ([Id
id_],[Text
nm2],[Declaration
idDecl]))
          CoreId dstR :: Id
dstR -> Maybe ([Id], [Text], [Declaration])
-> NetlistMonad (Maybe ([Id], [Text], [Declaration]))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (([Id], [Text], [Declaration])
-> Maybe ([Id], [Text], [Declaration])
forall a. a -> Maybe a
Just ([Id
dstR],[Name Term -> Text
forall a. Name a -> Text
nameOcc (Name Term -> Text) -> (Id -> Name Term) -> Id -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name Term
forall a. Var a -> Name a
varName (Id -> Text) -> Id -> Text
forall a b. (a -> b) -> a -> b
$ Id
dstR],[]))
          MultiId ids :: [Id]
ids -> Maybe ([Id], [Text], [Declaration])
-> NetlistMonad (Maybe ([Id], [Text], [Declaration]))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (([Id], [Text], [Declaration])
-> Maybe ([Id], [Text], [Declaration])
forall a. a -> Maybe a
Just ([Id]
ids,(Id -> Text) -> [Id] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Name Term -> Text
forall a. Name a -> Text
nameOcc (Name Term -> Text) -> (Id -> Name Term) -> Id -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name Term
forall a. Var a -> Name a
varName) [Id]
ids,[]))

    -- Like resBndr, but fails on MultiId
    resBndr1
      :: HasCallStack
      => Bool
      -> NetlistId
      -> NetlistMonad (Maybe (Id,Identifier,[Declaration]))
    resBndr1 :: Bool -> NetlistId -> NetlistMonad (Maybe (Id, Text, [Declaration]))
resBndr1 mkDec :: Bool
mkDec dst' :: NetlistId
dst' = Bool
-> NetlistId -> NetlistMonad (Maybe ([Id], [Text], [Declaration]))
resBndr Bool
mkDec NetlistId
dst' NetlistMonad (Maybe ([Id], [Text], [Declaration]))
-> (Maybe ([Id], [Text], [Declaration])
    -> NetlistMonad (Maybe (Id, Text, [Declaration])))
-> NetlistMonad (Maybe (Id, Text, [Declaration]))
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Nothing -> Maybe (Id, Text, [Declaration])
-> NetlistMonad (Maybe (Id, Text, [Declaration]))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe (Id, Text, [Declaration])
forall a. Maybe a
Nothing
      Just ([id_ :: Id
id_],[nm_ :: Text
nm_],decls :: [Declaration]
decls) -> Maybe (Id, Text, [Declaration])
-> NetlistMonad (Maybe (Id, Text, [Declaration]))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Id, Text, [Declaration]) -> Maybe (Id, Text, [Declaration])
forall a. a -> Maybe a
Just (Id
id_,Text
nm_,[Declaration]
decls))
      _ -> String -> NetlistMonad (Maybe (Id, Text, [Declaration]))
forall a. HasCallStack => String -> a
error "internal error"

-- | Turn a 'mealyIO' expression into a two sequential processes, one "initial"
-- process for the starting state, and one clocked sequential process.
collectMealy
  :: HasCallStack
  => Identifier
  -- ^ Identifier to assign the final result to
  -> NetlistId
  -- ^ Id to assign the final result to
  -> TyConMap
  -> [Term]
  -- ^ The arguments to 'mealyIO'
  -> NetlistMonad [Declaration]
collectMealy :: Text
-> NetlistId -> TyConMap -> [Term] -> NetlistMonad [Declaration]
collectMealy dstNm :: Text
dstNm dst :: NetlistId
dst tcm :: TyConMap
tcm (kd :: Term
kd:clk :: Term
clk:mealyFun :: Term
mealyFun:mealyInit :: Term
mealyInit:mealyIn :: Term
mealyIn:_) = do
  let ([Either Id TyVar] -> [Id]
forall a b. [Either a b] -> [a]
lefts -> [Id]
args0,res0 :: Term
res0) = Term -> ([Either Id TyVar], Term)
collectBndrs Term
mealyFun
      is0 :: InScopeSet
is0 = VarSet -> InScopeSet
mkInScopeSet (Getting VarSet Term Id -> (Id -> VarSet) -> Term -> VarSet
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting VarSet Term Id
Fold Term Id
freeIds Id -> VarSet
forall a. Var a -> VarSet
unitVarSet Term
res0 VarSet -> VarSet -> VarSet
forall a. Semigroup a => a -> a -> a
<>
                          Getting VarSet Term Id -> (Id -> VarSet) -> Term -> VarSet
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting VarSet Term Id
Fold Term Id
freeIds Id -> VarSet
forall a. Var a -> VarSet
unitVarSet Term
mealyInit VarSet -> VarSet -> VarSet
forall a. Semigroup a => a -> a -> a
<>
                          Getting VarSet Term Id -> (Id -> VarSet) -> Term -> VarSet
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting VarSet Term Id
Fold Term Id
freeIds Id -> VarSet
forall a. Var a -> VarSet
unitVarSet Term
mealyIn)
      -- Given that we're creating a sequential list of statements from the
      -- let-bindings, make sure that everything is inverse topologically sorted
      (bs :: [LetBinding]
bs,res :: Id
res) = case HasCallStack => Term -> Term
Term -> Term
inverseTopSortLetBindings Term
res0 of
        Letrec bsN :: [LetBinding]
bsN (C.Var resN :: Id
resN) -> ([LetBinding]
bsN,Id
resN)
        Letrec bsN :: [LetBinding]
bsN e :: Term
e ->
          let u :: Id
u = case NetlistId
dst of
                    CoreId u0 :: Id
u0 -> Id
u0
                    _ -> InScopeSet -> Id -> Id
forall a. (Uniquable a, ClashPretty a) => InScopeSet -> a -> a
uniqAway InScopeSet
is0
                           (Type -> Name Term -> Id
mkLocalId (TyConMap -> Term -> Type
termType TyConMap
tcm Term
e)
                                      (Text -> Int -> Name Term
forall a. Text -> Int -> Name a
mkUnsafeSystemName "mealyres" 0))
          in  ([LetBinding]
bsN [LetBinding] -> [LetBinding] -> [LetBinding]
forall a. [a] -> [a] -> [a]
++ [(Id
u,Term
e)], Id
u)
        e :: Term
e ->
          let u :: Id
u = case NetlistId
dst of
                    CoreId u0 :: Id
u0 -> Id
u0
                    _ -> InScopeSet -> Id -> Id
forall a. (Uniquable a, ClashPretty a) => InScopeSet -> a -> a
uniqAway InScopeSet
is0
                           (Type -> Name Term -> Id
mkLocalId (TyConMap -> Term -> Type
termType TyConMap
tcm Term
e)
                                      (Text -> Int -> Name Term
forall a. Text -> Int -> Name a
mkUnsafeSystemName "mealyres" 0))
          in  ([(Id
u,Term
e)], Id
u)
      -- Drop the 'State# World' argument
      args1 :: [Id]
args1 = [Id] -> [Id]
forall a. [a] -> [a]
init [Id]
args0
      -- Take into account that the state argument is split over multiple
      -- binders because it contained types that are not allowed to occur in
      -- a HDL aggregate type
      mealyInitLength :: Int
mealyInitLength = [Type] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length (TyConMap -> [Type] -> [Type]
splitShouldSplit TyConMap
tcm [TyConMap -> Term -> Type
termType TyConMap
tcm Term
mealyInit])
      (sArgs :: [Id]
sArgs,iArgs :: [Id]
iArgs) = Int -> [Id] -> ([Id], [Id])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
mealyInitLength [Id]
args1
  -- Give all binders a unique name
  ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
 [Declaration], [LetBinding], Maybe Id)
normE <- HasCallStack =>
InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
      [Declaration], [LetBinding], Maybe Id)
InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
      [Declaration], [LetBinding], Maybe Id)
mkUniqueNormalized InScopeSet
is0
             (Maybe TopEntity -> Maybe (Maybe TopEntity)
forall a. a -> Maybe a
Just (TopEntity -> Maybe TopEntity
forall a. a -> Maybe a
Just (String -> [PortName] -> PortName -> TopEntity
Synthesize "" [] (String -> PortName
PortName ""))))
             ([],(Id -> LetBinding) -> [Id] -> [LetBinding]
forall a b. (a -> b) -> [a] -> [b]
map (,Term
mealyInit) [Id]
sArgs [LetBinding] -> [LetBinding] -> [LetBinding]
forall a. [a] -> [a] -> [a]
++ (Id -> LetBinding) -> [Id] -> [LetBinding]
forall a b. (a -> b) -> [a] -> [b]
map (,Term
mealyIn) [Id]
iArgs [LetBinding] -> [LetBinding] -> [LetBinding]
forall a. [a] -> [a] -> [a]
++ [LetBinding]
bs,Id
res)
  case ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
 [Declaration], [LetBinding], Maybe Id)
normE of
    -- We're not expecting any input or output wrappers
    (_,[],[],_,[],binders0 :: [LetBinding]
binders0,Just result :: Id
result) -> do
      let (sBinders :: [LetBinding]
sBinders,binders1 :: [LetBinding]
binders1) = Int -> [LetBinding] -> ([LetBinding], [LetBinding])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Id] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Id]
sArgs) [LetBinding]
binders0
          (iBinders :: [LetBinding]
iBinders,binders2 :: [LetBinding]
binders2) = Int -> [LetBinding] -> ([LetBinding], [LetBinding])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Id] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Id]
iArgs) [LetBinding]
binders1
          -- Get all the "original" let-bindings, without the above "mealyres".
          -- We don't want to make a NetDecl for it.
          bindersN :: [LetBinding]
bindersN = case Term
res0 of
            Letrec _ (C.Var {}) -> [LetBinding]
binders2
            _                   -> [LetBinding] -> [LetBinding]
forall a. [a] -> [a]
init [LetBinding]
binders2

      -- Create new net declarations for state-binders, input-binders, and all
      -- the "original" let-bindings in 'mealyFun'
      --
      -- The first set is only assigned in the always block, so they must be
      -- 'reg' in Verilog terminology
      [Declaration]
netDeclsSeq <- ([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 ((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]
sBinders [LetBinding] -> [LetBinding] -> [LetBinding]
forall a. [a] -> [a] -> [a]
++ [LetBinding]
bindersN))
      -- The second set is assigned using concurrent assignment, so don't need
      -- to be 'reg'
      [Declaration]
netDeclsInp <- ([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 ((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]
iBinders)

      -- If the 'mealyFun' was not a let-expression with a variable reference
      -- as a body then we used the LHS of the entire 'mealyIO' expression as
      -- a new let-binding; otherwise 'mkUniqueNormalized' would not work.
      --
      -- However, 'mkUniqueNormalized' made a new unique name for that LHS,
      -- which is not what we want. We want to assign the last expression to the
      -- LHS of 'mealyIO'.
      let bindersE :: [LetBinding]
bindersE = case Term
res0 of
                        Letrec _ (C.Var {}) -> [LetBinding]
binders2
                        _ -> case NetlistId
dst of
                          -- See above why we do this.
                          CoreId u0 :: Id
u0 -> [LetBinding] -> [LetBinding]
forall a. [a] -> [a]
init [LetBinding]
binders2 [LetBinding] -> [LetBinding] -> [LetBinding]
forall a. [a] -> [a] -> [a]
++ [(Id
u0,LetBinding -> Term
forall a b. (a, b) -> b
snd ([LetBinding] -> LetBinding
forall a. [a] -> a
last [LetBinding]
binders2))]
                          _ -> [LetBinding]
binders2
      [Declaration]
seqDecls <- [[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 =>
DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
mkDeclarations' DeclarationType
Sequential)) [LetBinding]
bindersE

      -- When the body the let-expression of 'mealyFun' was variable reference,
      -- or in case we had to create a new identifier because the original LHS
      -- was not available: then we need to assign
      (resExpr :: Expr
resExpr,resDecls :: [Declaration]
resDecls) <- case Term
res0 of
        Letrec _ (C.Var {}) -> HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Concurrent NetlistId
dst (Id -> Term
C.Var Id
result)
        _ -> case NetlistId
dst of
          CoreId {} -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Expr
Noop,[])
          _ -> HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Concurrent NetlistId
dst (Id -> Term
C.Var Id
result)
      let resAssn :: [Declaration]
resAssn = case Expr
resExpr of
            Noop -> []
            _ -> [[Seq] -> Declaration
Seq [[Seq] -> Seq
AlwaysComb [Declaration -> Seq
SeqDecl (Text -> Expr -> Declaration
Assignment Text
dstNm Expr
resExpr)]]]

      -- Create the declarations for the "initial state" block
      let sDst :: NetlistId
sDst = case [LetBinding]
sBinders of
                   [(b :: Id
b,_)] -> Id -> NetlistId
CoreId Id
b
                   _       -> [Id] -> NetlistId
MultiId ((LetBinding -> Id) -> [LetBinding] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map LetBinding -> Id
forall a b. (a, b) -> a
fst [LetBinding]
sBinders)
      (exprInit :: Expr
exprInit,initDecls :: [Declaration]
initDecls) <- HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Sequential NetlistId
sDst Term
mealyInit
      let initAssign :: [Declaration]
initAssign = case Expr
exprInit of
            Identifier _ Nothing -> []
            Noop -> []
            _ -> [Text -> Expr -> Declaration
Assignment (Id -> Text
id2identifier (LetBinding -> Id
forall a b. (a, b) -> a
fst ([LetBinding] -> LetBinding
forall a. [a] -> a
head [LetBinding]
sBinders))) Expr
exprInit]

      -- Create the declarations that corresponding to the input
      let iDst :: NetlistId
iDst = case [LetBinding]
iBinders of
                   [(b :: Id
b,_)] -> Id -> NetlistId
CoreId Id
b
                   _       -> [Id] -> NetlistId
MultiId ((LetBinding -> Id) -> [LetBinding] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map LetBinding -> Id
forall a b. (a, b) -> a
fst [LetBinding]
iBinders)
      (exprArg :: Expr
exprArg,inpDeclsMisc :: [Declaration]
inpDeclsMisc) <- HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Concurrent NetlistId
iDst Term
mealyIn

      -- Split netdecl declarations and other declarations
      let (netDeclsSeqMisc :: [Declaration]
netDeclsSeqMisc,seqDeclsOther :: [Declaration]
seqDeclsOther) = (Declaration -> Bool)
-> [Declaration] -> ([Declaration], [Declaration])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Declaration -> Bool
isNet ([Declaration]
seqDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
resDecls)
          (netDeclsInit :: [Declaration]
netDeclsInit,initDeclsOther :: [Declaration]
initDeclsOther)   = (Declaration -> Bool)
-> [Declaration] -> ([Declaration], [Declaration])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Declaration -> Bool
isNet [Declaration]
initDecls
      -- All assignments happens within a sequential block, so the nets need to
      -- be of type 'reg' in Verilog nomenclature
      let netDeclsSeq1 :: [Declaration]
netDeclsSeq1 = (Declaration -> Declaration) -> [Declaration] -> [Declaration]
forall a b. (a -> b) -> [a] -> [b]
map Declaration -> Declaration
toReg ([Declaration]
netDeclsSeq [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
netDeclsSeqMisc [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
netDeclsInit)

      -- We run mealy block in the opposite clock edge of the the ambient system
      -- because we're basically clocked logic; so we need to have our outputs
      -- ready before the ambient system starts sampling them. The clockGen code
      -- ensures that the "opposite" edge always comes first.
      FilteredHWType
kdTy <- String -> Type -> NetlistMonad FilteredHWType
unsafeCoreTypeToHWTypeM $(curLoc) (TyConMap -> Term -> Type
termType TyConMap
tcm Term
kd)
      let edge :: ActiveEdge
edge = case HWType -> HWType
stripVoid (FilteredHWType -> HWType
stripFiltered FilteredHWType
kdTy) of
                   KnownDomain _ _ Rising _ _ _  -> ActiveEdge
Falling
                   KnownDomain _ _ Falling _ _ _ -> ActiveEdge
Rising
                   _ -> String -> ActiveEdge
forall a. HasCallStack => String -> a
error "internal error"
      (clkExpr :: Expr
clkExpr,clkDecls :: [Declaration]
clkDecls) <-
        HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Concurrent (Text -> Type -> NetlistId
NetlistId "__MEALY_CLK__" (TyConMap -> Term -> Type
termType TyConMap
tcm Term
clk)) Term
clk

      -- collect the declarations related to the input
      let netDeclsInp1 :: [Declaration]
netDeclsInp1 = [Declaration]
netDeclsInp [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
inpDeclsMisc

      -- Collate everything
      [Declaration] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Declaration]
clkDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
netDeclsSeq1 [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
netDeclsInp1 [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++
                [ Text -> Expr -> Declaration
Assignment (Id -> Text
id2identifier (LetBinding -> Id
forall a b. (a, b) -> a
fst ([LetBinding] -> LetBinding
forall a. [a] -> a
head [LetBinding]
iBinders))) Expr
exprArg
                , [Seq] -> Declaration
Seq [[Seq] -> Seq
Initial ((Declaration -> Seq) -> [Declaration] -> [Seq]
forall a b. (a -> b) -> [a] -> [b]
map Declaration -> Seq
SeqDecl ([Declaration]
initDeclsOther [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
initAssign))]
                , [Seq] -> Declaration
Seq [ActiveEdge -> Expr -> [Seq] -> Seq
AlwaysClocked ActiveEdge
edge Expr
clkExpr ((Declaration -> Seq) -> [Declaration] -> [Seq]
forall a b. (a -> b) -> [a] -> [b]
map Declaration -> Seq
SeqDecl [Declaration]
seqDeclsOther)]
                ] [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
resAssn)
    _ -> String -> NetlistMonad [Declaration]
forall a. HasCallStack => String -> a
error "internal error"
 where
  isNet :: Declaration -> Bool
isNet NetDecl' {} = Bool
True
  isNet _ = Bool
False

  toReg :: Declaration -> Declaration
toReg (NetDecl' cmM :: Maybe Text
cmM _ r :: Text
r ty :: Either Text HWType
ty eM :: Maybe Expr
eM) = Maybe Text
-> WireOrReg
-> Text
-> Either Text HWType
-> Maybe Expr
-> Declaration
NetDecl' Maybe Text
cmM WireOrReg
Reg Text
r Either Text HWType
ty Maybe Expr
eM
  toReg d :: Declaration
d = Declaration
d

collectMealy _ _ _ _ = String -> NetlistMonad [Declaration]
forall a. HasCallStack => String -> a
error "internal error"

-- | Collect the sequential declarations for 'bindIO'
collectBindIO :: NetlistId -> [Term] -> NetlistMonad (Expr,[Declaration])
collectBindIO :: NetlistId -> [Term] -> NetlistMonad (Expr, [Declaration])
collectBindIO dst :: NetlistId
dst (m :: Term
m:Lam x :: Id
x q :: Term
q@(Lam _ e :: Term
e):_) = 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
  [Declaration]
ds0 <- TyConMap -> NetlistMonad [Declaration]
collectAction TyConMap
tcm
  case TyConMap -> Term -> Either String ([Id], [LetBinding], Id)
splitNormalized TyConMap
tcm Term
q of
    Right (args :: [Id]
args,bs0 :: [LetBinding]
bs0,res :: Id
res) -> do
      let Letrec bs :: [LetBinding]
bs _ = HasCallStack => Term -> Term
Term -> Term
inverseTopSortLetBindings ([LetBinding] -> Term -> Term
Letrec [LetBinding]
bs0 (Id -> Term
C.Var Id
res))
      let is0 :: InScopeSet
is0 = VarSet -> InScopeSet
mkInScopeSet (Getting VarSet Term Id -> (Id -> VarSet) -> Term -> VarSet
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting VarSet Term Id
Fold Term Id
freeIds Id -> VarSet
forall a. Var a -> VarSet
unitVarSet Term
q)
      ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
 [Declaration], [LetBinding], Maybe Id)
normE <- HasCallStack =>
InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
      [Declaration], [LetBinding], Maybe Id)
InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
      [Declaration], [LetBinding], Maybe Id)
mkUniqueNormalized InScopeSet
is0 Maybe (Maybe TopEntity)
forall a. Maybe a
Nothing ([Id]
args,[LetBinding]
bs,Id
res)
      case ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
 [Declaration], [LetBinding], Maybe Id)
normE of
        (_,_,[],_,[],binders :: [LetBinding]
binders,Just result :: Id
result) -> do
          [Declaration]
ds1 <- [[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 =>
DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
mkDeclarations' DeclarationType
Sequential)) [LetBinding]
binders
          [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 ((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)
          let assn :: Declaration
assn = Text -> Expr -> Declaration
Assignment ((Text -> Text) -> (Id -> Text) -> NetlistId -> Text
forall r.
HasCallStack =>
(Text -> r) -> (Id -> r) -> NetlistId -> r
netlistId1 Text -> Text
forall a. a -> a
id Id -> Text
id2identifier NetlistId
dst)
                                (Text -> Maybe Modifier -> Expr
Identifier (Id -> Text
id2identifier Id
result) Maybe Modifier
forall a. Maybe a
Nothing)
          (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
Noop, ([Declaration]
netDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
ds0 [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
ds1 [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
assn]))
        _ -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error "internal error"
    _ -> case Term
e of
      Letrec {} -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error "internal error"
      (Term -> (Term, [Either Term Type])
collectArgs -> (Prim p :: PrimInfo
p,args :: [Either Term Type]
args))
        | PrimInfo -> Text
primName PrimInfo
p Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Explicit.SimIO.bindSimIO#" -> do
            (expr :: Expr
expr,ds1 :: [Declaration]
ds1) <- NetlistId -> [Term] -> NetlistMonad (Expr, [Declaration])
collectBindIO NetlistId
dst ([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args)
            (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
expr, [Declaration]
ds0 [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
ds1)
      _ -> do
        (expr :: Expr
expr,ds1 :: [Declaration]
ds1) <- HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Sequential NetlistId
dst Term
e
        (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
expr, [Declaration]
ds0 [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
ds1)
 where
  collectAction :: TyConMap -> NetlistMonad [Declaration]
collectAction tcm :: TyConMap
tcm = case TyConMap -> Term -> Either String ([Id], [LetBinding], Id)
splitNormalized TyConMap
tcm Term
m of
    Right (args :: [Id]
args,bs0 :: [LetBinding]
bs0,res :: Id
res) -> do
      let Letrec bs :: [LetBinding]
bs _ = HasCallStack => Term -> Term
Term -> Term
inverseTopSortLetBindings ([LetBinding] -> Term -> Term
Letrec [LetBinding]
bs0 (Id -> Term
C.Var Id
res))
      let is0 :: InScopeSet
is0 = VarSet -> InScopeSet
mkInScopeSet (Getting VarSet Term Id -> (Id -> VarSet) -> Term -> VarSet
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting VarSet Term Id
Fold Term Id
freeIds Id -> VarSet
forall a. Var a -> VarSet
unitVarSet Term
m)
      ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
 [Declaration], [LetBinding], Maybe Id)
normE <- HasCallStack =>
InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
      [Declaration], [LetBinding], Maybe Id)
InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
      [Declaration], [LetBinding], Maybe Id)
mkUniqueNormalized InScopeSet
is0 Maybe (Maybe TopEntity)
forall a. Maybe a
Nothing ([Id]
args,(Id
x,Term
m)LetBinding -> [LetBinding] -> [LetBinding]
forall a. a -> [a] -> [a]
:[LetBinding]
bs,Id
res)
      case ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
 [Declaration], [LetBinding], Maybe Id)
normE of
        (_,_,[],_,[],binders :: [LetBinding]
binders,Just result :: Id
result) -> do
          let binders1 :: [LetBinding]
binders1 = [LetBinding] -> [LetBinding]
forall a. [a] -> [a]
tail [LetBinding]
binders [LetBinding] -> [LetBinding] -> [LetBinding]
forall a. [a] -> [a] -> [a]
++ [(LetBinding -> Id
forall a b. (a, b) -> a
fst ([LetBinding] -> LetBinding
forall a. [a] -> a
head [LetBinding]
binders), Id -> Term
C.Var Id
result)]
          [Declaration]
ds1 <- [[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 =>
DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
mkDeclarations' DeclarationType
Sequential)) [LetBinding]
binders1
          [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 ((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] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Declaration]
netDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
ds1)
        _ -> String -> NetlistMonad [Declaration]
forall a. HasCallStack => String -> a
error "internal error"
    _ -> 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 ((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 [(Id
x,Term
m)])
      [Declaration]
ds1 <- HasCallStack =>
DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
mkDeclarations' DeclarationType
Sequential Id
x Term
m
      [Declaration] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Declaration]
netDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
ds1)

collectBindIO _ es :: [Term]
es = String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error ("internal error:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Term] -> String
forall p. PrettyPrec p => p -> String
showPpr [Term]
es)

-- | Collect the sequential declarations for 'appIO'
collectAppIO :: NetlistId -> [Term] -> [Term] -> NetlistMonad (Expr,[Declaration])
collectAppIO :: NetlistId -> [Term] -> [Term] -> NetlistMonad (Expr, [Declaration])
collectAppIO dst :: NetlistId
dst (fun1 :: Term
fun1:arg1 :: Term
arg1:_) rest :: [Term]
rest = case Term -> (Term, [Either Term Type])
collectArgs Term
fun1 of
  (Prim (PrimInfo "Clash.Explicit.SimIO.fmapSimIO#" _ _),([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts -> (fun0 :: Term
fun0:arg0 :: Term
arg0:_))) -> 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 argN :: [Either Term b]
argN = (Term -> Either Term b) -> [Term] -> [Either Term b]
forall a b. (a -> b) -> [a] -> [b]
map (Term -> Either Term b
forall a b. a -> Either a b
Left (Term -> Either Term b) -> (Term -> Term) -> Term -> Either Term b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyConMap -> Term -> Term
unSimIO TyConMap
tcm) (Term
arg0Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
:Term
arg1Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
:[Term]
rest)
    HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Sequential NetlistId
dst (Term -> [Either Term Type] -> Term
mkApps Term
fun0 [Either Term Type]
forall b. [Either Term b]
argN)
  (Prim (PrimInfo "Clash.Explicit.SimIO.apSimIO#" _ _),([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts -> [Term]
args)) -> do
    NetlistId -> [Term] -> [Term] -> NetlistMonad (Expr, [Declaration])
collectAppIO NetlistId
dst [Term]
args (Term
arg1Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
:[Term]
rest)
  _ -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error ("internal error:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Term] -> String
forall p. PrettyPrec p => p -> String
showPpr (Term
fun1Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
:Term
arg1Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
:[Term]
rest))


collectAppIO _ es :: [Term]
es _ = String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error ("internal error:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Term] -> String
forall p. PrettyPrec p => p -> String
showPpr [Term]
es)

-- | Unwrap the new-type wrapper for things of type SimIO, this is needed to
-- allow applications of the `State# World` token to the underlying IO type.
--
-- XXX: this is most likely needed because Ghc2Core that threw away the cast
-- that this unwrapping; we should really start to support casts.
unSimIO
  :: TyConMap
  -> Term
  -> Term
unSimIO :: TyConMap -> Term -> Term
unSimIO tcm :: TyConMap
tcm arg :: Term
arg =
  let argTy :: Type
argTy = TyConMap -> Term -> Type
termType TyConMap
tcm Term
arg
  in  case Type -> TypeView
tyView Type
argTy of
        TyConApp _ [tcArg :: Type
tcArg] ->
          Term -> [Either Term Type] -> Term
mkApps (PrimInfo -> Term
Prim (Text -> Type -> WorkInfo -> PrimInfo
PrimInfo "Clash.Explicit.SimIO.unSimIO#" (Type -> Type -> Type
mkFunTy Type
argTy Type
tcArg) WorkInfo
WorkNever))
                 [Term -> Either Term Type
forall a b. a -> Either a b
Left Term
arg]
        _ -> String -> Term
forall a. HasCallStack => String -> a
error ("internal error:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
arg)

-- | Create an template instantiation text and a partial blackbox content for an
-- argument term, given that the term is a function. Errors if the term is not
-- a function
mkFunInput
  :: HasCallStack
  => Id
  -- ^ Identifier binding the encompassing primitive/blackbox application
  -> Term
  -- ^ The function argument term
  -> NetlistMonad
      ((Either BlackBox (Identifier,[Declaration])
       ,WireOrReg
       ,[BlackBoxTemplate]
       ,[BlackBoxTemplate]
       ,[((TextS.Text,TextS.Text),BlackBox)]
       ,BlackBoxContext)
      ,[Declaration])
mkFunInput :: Id
-> Term
-> NetlistMonad
     ((Either BlackBox (Text, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext),
      [Declaration])
mkFunInput resId :: Id
resId e :: Term
e =
 let (appE :: Term
appE,args :: [Either Term Type]
args,ticks :: [TickInfo]
ticks) = Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks Term
e
 in  [TickInfo]
-> ([Declaration]
    -> NetlistMonad
         ((Either BlackBox (Text, [Declaration]), WireOrReg,
           [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
           BlackBoxContext),
          [Declaration]))
-> NetlistMonad
     ((Either BlackBox (Text, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext),
      [Declaration])
forall a.
[TickInfo] -> ([Declaration] -> NetlistMonad a) -> NetlistMonad a
withTicks [TickInfo]
ticks (([Declaration]
  -> NetlistMonad
       ((Either BlackBox (Text, [Declaration]), WireOrReg,
         [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
         BlackBoxContext),
        [Declaration]))
 -> NetlistMonad
      ((Either BlackBox (Text, [Declaration]), WireOrReg,
        [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
        BlackBoxContext),
       [Declaration]))
-> ([Declaration]
    -> NetlistMonad
         ((Either BlackBox (Text, [Declaration]), WireOrReg,
           [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
           BlackBoxContext),
          [Declaration]))
-> NetlistMonad
     ((Either BlackBox (Text, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext),
      [Declaration])
forall a b. (a -> b) -> a -> b
$ \tickDecls :: [Declaration]
tickDecls -> 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
  -- TODO: Rewrite this function to use blackbox functions. Right now it
  -- TODO: generates strings that are later parsed/interpreted again. Silly!
  (bbCtx :: BlackBoxContext
bbCtx,dcls :: [Declaration]
dcls) <- Text
-> Id
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext "__INTERNAL__" Id
resId [Either Term Type]
args
  Either
  (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Text, [Declaration]), WireOrReg)
templ <- case Term
appE of
            Prim p :: PrimInfo
p -> do
              CompiledPrimitive
bb  <- HasCallStack => Text -> NetlistMonad CompiledPrimitive
Text -> NetlistMonad CompiledPrimitive
extractPrimWarnOrFail (PrimInfo -> Text
primName PrimInfo
p)
              case CompiledPrimitive
bb of
                P.BlackBox {..} ->
                  Either
  (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Text, [Declaration]), WireOrReg)
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
 [((Text, Text), BlackBox)], Text, BlackBox)
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
forall a b. a -> Either a b
Left (TemplateKind
kind,Bool
outputReg,[BlackBoxTemplate]
libraries,[BlackBoxTemplate]
imports,[((Text, Text), BlackBox)]
includes,PrimInfo -> Text
primName PrimInfo
p,BlackBox
template))
                P.Primitive pn :: Text
pn _ pt :: Text
pt ->
                  String
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad
      (Either
         (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Text, [Declaration]), WireOrReg)))
-> String
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Unexpected blackbox type: "
                                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Primitive " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
pn
                                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
pt
                P.BlackBoxHaskell pName :: Text
pName _workInfo :: WorkInfo
_workInfo _usedArgs :: UsedArguments
_usedArgs fName :: BlackBoxFunctionName
fName (_, func :: BlackBoxFunction
func) -> do
                  -- Determine result type of this blackbox. If it's not a
                  -- function, simply use its term type.
                  let
                    resTy0 :: Type
resTy0 = TyConMap -> Term -> Type
termType TyConMap
tcm Term
e
                    resTy1 :: Type
resTy1 =
                      case TyConMap -> Type -> Maybe (Type, Type)
splitFunTy TyConMap
tcm Type
resTy0 of
                        Just (_, t :: Type
t) -> Type
t
                        Nothing -> Type
resTy0

                  Either String (BlackBoxMeta, BlackBox)
bbhRes <- BlackBoxFunction
func Bool
True Text
pName [Either Term Type]
args Type
resTy1
                  case Either String (BlackBoxMeta, BlackBox)
bbhRes of
                    Left err :: String
err ->
                      String
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad
      (Either
         (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Text, [Declaration]), WireOrReg)))
-> String
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ BlackBoxFunctionName -> String
forall a. Show a => a -> String
show BlackBoxFunctionName
fName String -> String -> String
forall a. [a] -> [a] -> [a]
++ " yielded an error: "
                                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
                    Right (BlackBoxMeta{..}, template :: BlackBox
template) ->
                      Either
  (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Text, [Declaration]), WireOrReg)
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either
   (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
    [((Text, Text), BlackBox)], Text, BlackBox)
   ((Text, [Declaration]), WireOrReg)
 -> NetlistMonad
      (Either
         (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Text, [Declaration]), WireOrReg)))
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall a b. (a -> b) -> a -> b
$
                        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
 [((Text, Text), BlackBox)], Text, BlackBox)
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
forall a b. a -> Either a b
Left ( TemplateKind
bbKind, Bool
bbOutputReg, [BlackBoxTemplate]
bbLibrary, [BlackBoxTemplate]
bbImports
                             , [((Text, Text), BlackBox)]
bbIncludes, Text
pName, BlackBox
template)
            Data dc :: DataCon
dc -> do
              let eTy :: Type
eTy = TyConMap -> Term -> Type
termType TyConMap
tcm Term
e
                  (_,resTy :: Type
resTy) = TyConMap -> Type -> ([Type], Type)
splitFunTys TyConMap
tcm Type
eTy

              Maybe FilteredHWType
resHTyM0 <- Type -> NetlistMonad (Maybe FilteredHWType)
coreTypeToHWTypeM Type
resTy
              let resHTyM1 :: Maybe (HWType, [[Bool]])
resHTyM1 = (\fHwty :: FilteredHWType
fHwty -> (FilteredHWType -> HWType
stripFiltered FilteredHWType
fHwty, FilteredHWType -> [[Bool]]
flattenFiltered FilteredHWType
fHwty)) (FilteredHWType -> (HWType, [[Bool]]))
-> Maybe FilteredHWType -> Maybe (HWType, [[Bool]])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FilteredHWType
resHTyM0

              case Maybe (HWType, [[Bool]])
resHTyM1 of
                -- Special case where coreTypeToHWTypeM determined a type to
                -- be completely transparent.
                Just (_resHTy :: HWType
_resHTy, areVoids :: [[Bool]]
areVoids@[Bool -> [Bool] -> Int
forall a. Eq a => a -> [a] -> Int
countEq Bool
False -> Int
1]) -> do
                  let nonVoidArgI :: Int
nonVoidArgI = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Bool -> [Bool] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Bool
False ([[Bool]] -> [Bool]
forall a. [a] -> a
head [[Bool]]
areVoids))
                  let arg :: Text
arg = [Text] -> Text
TextS.concat ["~ARG[", Int -> Text
forall a. TextShow a => a -> Text
showt Int
nonVoidArgI, "]"]
                  let assign :: Declaration
assign = Text -> Expr -> Declaration
Assignment "~RESULT" (Text -> Maybe Modifier -> Expr
Identifier Text
arg Maybe Modifier
forall a. Maybe a
Nothing)
                  Either
  (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Text, [Declaration]), WireOrReg)
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Text, [Declaration]), WireOrReg)
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
forall a b. b -> Either a b
Right (("", [Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
assign]), WireOrReg
Wire))

                -- Because we filter void constructs, the argument indices and
                -- the field indices don't necessarily correspond anymore. We
                -- use the result of coreTypeToHWTypeM to figure out what the
                -- original indices are. Please see the documentation in
                -- Clash.Netlist.Util.mkADT for more information.
                Just (resHTy :: HWType
resHTy@(SP _ _), areVoids0 :: [[Bool]]
areVoids0) -> do
                  let
                      dcI :: Int
dcI       = DataCon -> Int
dcTag DataCon
dc Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
                      areVoids1 :: [Bool]
areVoids1 = String -> [[Bool]] -> Int -> [Bool]
forall a. HasCallStack => String -> [a] -> Int -> a
indexNote ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "No areVoids with index: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
dcI) [[Bool]]
areVoids0 Int
dcI
                      dcInps :: [Expr]
dcInps    = [Text -> Maybe Modifier -> Expr
Identifier (String -> Text
TextS.pack ("~ARG[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "]")) Maybe Modifier
forall a. Maybe a
Nothing | Int
x <- [Bool] -> [Int]
originalIndices [Bool]
areVoids1]
                      dcApp :: Expr
dcApp     = HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
resHTy ((HWType, Int) -> Modifier
DC (HWType
resHTy,Int
dcI)) [Expr]
dcInps
                      dcAss :: Declaration
dcAss     = Text -> Expr -> Declaration
Assignment "~RESULT" Expr
dcApp
                  Either
  (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Text, [Declaration]), WireOrReg)
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Text, [Declaration]), WireOrReg)
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
forall a b. b -> Either a b
Right (("",[Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
dcAss]),WireOrReg
Wire))

                -- CustomSP the same as SP, but with a user-defined bit
                -- level representation
                Just (resHTy :: HWType
resHTy@(CustomSP {}), areVoids0 :: [[Bool]]
areVoids0) -> do
                  let
                      dcI :: Int
dcI       = DataCon -> Int
dcTag DataCon
dc Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
                      areVoids1 :: [Bool]
areVoids1 = String -> [[Bool]] -> Int -> [Bool]
forall a. HasCallStack => String -> [a] -> Int -> a
indexNote ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "No areVoids with index: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
dcI) [[Bool]]
areVoids0 Int
dcI
                      dcInps :: [Expr]
dcInps    = [Text -> Maybe Modifier -> Expr
Identifier (String -> Text
TextS.pack ("~ARG[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "]")) Maybe Modifier
forall a. Maybe a
Nothing | Int
x <- [Bool] -> [Int]
originalIndices [Bool]
areVoids1]
                      dcApp :: Expr
dcApp     = HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
resHTy ((HWType, Int) -> Modifier
DC (HWType
resHTy,Int
dcI)) [Expr]
dcInps
                      dcAss :: Declaration
dcAss     = Text -> Expr -> Declaration
Assignment "~RESULT" Expr
dcApp
                  Either
  (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Text, [Declaration]), WireOrReg)
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Text, [Declaration]), WireOrReg)
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
forall a b. b -> Either a b
Right (("",[Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
dcAss]),WireOrReg
Wire))

                -- Like SP, we have to retrieve the index BEFORE filtering voids
                Just (resHTy :: HWType
resHTy@(Product _ _ _), areVoids0 :: [[Bool]]
areVoids0) -> do
                  let areVoids1 :: [Bool]
areVoids1 = [[Bool]] -> [Bool]
forall a. [a] -> a
head [[Bool]]
areVoids0
                      dcInps :: [Expr]
dcInps    = [ Text -> Maybe Modifier -> Expr
Identifier (String -> Text
TextS.pack ("~ARG[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "]")) Maybe Modifier
forall a. Maybe a
Nothing | Int
x <- [Bool] -> [Int]
originalIndices [Bool]
areVoids1]
                      dcApp :: Expr
dcApp     = HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
resHTy ((HWType, Int) -> Modifier
DC (HWType
resHTy,0)) [Expr]
dcInps
                      dcAss :: Declaration
dcAss     = Text -> Expr -> Declaration
Assignment "~RESULT" Expr
dcApp
                  Either
  (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Text, [Declaration]), WireOrReg)
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Text, [Declaration]), WireOrReg)
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
forall a b. b -> Either a b
Right (("",[Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
dcAss]),WireOrReg
Wire))

                -- Vectors never have defined areVoids (or all set to False), as
                -- it would be converted to Void otherwise. We can therefore
                -- safely ignore it:
                Just (resHTy :: HWType
resHTy@(Vector _ _), _areVoids :: [[Bool]]
_areVoids) -> do
                  let dcInps :: [Expr]
dcInps = [ Text -> Maybe Modifier -> Expr
Identifier (String -> Text
TextS.pack ("~ARG[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "]")) Maybe Modifier
forall a. Maybe a
Nothing | Int
x <- [(1::Int)..2] ]
                      dcApp :: Expr
dcApp  = HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
resHTy ((HWType, Int) -> Modifier
DC (HWType
resHTy,1)) [Expr]
dcInps
                      dcAss :: Declaration
dcAss  = Text -> Expr -> Declaration
Assignment "~RESULT" Expr
dcApp
                  Either
  (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Text, [Declaration]), WireOrReg)
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Text, [Declaration]), WireOrReg)
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
forall a b. b -> Either a b
Right (("",[Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
dcAss]),WireOrReg
Wire))

                -- Sum types OR a Sum type after filtering empty types:
                Just (resHTy :: HWType
resHTy@(Sum _ _), _areVoids :: [[Bool]]
_areVoids) -> do
                  let dcI :: Int
dcI   = DataCon -> Int
dcTag DataCon
dc Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
                      dcApp :: Expr
dcApp = HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
resHTy ((HWType, Int) -> Modifier
DC (HWType
resHTy,Int
dcI)) []
                      dcAss :: Declaration
dcAss = Text -> Expr -> Declaration
Assignment "~RESULT" Expr
dcApp
                  Either
  (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Text, [Declaration]), WireOrReg)
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Text, [Declaration]), WireOrReg)
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
forall a b. b -> Either a b
Right (("",[Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
dcAss]),WireOrReg
Wire))

                -- Same as Sum, but with user defined bit level representation
                Just (resHTy :: HWType
resHTy@(CustomSum {}), _areVoids :: [[Bool]]
_areVoids) -> do
                  let dcI :: Int
dcI   = DataCon -> Int
dcTag DataCon
dc Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
                      dcApp :: Expr
dcApp = HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
resHTy ((HWType, Int) -> Modifier
DC (HWType
resHTy,Int
dcI)) []
                      dcAss :: Declaration
dcAss = Text -> Expr -> Declaration
Assignment "~RESULT" Expr
dcApp
                  Either
  (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Text, [Declaration]), WireOrReg)
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Text, [Declaration]), WireOrReg)
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
forall a b. b -> Either a b
Right (("",[Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
dcAss]),WireOrReg
Wire))

                Just (Void {}, _areVoids :: [[Bool]]
_areVoids) ->
                  Either
  (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Text, [Declaration]), WireOrReg)
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (String
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
forall a. HasCallStack => String -> a
error (String
 -> Either
      (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
       [((Text, Text), BlackBox)], Text, BlackBox)
      ((Text, [Declaration]), WireOrReg))
-> String
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Encountered Void in mkFunInput."
                                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ " This is a bug in Clash.")

                _ -> String
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad
      (Either
         (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Text, [Declaration]), WireOrReg)))
-> String
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Cannot make function input for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
e
            C.Var fun :: Id
fun -> 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
              case Id -> VarEnv TopEntityT -> Maybe TopEntityT
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
fun VarEnv TopEntityT
topAnns of
                Just _ ->
                  String
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad
      (Either
         (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Text, [Declaration]), WireOrReg)))
-> String
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Cannot make function input for partially applied Synthesize-annotated: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
e
                _ -> 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
                    Just _ -> do
                      (wereVoids :: [Bool]
wereVoids,_,_,N.Component compName :: Text
compName compInps :: [(Text, HWType)]
compInps [(_,compOutp :: (Text, HWType)
compOutp,_)] _) <-
                        NetlistMonad ([Bool], SrcSpan, HashMap Text Word, Component)
-> NetlistMonad ([Bool], SrcSpan, HashMap Text Word, Component)
forall a. NetlistMonad a -> NetlistMonad a
preserveVarEnv (NetlistMonad ([Bool], SrcSpan, HashMap Text Word, Component)
 -> NetlistMonad ([Bool], SrcSpan, HashMap Text Word, Component))
-> NetlistMonad ([Bool], SrcSpan, HashMap Text Word, Component)
-> NetlistMonad ([Bool], SrcSpan, HashMap Text Word, Component)
forall a b. (a -> b) -> a -> b
$ HasCallStack =>
Id -> NetlistMonad ([Bool], SrcSpan, HashMap Text Word, Component)
Id -> NetlistMonad ([Bool], SrcSpan, HashMap Text Word, Component)
genComponent Id
fun

                      let inpAssign :: (Text, c) -> d -> (Expr, PortDirection, c, d)
inpAssign (i :: Text
i, t :: c
t) e' :: d
e' = (Text -> Maybe Modifier -> Expr
Identifier Text
i Maybe Modifier
forall a. Maybe a
Nothing, PortDirection
In, c
t, d
e')
                          inpVar :: a -> Text
inpVar i :: a
i            = String -> Text
TextS.pack ("~VAR[arg" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "][" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "]")
                          inpVars :: [Expr]
inpVars             = [Text -> Maybe Modifier -> Expr
Identifier (Int -> Text
forall a. Show a => a -> Text
inpVar Int
i)  Maybe Modifier
forall a. Maybe a
Nothing | Int
i <- [Bool] -> [Int]
originalIndices [Bool]
wereVoids]
                          inpAssigns :: [(Expr, PortDirection, HWType, Expr)]
inpAssigns          = ((Text, HWType) -> Expr -> (Expr, PortDirection, HWType, Expr))
-> [(Text, HWType)]
-> [Expr]
-> [(Expr, PortDirection, HWType, Expr)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Text, HWType) -> Expr -> (Expr, PortDirection, HWType, Expr)
forall c d. (Text, c) -> d -> (Expr, PortDirection, c, d)
inpAssign [(Text, HWType)]
compInps [Expr]
inpVars
                          outpAssign :: (Expr, PortDirection, HWType, Expr)
outpAssign          = ( Text -> Maybe Modifier -> Expr
Identifier ((Text, HWType) -> Text
forall a b. (a, b) -> a
fst (Text, HWType)
compOutp) Maybe Modifier
forall a. Maybe a
Nothing
                                                , PortDirection
Out
                                                , (Text, HWType) -> HWType
forall a b. (a, b) -> b
snd (Text, HWType)
compOutp
                                                , Text -> Maybe Modifier -> Expr
Identifier "~RESULT" Maybe Modifier
forall a. Maybe a
Nothing )
                      Int
i <- (Int -> (Int, Int)) -> NetlistState -> (Int, NetlistState)
Lens' NetlistState Int
varCount ((Int -> (Int, Int)) -> NetlistState -> (Int, NetlistState))
-> (Int -> Int) -> NetlistMonad Int
forall (p :: Type -> Type -> Type) s (m :: Type -> Type) a b.
(Strong p, MonadState s m) =>
Over p ((,) a) s s a b -> p a b -> m a
<<%= (Int -> Int -> Int
forall a. Num a => a -> a -> a
+1)
                      let instLabel :: Text
instLabel     = [Text] -> Text
TextS.concat [Text
compName,String -> Text
TextS.pack ("_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)]
                          instDecl :: Declaration
instDecl      = EntityOrComponent
-> Maybe Text
-> Text
-> Text
-> [(Expr, HWType, Expr)]
-> [(Expr, PortDirection, HWType, Expr)]
-> Declaration
InstDecl EntityOrComponent
Entity Maybe Text
forall a. Maybe a
Nothing Text
compName Text
instLabel [] ((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)
                      Either
  (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Text, [Declaration]), WireOrReg)
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Text, [Declaration]), WireOrReg)
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
forall a b. b -> Either a b
Right (("",[Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
instDecl]),WireOrReg
Wire))
                    Nothing -> String
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad
      (Either
         (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Text, [Declaration]), WireOrReg)))
-> String
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Cannot make function input for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
e
            C.Lam {} -> do
              let is0 :: InScopeSet
is0 = VarSet -> InScopeSet
mkInScopeSet (Getting VarSet Term Id -> (Id -> VarSet) -> Term -> VarSet
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting VarSet Term Id
Fold Term Id
freeIds Id -> VarSet
forall a. Var a -> VarSet
unitVarSet Term
appE)
              ((TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
  [((Text, Text), BlackBox)], Text, BlackBox)
 -> Either
      (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
       [((Text, Text), BlackBox)], Text, BlackBox)
      ((Text, [Declaration]), WireOrReg))
-> (((Text, [Declaration]), WireOrReg)
    -> Either
         (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Text, [Declaration]), WireOrReg))
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
 [((Text, Text), BlackBox)], Text, BlackBox)
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
forall a b. a -> Either a b
Left (((Text, [Declaration]), WireOrReg)
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
forall a b. b -> Either a b
Right (((Text, [Declaration]), WireOrReg)
 -> Either
      (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
       [((Text, Text), BlackBox)], Text, BlackBox)
      ((Text, [Declaration]), WireOrReg))
-> (((Text, [Declaration]), WireOrReg)
    -> ((Text, [Declaration]), WireOrReg))
-> ((Text, [Declaration]), WireOrReg)
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, [Declaration]) -> (Text, [Declaration]))
-> ((Text, [Declaration]), WireOrReg)
-> ((Text, [Declaration]), WireOrReg)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (([Declaration] -> [Declaration])
-> (Text, [Declaration]) -> (Text, [Declaration])
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ([Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++))) (Either
   (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
    [((Text, Text), BlackBox)], Text, BlackBox)
   ((Text, [Declaration]), WireOrReg)
 -> Either
      (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
       [((Text, Text), BlackBox)], Text, BlackBox)
      ((Text, [Declaration]), WireOrReg))
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> InScopeSet
-> Int
-> Term
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall a.
InScopeSet
-> Int
-> Term
-> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
go InScopeSet
is0 0 Term
appE
            _ -> String
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad
      (Either
         (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Text, [Declaration]), WireOrReg)))
-> String
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Cannot make function input for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
e
  case Either
  (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Text, [Declaration]), WireOrReg)
templ of
    Left (TDecl,oreg :: Bool
oreg,libs :: [BlackBoxTemplate]
libs,imps :: [BlackBoxTemplate]
imps,inc :: [((Text, Text), BlackBox)]
inc,_,templ' :: BlackBox
templ') -> do
      (l' :: BlackBox
l',templDecl :: [Declaration]
templDecl)
        <- (BlackBoxTemplate -> NetlistMonad (BlackBox, [Declaration]))
-> (String
    -> Int
    -> TemplateFunction
    -> NetlistMonad (BlackBox, [Declaration]))
-> BlackBox
-> NetlistMonad (BlackBox, [Declaration])
forall r.
(BlackBoxTemplate -> r)
-> (String -> Int -> TemplateFunction -> r) -> BlackBox -> r
onBlackBox
            (((BlackBoxTemplate, [Declaration]) -> (BlackBox, [Declaration]))
-> NetlistMonad (BlackBoxTemplate, [Declaration])
-> NetlistMonad (BlackBox, [Declaration])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((BlackBoxTemplate -> BlackBox)
-> (BlackBoxTemplate, [Declaration]) -> (BlackBox, [Declaration])
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first BlackBoxTemplate -> BlackBox
BBTemplate) (NetlistMonad (BlackBoxTemplate, [Declaration])
 -> NetlistMonad (BlackBox, [Declaration]))
-> (BlackBoxTemplate
    -> NetlistMonad (BlackBoxTemplate, [Declaration]))
-> BlackBoxTemplate
-> NetlistMonad (BlackBox, [Declaration])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IdType -> Text -> NetlistMonad Text)
-> BlackBoxContext
-> BlackBoxTemplate
-> NetlistMonad (BlackBoxTemplate, [Declaration])
forall (m :: Type -> Type).
Monad m =>
(IdType -> Text -> m Text)
-> BlackBoxContext
-> BlackBoxTemplate
-> m (BlackBoxTemplate, [Declaration])
setSym IdType -> Text -> NetlistMonad Text
mkUniqueIdentifier BlackBoxContext
bbCtx)
            (\bbName :: String
bbName bbHash :: Int
bbHash bbFunc :: TemplateFunction
bbFunc -> (BlackBox, [Declaration]) -> NetlistMonad (BlackBox, [Declaration])
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((BlackBox, [Declaration])
 -> NetlistMonad (BlackBox, [Declaration]))
-> (BlackBox, [Declaration])
-> NetlistMonad (BlackBox, [Declaration])
forall a b. (a -> b) -> a -> b
$ (String -> Int -> TemplateFunction -> BlackBox
BBFunction String
bbName Int
bbHash TemplateFunction
bbFunc, []))
            BlackBox
templ'
      ((Either BlackBox (Text, [Declaration]), WireOrReg,
  [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
  BlackBoxContext),
 [Declaration])
-> NetlistMonad
     ((Either BlackBox (Text, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext),
      [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((BlackBox -> Either BlackBox (Text, [Declaration])
forall a b. a -> Either a b
Left BlackBox
l',if Bool
oreg then WireOrReg
Reg else WireOrReg
Wire,[BlackBoxTemplate]
libs,[BlackBoxTemplate]
imps,[((Text, Text), BlackBox)]
inc,BlackBoxContext
bbCtx),[Declaration]
dcls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
templDecl)
    Left (TExpr,_,libs :: [BlackBoxTemplate]
libs,imps :: [BlackBoxTemplate]
imps,inc :: [((Text, Text), BlackBox)]
inc,nm :: Text
nm,templ' :: BlackBox
templ') -> do
      (BlackBoxTemplate
 -> NetlistMonad
      ((Either BlackBox (Text, [Declaration]), WireOrReg,
        [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
        BlackBoxContext),
       [Declaration]))
-> (String
    -> Int
    -> TemplateFunction
    -> NetlistMonad
         ((Either BlackBox (Text, [Declaration]), WireOrReg,
           [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
           BlackBoxContext),
          [Declaration]))
-> BlackBox
-> NetlistMonad
     ((Either BlackBox (Text, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext),
      [Declaration])
forall r.
(BlackBoxTemplate -> r)
-> (String -> Int -> TemplateFunction -> r) -> BlackBox -> r
onBlackBox
        (\t :: BlackBoxTemplate
t -> do Text
t' <- Mon NetlistMonad Text -> NetlistMonad Text
forall (f :: Type -> Type) m. Mon f m -> f m
getMon (BlackBoxTemplate -> Mon NetlistMonad Text
forall (m :: Type -> Type).
Monad m =>
BlackBoxTemplate -> Mon m Text
prettyBlackBox BlackBoxTemplate
t)
                  let assn :: Declaration
assn = Text -> Expr -> Declaration
Assignment "~RESULT" (Text -> Maybe Modifier -> Expr
Identifier (Text -> Text
Text.toStrict Text
t') Maybe Modifier
forall a. Maybe a
Nothing)
                  ((Either BlackBox (Text, [Declaration]), WireOrReg,
  [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
  BlackBoxContext),
 [Declaration])
-> NetlistMonad
     ((Either BlackBox (Text, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext),
      [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Text, [Declaration]) -> Either BlackBox (Text, [Declaration])
forall a b. b -> Either a b
Right ("",[Declaration
assn]),WireOrReg
Wire,[BlackBoxTemplate]
libs,[BlackBoxTemplate]
imps,[((Text, Text), BlackBox)]
inc,BlackBoxContext
bbCtx),[Declaration]
dcls))
        (\bbName :: String
bbName bbHash :: Int
bbHash (TemplateFunction k :: [Int]
k g :: BlackBoxContext -> Bool
g _) -> do
          let f' :: BlackBoxContext -> State state (Doc ())
f' bbCtx' :: BlackBoxContext
bbCtx' = do
                let assn :: Declaration
assn = Text -> Expr -> Declaration
Assignment "~RESULT"
                            (Text
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> BlackBoxContext
-> Bool
-> Expr
BlackBoxE Text
nm [BlackBoxTemplate]
libs [BlackBoxTemplate]
imps [((Text, Text), BlackBox)]
inc BlackBox
templ' BlackBoxContext
bbCtx' Bool
False)
                Doc ()
p <- Mon (State state) (Doc ()) -> State state (Doc ())
forall (f :: Type -> Type) m. Mon f m -> f m
getMon (Text -> [Declaration] -> Mon (State state) (Doc ())
forall state.
Backend state =>
Text -> [Declaration] -> Mon (State state) (Doc ())
Backend.blockDecl "" [Declaration
assn])
                Doc () -> State state (Doc ())
forall (m :: Type -> Type) a. Monad m => a -> m a
return Doc ()
p
          ((Either BlackBox (Text, [Declaration]), WireOrReg,
  [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
  BlackBoxContext),
 [Declaration])
-> NetlistMonad
     ((Either BlackBox (Text, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext),
      [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((BlackBox -> Either BlackBox (Text, [Declaration])
forall a b. a -> Either a b
Left (String -> Int -> TemplateFunction -> BlackBox
BBFunction String
bbName Int
bbHash ([Int]
-> (BlackBoxContext -> Bool)
-> (forall s. Backend s => BlackBoxContext -> State s (Doc ()))
-> TemplateFunction
TemplateFunction [Int]
k BlackBoxContext -> Bool
g forall s. Backend s => BlackBoxContext -> State s (Doc ())
f'))
                  ,WireOrReg
Wire
                  ,[]
                  ,[]
                  ,[]
                  ,BlackBoxContext
bbCtx
                  )
                 ,[Declaration]
dcls
                 )
        )
        BlackBox
templ'
    Right (decl :: (Text, [Declaration])
decl,wr :: WireOrReg
wr) ->
      ((Either BlackBox (Text, [Declaration]), WireOrReg,
  [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
  BlackBoxContext),
 [Declaration])
-> NetlistMonad
     ((Either BlackBox (Text, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext),
      [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Text, [Declaration]) -> Either BlackBox (Text, [Declaration])
forall a b. b -> Either a b
Right (Text, [Declaration])
decl,WireOrReg
wr,[],[],[],BlackBoxContext
bbCtx),[Declaration]
dcls)
  where
    goExpr :: Term -> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
goExpr app :: Term
app@(Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks -> (C.Var fun :: Id
fun,args :: [Either Term Type]
args@(_:_),ticks :: [TickInfo]
ticks)) = do
      let (tmArgs :: [Term]
tmArgs,tyArgs :: [Type]
tyArgs) = [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Term Type]
args
      if [Type] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Type]
tyArgs
        then
          [TickInfo]
-> ([Declaration]
    -> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg)))
-> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
forall a.
[TickInfo] -> ([Declaration] -> NetlistMonad a) -> NetlistMonad a
withTicks [TickInfo]
ticks (([Declaration]
  -> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg)))
 -> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg)))
-> ([Declaration]
    -> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg)))
-> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
forall a b. (a -> b) -> a -> b
$ \tickDecls :: [Declaration]
tickDecls -> do
            [Declaration]
appDecls <- HasCallStack =>
Text -> Id -> [Term] -> [Declaration] -> NetlistMonad [Declaration]
Text -> Id -> [Term] -> [Declaration] -> NetlistMonad [Declaration]
mkFunApp "~RESULT" Id
fun [Term]
tmArgs [Declaration]
tickDecls
            Text
nm <- IdType -> Text -> NetlistMonad Text
mkUniqueIdentifier IdType
Basic "block"
            Either a ((Text, [Declaration]), WireOrReg)
-> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Text, [Declaration]), WireOrReg)
-> Either a ((Text, [Declaration]), WireOrReg)
forall a b. b -> Either a b
Right ((Text
nm,[Declaration]
appDecls),WireOrReg
Wire))
        else do
          (_,sp :: SrcSpan
sp) <- Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
-> NetlistMonad (Text, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
Lens' NetlistState (Text, SrcSpan)
curCompNm
          ClashException
-> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
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)
    goExpr e' :: Term
e' = 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 eType :: Type
eType = TyConMap -> Term -> Type
termType TyConMap
tcm Term
e'
      (appExpr :: Expr
appExpr,appDecls :: [Declaration]
appDecls) <- HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Concurrent (Text -> Type -> NetlistId
NetlistId "c$bb_res" Type
eType) Term
e'
      let assn :: Declaration
assn = Text -> Expr -> Declaration
Assignment "~RESULT" Expr
appExpr
      Text
nm <- if [Declaration] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Declaration]
appDecls
               then Text -> NetlistMonad Text
forall (m :: Type -> Type) a. Monad m => a -> m a
return ""
               else IdType -> Text -> NetlistMonad Text
mkUniqueIdentifier IdType
Basic "block"
      Either a ((Text, [Declaration]), WireOrReg)
-> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Text, [Declaration]), WireOrReg)
-> Either a ((Text, [Declaration]), WireOrReg)
forall a b. b -> Either a b
Right ((Text
nm,[Declaration]
appDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
assn]),WireOrReg
Wire))

    go :: InScopeSet
-> Int
-> Term
-> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
go is0 :: InScopeSet
is0 n :: Int
n (Lam id_ :: Id
id_ e' :: Term
e') = do
      Int
lvl <- 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
curBBlvl
      let nm :: Text
nm    = [Text] -> Text
TextS.concat
                    ["~ARGN[",String -> Text
TextS.pack (Int -> String
forall a. Show a => a -> String
show Int
lvl),"][",String -> Text
TextS.pack (Int -> String
forall a. Show a => a -> String
show Int
n),"]"]
          v' :: Id
v'    = InScopeSet -> Id -> Id
forall a. (Uniquable a, ClashPretty a) => InScopeSet -> a -> a
uniqAway InScopeSet
is0 ((Name Term -> Name Term) -> Id -> Id
forall a. (Name a -> Name a) -> Var a -> Var a
modifyVarName (\v :: Name Term
v -> Name Term
v {nameOcc :: Text
nameOcc = Text
nm}) Id
id_)
          subst :: Subst
subst = Subst -> Id -> Term -> Subst
extendIdSubst (InScopeSet -> Subst
mkSubst InScopeSet
is0) Id
id_ (Id -> Term
C.Var Id
v')
          e'' :: Term
e''   = HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm "mkFunInput.goLam" Subst
subst Term
e'
          is1 :: InScopeSet
is1   = InScopeSet -> Id -> InScopeSet
forall a. InScopeSet -> Var a -> InScopeSet
extendInScopeSet InScopeSet
is0 Id
v'
      InScopeSet
-> Int
-> Term
-> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
go InScopeSet
is1 (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+(1::Int)) Term
e''

    go _ _ (C.Var v :: Id
v) = do
      let assn :: Declaration
assn = Text -> Expr -> Declaration
Assignment "~RESULT" (Text -> Maybe Modifier -> Expr
Identifier (Name Term -> Text
forall a. Name a -> Text
nameOcc (Id -> Name Term
forall a. Var a -> Name a
varName Id
v)) Maybe Modifier
forall a. Maybe a
Nothing)
      Either a ((Text, [Declaration]), WireOrReg)
-> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Text, [Declaration]), WireOrReg)
-> Either a ((Text, [Declaration]), WireOrReg)
forall a b. b -> Either a b
Right (("",[Declaration
assn]),WireOrReg
Wire))

    go _ _ (Case scrut :: Term
scrut ty :: Type
ty [alt :: Alt
alt]) = 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 sTy :: Type
sTy = TyConMap -> Term -> Type
termType TyConMap
tcm Term
scrut
      (projection :: Expr
projection,decls :: [Declaration]
decls) <- Bool
-> NetlistId
-> Term
-> Type
-> Alt
-> NetlistMonad (Expr, [Declaration])
mkProjection Bool
False (Text -> Type -> NetlistId
NetlistId "c$bb_res" Type
sTy) Term
scrut Type
ty Alt
alt
      let assn :: Declaration
assn = Text -> Expr -> Declaration
Assignment "~RESULT" Expr
projection
      Text
nm <- if [Declaration] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Declaration]
decls
               then Text -> NetlistMonad Text
forall (m :: Type -> Type) a. Monad m => a -> m a
return ""
               else IdType -> Text -> NetlistMonad Text
mkUniqueIdentifier IdType
Basic "projection"
      Either a ((Text, [Declaration]), WireOrReg)
-> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Text, [Declaration]), WireOrReg)
-> Either a ((Text, [Declaration]), WireOrReg)
forall a b. b -> Either a b
Right ((Text
nm,[Declaration]
decls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
assn]),WireOrReg
Wire))

    go _ _ (Case scrut :: Term
scrut ty :: Type
ty alts :: [Alt]
alts@(_:_:_)) = do
      -- TODO: check that it's okay to use `mkUnsafeSystemName`
      let resId' :: Var a
resId'  = Id
resId {varName :: Name a
varName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
mkUnsafeSystemName "~RESULT" 0}
      [Declaration]
selectionDecls <- DeclarationType
-> NetlistId
-> Term
-> Type
-> [Alt]
-> [Declaration]
-> NetlistMonad [Declaration]
mkSelection DeclarationType
Concurrent (Id -> NetlistId
CoreId Id
forall a. Var a
resId') Term
scrut Type
ty [Alt]
alts []
      Text
nm <- IdType -> Text -> NetlistMonad Text
mkUniqueIdentifier IdType
Basic "selection"
      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
      Either a ((Text, [Declaration]), WireOrReg)
-> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Text, [Declaration]), WireOrReg)
-> Either a ((Text, [Declaration]), WireOrReg)
forall a b. b -> Either a b
Right ((Text
nm,[Declaration]
selectionDecls),WireOrReg
wr))

    go is0 :: InScopeSet
is0 _ e' :: Term
e'@(Letrec {}) = 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 normE :: Either String ([Id], [LetBinding], Id)
normE = TyConMap -> Term -> Either String ([Id], [LetBinding], Id)
splitNormalized TyConMap
tcm Term
e'
      (_,[],[],_,[],binders :: [LetBinding]
binders,resultM :: Maybe Id
resultM) <- case Either String ([Id], [LetBinding], Id)
normE of
        Right norm :: ([Id], [LetBinding], Id)
norm -> HasCallStack =>
InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
      [Declaration], [LetBinding], Maybe Id)
InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
      [Declaration], [LetBinding], Maybe Id)
mkUniqueNormalized InScopeSet
is0 Maybe (Maybe TopEntity)
forall a. Maybe a
Nothing ([Id], [LetBinding], Id)
norm
        Left err :: String
err -> String
-> NetlistMonad
     ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
      [Declaration], [LetBinding], Maybe Id)
forall a. HasCallStack => String -> a
error String
err
      case Maybe Id
resultM of
        Just result :: Id
result -> do
          let binders' :: [LetBinding]
binders' = (LetBinding -> LetBinding) -> [LetBinding] -> [LetBinding]
forall a b. (a -> b) -> [a] -> [b]
map (\(id_ :: Id
id_,tm :: Term
tm) -> (Id -> Id -> Id
forall a. Var a -> Var a -> Var a
goR Id
result Id
id_,Term
tm)) [LetBinding]
binders
          [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 -> 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
          [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'
          Just (NetDecl' _ rw :: WireOrReg
rw _ _ _) <- 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
          Text
nm <- IdType -> Text -> NetlistMonad Text
mkUniqueIdentifier IdType
Basic "fun"
          Either a ((Text, [Declaration]), WireOrReg)
-> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Text, [Declaration]), WireOrReg)
-> Either a ((Text, [Declaration]), WireOrReg)
forall a b. b -> Either a b
Right ((Text
nm,[Declaration]
netDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
decls),WireOrReg
rw))
        Nothing -> Either a ((Text, [Declaration]), WireOrReg)
-> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Text, [Declaration]), WireOrReg)
-> Either a ((Text, [Declaration]), WireOrReg)
forall a b. b -> Either a b
Right (("",[]),WireOrReg
Wire))
      where
        -- TODO: check that it's okay to use `mkUnsafeSystemName`
        goR :: Var a -> Var a -> Var a
goR r :: Var a
r id_ :: Var a
id_ | Var a
id_ Var a -> Var a -> Bool
forall a. Eq a => a -> a -> Bool
== Var a
r  = Var a
id_ {varName :: Name a
varName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
mkUnsafeSystemName "~RESULT" 0}
                  | Bool
otherwise = Var a
id_

    go is0 :: InScopeSet
is0 n :: Int
n (Tick _ e' :: Term
e') = InScopeSet
-> Int
-> Term
-> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
go InScopeSet
is0 Int
n Term
e'

    go _ _ e' :: Term
e'@(App {}) = Term -> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
forall a.
Term -> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
goExpr Term
e'
    go _ _ e' :: Term
e'@(C.Data {}) = Term -> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
forall a.
Term -> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
goExpr Term
e'
    go _ _ e' :: Term
e'@(C.Literal {}) = Term -> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
forall a.
Term -> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
goExpr Term
e'
    go _ _ e' :: Term
e'@(Cast {}) = Term -> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
forall a.
Term -> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
goExpr Term
e'
    go _ _ e' :: Term
e'@(Prim {}) = Term -> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
forall a.
Term -> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
goExpr Term
e'
    go _ _ e' :: Term
e'@(TyApp {}) = Term -> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
forall a.
Term -> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
goExpr Term
e'

    go _ _ e' :: Term
e'@(Case _ _ []) =
      String
-> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg)))
-> String
-> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Cannot make function input for case without alternatives: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall a. Show a => a -> String
show Term
e'

    go _ _ e' :: Term
e'@(TyLam {}) =
      String
-> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg)))
-> String
-> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Cannot make function input for TyLam: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall a. Show a => a -> String
show Term
e'