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

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

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

module Clash.Netlist.BlackBox
    ( mkBlackBoxContext
    , extractPrimWarnOrFail
    , mkPrimitive
    , prepareBlackBox
    , isLiteral
    ) where

import           Control.Exception             (throw)
import           Control.Lens                  ((%=))
import qualified Control.Lens                  as Lens
import           Control.Monad                 (when, replicateM, zipWithM)
import           Control.Monad.Extra           (concatMapM)
import           Control.Monad.IO.Class        (liftIO)
import           Data.Bifunctor                (first, second)
import           Data.Either                   (lefts, partitionEithers)
import           Data.Foldable                 (for_)
import qualified Data.HashMap.Lazy             as HashMap
import qualified Data.IntMap                   as IntMap
import           Data.List.NonEmpty            (NonEmpty (..))
import           Data.List                     (elemIndex, partition)
import           Data.List.Extra               (countEq, mapAccumLM)
import           Data.Maybe                    (listToMaybe, fromJust, fromMaybe)
import           Data.Monoid                   (Ap(getAp))
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           Data.Text.Extra
import           GHC.Stack
  (HasCallStack, callStack, prettyCallStack)
import qualified System.Console.ANSI           as ANSI
import           System.Console.ANSI
  ( hSetSGR, SGR(SetConsoleIntensity, SetColor), Color(Magenta, Red)
  , ConsoleIntensity(BoldIntensity), ConsoleLayer(Foreground), ColorIntensity(Vivid))
import           System.IO
  (hPutStrLn, stderr, hFlush, hIsTerminalDevice)

import           Clash.Annotations.Primitive
  ( PrimitiveGuard(HasBlackBox, DontTranslate)
  , PrimitiveWarning(WarnNonSynthesizable, WarnAlways)
  , extractPrim, HDL(VHDL))
import           Clash.Core.DataCon            as D (dcTag)
import           Clash.Core.FreeVars           (freeIds)
import           Clash.Core.HasType
import           Clash.Core.Literal            as C (Literal (..))
import           Clash.Core.Name
  (Name (..), mkUnsafeSystemName)
import qualified Clash.Netlist.Id              as Id
import           Clash.Core.Pretty             (showPpr)
import           Clash.Core.Subst              (extendIdSubst, mkSubst, substTm)
import           Clash.Core.Term               as C
  (IsMultiPrim (..), PrimInfo (..), Term (..), WorkInfo (..), collectArgs,
   collectArgsTicks, collectBndrs, mkApps, PrimUnfolding(..))
import           Clash.Core.TermInfo
import           Clash.Core.Type               as C
  (Type (..), ConstTy (..), TypeView (..), mkFunTy, splitFunTys, tyView)
import           Clash.Core.TyCon              as C (TyConMap, tyConDataCons)
import           Clash.Core.Util
  (inverseTopSortLetBindings, splitShouldSplit)
import           Clash.Core.Var                as V
  (Id, mkLocalId, modifyVarName, varType)
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 qualified Clash.Data.UniqMap as UniqMap
import           Clash.Debug                   (debugIsOn)
import           Clash.Driver.Bool             (OverridingBool(..))
import           Clash.Driver.Types
  (ClashOpts(opt_primWarn, opt_color, opt_werror))
import           Clash.Netlist.BlackBox.Types  as B
import           Clash.Netlist.BlackBox.Util   as B
import           Clash.Netlist.Types           as N
import           Clash.Netlist.Util            as N
import           Clash.Normalize.Primitives    (removedArg)
import           Clash.Primitives.Types        as P
import qualified Clash.Primitives.Util         as P
import           Clash.Signal.Internal         (ActiveEdge (..))
import           Clash.Util
import qualified Clash.Util.Interpolate        as I

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

  hSetSGR stderr [SetConsoleIntensity BoldIntensity]

  case opt_werror opts of
    Bool
True -> do
      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
Red]
      ClashException -> IO ()
forall a e. (HasCallStack, Exception e) => e -> a
throw (SrcSpan -> [Char] -> Maybe [Char] -> ClashException
ClashException SrcSpan
noSrcSpan [Char]
msg Maybe [Char]
forall a. Maybe a
Nothing)

    Bool
False -> do
      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 -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"[WARNING] " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
msg
      Handle -> [SGR] -> IO ()
hSetSGR Handle
stderr [SGR
ANSI.Reset]
      Handle -> IO ()
hFlush Handle
stderr

-- | Generate the context for a BlackBox instantiation.
mkBlackBoxContext
  :: HasCallStack
  => TextS.Text
  -- ^ Blackbox function name
  -> DeclarationType
  -- ^ Are we concurrent or sequential?
  -> [Id]
  -- ^ Identifiers binding the primitive/blackbox application
  -> [Either Term Type]
  -- ^ Arguments of the primitive/blackbox application
  -> NetlistMonad (BlackBoxContext,[Declaration])
mkBlackBoxContext :: HasCallStack =>
Text
-> DeclarationType
-> [Id]
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext Text
bbName DeclarationType
declType [Id]
resIds args :: [Either Term Type]
args@([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts -> [Term]
termArgs) = do
    -- Make context inputs
    let
      resNms :: [Identifier]
resNms = (Id -> Identifier) -> [Id] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId [Id]
resIds
      resNm :: Identifier
resNm = Identifier -> Maybe Identifier -> Identifier
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Identifier
forall a. HasCallStack => [Char] -> a
error [Char]
"mkBlackBoxContext: head") ([Identifier] -> Maybe Identifier
forall a. [a] -> Maybe a
listToMaybe [Identifier]
resNms)
    resTys <- (Id -> NetlistMonad HWType) -> [Id] -> NetlistMonad [HWType]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM ([Char] -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(curLoc) (Type -> NetlistMonad HWType)
-> (Id -> Type) -> Id -> NetlistMonad HWType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
forall a. HasType a => a -> Type
coreTypeOf) [Id]
resIds
    (imps,impDecls) <- unzip <$> zipWithM (mkArgument bbName resNm declType) [0..] termArgs
    (funs,funDecls) <-
      mapAccumLM
        (addFunction (map coreTypeOf resIds))
        IntMap.empty
        (zip termArgs [0..])

    -- Make context result
    let ress = (Identifier -> Expr) -> [Identifier] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map ((Identifier -> Maybe Modifier -> Expr)
-> Maybe Modifier -> Identifier -> Expr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Identifier -> Maybe Modifier -> Expr
Identifier Maybe Modifier
forall a. Maybe a
Nothing) [Identifier]
resNms

    lvl <- Lens.use curBBlvl
    (nm,_) <- Lens.use curCompNm

    -- Set "context name" to value set by `Clash.Magic.setName`, default to the
    -- name of the closest binder
    ctxName1 <- fromMaybe (map Id.toText resNms) . fmap pure <$> Lens.view setName
    -- Update "context name" with prefixes and suffixes set by
    -- `Clash.Magic.prefixName` and `Clash.Magic.suffixName`
    ctxName2 <- mapM affixName ctxName1

    return ( Context bbName (zip ress resTys) imps funs [] lvl nm (listToMaybe ctxName2)
           , concat impDecls ++ concat funDecls
           )
  where
    addFunction :: [Type]
-> IntMap
     [(Either BlackBox (Identifier, [Declaration]), Usage,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext)]
-> (Term, Int)
-> NetlistMonad
     (IntMap
        [(Either BlackBox (Identifier, [Declaration]), Usage,
          [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
          BlackBoxContext)],
      [Declaration])
addFunction [Type]
resTys IntMap
  [(Either BlackBox (Identifier, [Declaration]), Usage,
    [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
    BlackBoxContext)]
im (Term
arg,Int
i) = do
      tcm <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
      if isFun tcm arg then do
        -- Only try to calculate function plurality when primitive actually
        -- exists. Here to prevent crashes on __INTERNAL__ primitives.
        prim <- HashMap.lookup bbName <$> Lens.view primitives
        funcPlurality <-
          case extractPrim <$> prim of
            Just (Just 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]
resTys Int
i
            Maybe (Maybe CompiledPrimitive)
_ ->
              Int -> NetlistMonad Int
forall a. a -> NetlistMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Int
1

        curBBlvl Lens.+= 1
        (fs,ds) <- case resIds of
          (Id
resId:[Id]
_) -> [((Either BlackBox (Identifier, [Declaration]), Usage,
   [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
   BlackBoxContext),
  [Declaration])]
-> ([(Either BlackBox (Identifier, [Declaration]), Usage,
      [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
      BlackBoxContext)],
    [[Declaration]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([((Either BlackBox (Identifier, [Declaration]), Usage,
    [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
    BlackBoxContext),
   [Declaration])]
 -> ([(Either BlackBox (Identifier, [Declaration]), Usage,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext)],
     [[Declaration]]))
-> NetlistMonad
     [((Either BlackBox (Identifier, [Declaration]), Usage,
        [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
        BlackBoxContext),
       [Declaration])]
-> NetlistMonad
     ([(Either BlackBox (Identifier, [Declaration]), Usage,
        [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 (Identifier, [Declaration]), Usage,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext),
      [Declaration])
-> NetlistMonad
     [((Either BlackBox (Identifier, [Declaration]), Usage,
        [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
        BlackBoxContext),
       [Declaration])]
forall (m :: Type -> Type) a. Applicative m => Int -> m a -> m [a]
replicateM Int
funcPlurality (HasCallStack =>
Text
-> DeclarationType
-> Id
-> Term
-> NetlistMonad
     ((Either BlackBox (Identifier, [Declaration]), Usage,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext),
      [Declaration])
Text
-> DeclarationType
-> Id
-> Term
-> NetlistMonad
     ((Either BlackBox (Identifier, [Declaration]), Usage,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext),
      [Declaration])
mkFunInput Text
bbName DeclarationType
declType Id
resId Term
arg)
          [Id]
_ -> [Char]
-> NetlistMonad
     ([(Either BlackBox (Identifier, [Declaration]), Usage,
        [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
        BlackBoxContext)],
      [[Declaration]])
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: insufficient resIds"
        curBBlvl Lens.-= 1

        let im' = Int
-> [(Either BlackBox (Identifier, [Declaration]), Usage,
     [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
     BlackBoxContext)]
-> IntMap
     [(Either BlackBox (Identifier, [Declaration]), Usage,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext)]
-> IntMap
     [(Either BlackBox (Identifier, [Declaration]), Usage,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext)]
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
i [(Either BlackBox (Identifier, [Declaration]), Usage,
  [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
  BlackBoxContext)]
fs IntMap
  [(Either BlackBox (Identifier, [Declaration]), Usage,
    [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
    BlackBoxContext)]
im
        return (im', concat ds)
      else
        return (im, [])

prepareBlackBox
  :: TextS.Text
  -> BlackBox
  -> BlackBoxContext
  -> NetlistMonad (BlackBox,[Declaration])
prepareBlackBox :: Text
-> BlackBox
-> BlackBoxContext
-> NetlistMonad (BlackBox, [Declaration])
prepareBlackBox Text
_pNm BlackBox
templ BlackBoxContext
bbCtx =
  case BlackBoxContext -> BlackBox -> Maybe [Char]
verifyBlackBoxContext BlackBoxContext
bbCtx BlackBox
templ of
    Maybe [Char]
Nothing -> do
      (t2,decls) <-
        (BlackBoxTemplate -> NetlistMonad (BlackBox, [Declaration]))
-> ([Char]
    -> Int
    -> TemplateFunction
    -> NetlistMonad (BlackBox, [Declaration]))
-> BlackBox
-> NetlistMonad (BlackBox, [Declaration])
forall r.
(BlackBoxTemplate -> r)
-> ([Char] -> Int -> TemplateFunction -> r) -> BlackBox -> r
onBlackBox
          (((BlackBoxTemplate, [Declaration]) -> (BlackBox, [Declaration]))
-> NetlistMonad (BlackBoxTemplate, [Declaration])
-> NetlistMonad (BlackBox, [Declaration])
forall a b. (a -> b) -> NetlistMonad a -> NetlistMonad b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((BlackBoxTemplate -> BlackBox)
-> (BlackBoxTemplate, [Declaration]) -> (BlackBox, [Declaration])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
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
. BlackBoxContext
-> BlackBoxTemplate
-> NetlistMonad (BlackBoxTemplate, [Declaration])
forall (m :: Type -> Type).
IdentifierSetMonad m =>
BlackBoxContext
-> BlackBoxTemplate -> m (BlackBoxTemplate, [Declaration])
setSym BlackBoxContext
bbCtx)
          (\[Char]
bbName Int
bbHash TemplateFunction
bbFunc -> (BlackBox, [Declaration]) -> NetlistMonad (BlackBox, [Declaration])
forall a. a -> NetlistMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Char] -> Int -> TemplateFunction -> BlackBox
BBFunction [Char]
bbName Int
bbHash TemplateFunction
bbFunc, []))
          BlackBox
templ
      for_ decls goDecl
      return (t2,decls)
    Just [Char]
err0 -> do
      (_,sp) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
      let err1 = [[Char]] -> [Char]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [ [Char]
"Couldn't instantiate blackbox for "
                        , Text -> [Char]
Data.Text.unpack (BlackBoxContext -> Text
bbName BlackBoxContext
bbCtx), [Char]
". Verification "
                        , [Char]
"procedure reported:\n\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err0 ]
      throw (ClashException sp ($(curLoc) ++ err1) Nothing)
 where
  -- Right now we assume that (1) a blackbox doesn't assign to a signal
  -- declared outside the black box template and (2) all uses of a signal
  -- within a blackbox are correct for the targeted HDL (i.e. we don't try
  -- to generate new signals when a signal is used incorrectly).
  goDecl :: Declaration -> NetlistMonad ()
goDecl = \case
    Assignment Identifier
i Usage
u Expr
_ ->
      Usage -> Identifier -> NetlistMonad ()
declareUse Usage
u Identifier
i

    CondAssignment Identifier
i HWType
_ Expr
_ HWType
_ [(Maybe Literal, Expr)]
_ -> do
      -- Currently, all CondAssignment get rendered as `always @*` blocks in
      -- (System)Verilog. This means when we target these HDL, this is _really_
      -- a blocking procedural assignment.
      SomeBackend b <- Getting SomeBackend NetlistState SomeBackend
-> NetlistMonad SomeBackend
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting SomeBackend NetlistState SomeBackend
Lens' NetlistState SomeBackend
backend
      let use = case backend -> HDL
forall state. Backend state => state -> HDL
Backend.hdlKind backend
b of { HDL
VHDL -> Usage
Cont ; HDL
_ -> Blocking -> Usage
Proc Blocking
Blocking }
      declareUse use i

    Seq [Seq]
seqs -> [Seq] -> (Seq -> NetlistMonad ()) -> NetlistMonad ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Seq]
seqs Seq -> NetlistMonad ()
goSeq

    Declaration
_ -> () -> NetlistMonad ()
forall a. a -> NetlistMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()

  goSeq :: Seq -> NetlistMonad ()
goSeq = \case
    AlwaysClocked ActiveEdge
_ Expr
_ [Seq]
seqs ->
      [Seq] -> (Seq -> NetlistMonad ()) -> NetlistMonad ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Seq]
seqs Seq -> NetlistMonad ()
goSeq

    Initial [Seq]
seqs ->
      [Seq] -> (Seq -> NetlistMonad ()) -> NetlistMonad ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Seq]
seqs Seq -> NetlistMonad ()
goSeq

    AlwaysComb [Seq]
seqs ->
      [Seq] -> (Seq -> NetlistMonad ()) -> NetlistMonad ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Seq]
seqs Seq -> NetlistMonad ()
goSeq

    SeqDecl Declaration
conc ->
      Declaration -> NetlistMonad ()
goDecl Declaration
conc

    Branch Expr
_ HWType
_ [(Maybe Literal, [Seq])]
alts ->
      let seqs :: [Seq]
seqs = ((Maybe Literal, [Seq]) -> [Seq])
-> [(Maybe Literal, [Seq])] -> [Seq]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (Maybe Literal, [Seq]) -> [Seq]
forall a b. (a, b) -> b
snd [(Maybe Literal, [Seq])]
alts
       in [Seq] -> (Seq -> NetlistMonad ()) -> NetlistMonad ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Seq]
seqs Seq -> NetlistMonad ()
goSeq

-- | Determine if a term represents a literal
isLiteral :: Term -> Bool
isLiteral :: Term -> Bool
isLiteral Term
e = case Term -> (Term, [Either Term Type])
collectArgs Term
e of
  (Data DataCon
_, [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 PrimInfo
_, [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 Literal
_,[Either Term Type]
_)  -> Bool
True
  (Term, [Either Term Type])
_                -> Bool
False


mkArgument
  :: TextS.Text
  -- ^ Blackbox function name
  -> Identifier
  -- ^ LHS of the original let-binder. Is used as a name hint to generate new
  -- names in case the argument is a declaration.
  -> DeclarationType
  -- ^ Are we concurrent or sequential?
  -> Int
  -- ^ Argument n (zero-indexed). Used for error message.
  -> Term
  -> NetlistMonad ( (Expr,HWType,Bool)
                  , [Declaration]
                  )
mkArgument :: Text
-> Identifier
-> DeclarationType
-> Int
-> Term
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
mkArgument Text
bbName Identifier
bndr DeclarationType
declType Int
nArg Term
e = do
    tcm   <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
    let ty = TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
e
    iw    <- Lens.view intWidth
    hwTyM <- fmap stripFiltered <$> N.termHWTypeM e
    let eTyMsg = [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
e [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" :: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Type
ty [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
    ((e',t,l),d) <- case hwTyM of
      Maybe HWType
Nothing
        | (Prim PrimInfo
p,[Either Term Type]
_) <- Term -> (Term, [Either Term Type])
collectArgs Term
e
        , PrimInfo -> Text
primName PrimInfo
p Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Text
forall a. Show a => a -> Text
showt 'removedArg
        -> ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Identifier -> Maybe Modifier -> Expr
Identifier (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake (Name -> Text
forall a. Show a => a -> Text
showt 'removedArg)) 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 a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (([Char] -> Expr
forall a. HasCallStack => [Char] -> a
error ($(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Forced to evaluate untranslatable type: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
eTyMsg), Maybe HWType -> HWType
Void Maybe HWType
forall a. Maybe a
Nothing, Bool
False), [])
      Just HWType
hwTy -> case Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks Term
e of
        (C.Var Id
v,[],[TickInfo]
_) -> do
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Identifier -> Maybe Modifier -> Expr
Identifier (HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId Id
v) Maybe Modifier
forall a. Maybe a
Nothing,HWType
hwTy,Bool
False),[])
        (C.Literal Literal
l,[],[TickInfo]
_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Int -> Literal -> Expr
mkLiteral Int
iw Literal
l,HWType
hwTy,Bool
True),[])

        (Prim PrimInfo
pinfo,[Either Term Type]
args,[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
$ \[Declaration]
tickDecls -> do
          (e',d) <- Bool
-> Bool
-> DeclarationType
-> NetlistId
-> PrimInfo
-> [Either Term Type]
-> [Declaration]
-> NetlistMonad (Expr, [Declaration])
mkPrimitive Bool
True Bool
False DeclarationType
declType (Identifier -> Type -> NetlistId
NetlistId Identifier
bndr Type
ty) PrimInfo
pinfo [Either Term Type]
args [Declaration]
tickDecls
          case e' of
            (Identifier Identifier
_ Maybe Modifier
_) -> ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Expr
e',HWType
hwTy,Bool
False), [Declaration]
d)
            Expr
_                -> ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Expr
e',HWType
hwTy,Term -> Bool
isLiteral Term
e), [Declaration]
d)
        (Data DataCon
dc, [Either Term Type]
args,[TickInfo]
_) -> do
          (exprN,dcDecls) <- HasCallStack =>
DeclarationType
-> [HWType]
-> NetlistId
-> DataCon
-> [Term]
-> NetlistMonad (Expr, [Declaration])
DeclarationType
-> [HWType]
-> NetlistId
-> DataCon
-> [Term]
-> NetlistMonad (Expr, [Declaration])
mkDcApplication DeclarationType
declType [HWType
hwTy] (Identifier -> Type -> NetlistId
NetlistId Identifier
bndr Type
ty) DataCon
dc ([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args)
          return ((exprN,hwTy,isLiteral e),dcDecls)
        (Case Term
scrut Type
ty' [Alt
alt],[],[TickInfo]
_) -> do
          (projection,decls) <- DeclarationType
-> Bool
-> NetlistId
-> Term
-> Type
-> Alt
-> NetlistMonad (Expr, [Declaration])
mkProjection DeclarationType
declType Bool
False (Identifier -> Type -> NetlistId
NetlistId Identifier
bndr Type
ty) Term
scrut Type
ty' Alt
alt
          return ((projection,hwTy,False),decls)
        (Let Bind Term
_bnds Term
_term, [], [TickInfo]
_ticks) -> do
          (exprN, letDecls) <- HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
declType (Identifier -> Type -> NetlistId
NetlistId Identifier
bndr Type
ty) Term
e
          return ((exprN,hwTy,False),letDecls)
        (Term, [Either Term Type], [TickInfo])
_ -> do
          let errMsg :: [Char]
errMsg = [I.i|
            Forced to evaluate unexpected function argument:

              #{eTyMsg}

            in 'mkArgument' for argument #{nArg} of blackbox #{show bbName}.
          |]

          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Identifier -> Maybe Modifier -> Expr
Identifier ([Char] -> Identifier
forall a. HasCallStack => [Char] -> a
error ($(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
errMsg)) Maybe Modifier
forall a. Maybe a
Nothing, HWType
hwTy, Bool
False), [])

    return ((e',t,l),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 :: HasCallStack => Text -> NetlistMonad CompiledPrimitive
extractPrimWarnOrFail Text
nm = do
  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)
  NetlistEnv
  (HashMap Text GuardedCompiledPrimitive)
-> NetlistMonad (HashMap Text GuardedCompiledPrimitive)
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting
  (HashMap Text GuardedCompiledPrimitive)
  NetlistEnv
  (HashMap Text GuardedCompiledPrimitive)
Getter NetlistEnv (HashMap Text GuardedCompiledPrimitive)
primitives
  case prim of
    Just (HasBlackBox [PrimitiveWarning]
warnings CompiledPrimitive
compiledPrim) ->
      -- See if we need to warn the user
      if [PrimitiveWarning] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [PrimitiveWarning]
warnings then CompiledPrimitive -> NetlistMonad CompiledPrimitive
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return CompiledPrimitive
compiledPrim else [PrimitiveWarning]
-> CompiledPrimitive -> NetlistMonad CompiledPrimitive
go [PrimitiveWarning]
warnings CompiledPrimitive
compiledPrim
    Just GuardedCompiledPrimitive
DontTranslate -> do
      -- We need to error because we encountered a primitive the user
      -- explicitly requested not to translate
      (_,sp) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
      let msg = $(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Clash was forced to translate '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack Text
nm
             [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"', but this value was marked with DontTranslate. Did you forget"
             [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" to include a blackbox for one of the constructs using this?"
             [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (if Bool
debugIsOn then [Char]
"\n\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CallStack -> [Char]
prettyCallStack CallStack
HasCallStack => CallStack
callStack [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n\n" else [])
      throw (ClashException sp msg Nothing)
    Maybe GuardedCompiledPrimitive
Nothing -> do
      -- Blackbox requested, but no blackbox found at all!
      (_,sp) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
      let msg = $(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"No blackbox found for: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack Text
nm
             [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
". Did you forget to include directories containing "
             [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"primitives? You can use '-i/my/prim/dir' to achieve this."
             [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (if Bool
debugIsOn then [Char]
"\n\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CallStack -> [Char]
prettyCallStack CallStack
HasCallStack => CallStack
callStack [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n\n" else [])
      throw (ClashException sp msg Nothing)
 where
  go
    :: [PrimitiveWarning]
    -> CompiledPrimitive
    -> NetlistMonad CompiledPrimitive

  go :: [PrimitiveWarning]
-> CompiledPrimitive -> NetlistMonad CompiledPrimitive
go ((WarnAlways [Char]
warning):[PrimitiveWarning]
ws) CompiledPrimitive
cp = do
    opts <- Getting ClashOpts NetlistEnv ClashOpts -> NetlistMonad ClashOpts
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting ClashOpts NetlistEnv ClashOpts
Getter NetlistEnv ClashOpts
clashOpts
    let primWarn = ClashOpts -> Bool
opt_primWarn ClashOpts
opts
    seen <- Set.member nm <$> Lens.use seenPrimitives

    when (primWarn && not seen)
      $ liftIO
      $ warn opts
      $ "Dubious primitive instantiation for "
     ++ unpack nm
     ++ ": "
     ++ warning
     ++ " (disable with -fclash-no-prim-warn)"

    go ws cp

  go ((WarnNonSynthesizable [Char]
warning):[PrimitiveWarning]
ws) CompiledPrimitive
cp = do
    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 isTB then go ws cp else go ((WarnAlways warning):ws) cp

  go [] CompiledPrimitive
cp = do
    (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 a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return CompiledPrimitive
cp

mkPrimitive
  :: Bool
  -- ^ Put BlackBox expression in parenthesis
  -> Bool
  -- ^ Treat BlackBox expression as declaration
  -> DeclarationType
  -- ^ Are we concurrent or sequential?
  -> NetlistId
  -- ^ Id to assign the result to
  -> PrimInfo
  -- ^ Primitive info
  -> [Either Term Type]
  -- ^ Arguments
  -> [Declaration]
  -- ^ Tick declarations
  -> NetlistMonad (Expr,[Declaration])
mkPrimitive :: Bool
-> Bool
-> DeclarationType
-> NetlistId
-> PrimInfo
-> [Either Term Type]
-> [Declaration]
-> NetlistMonad (Expr, [Declaration])
mkPrimitive Bool
bbEParen Bool
bbEasD DeclarationType
declType NetlistId
dst PrimInfo
pInfo [Either Term Type]
args [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
    tys :: [Type]
tys = NetlistId -> [Type]
netlistTypes NetlistId
dst
    ty :: Type
ty = Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Type
forall a. HasCallStack => [Char] -> a
error [Char]
"mkPrimitive") ([Type] -> Maybe Type
forall a. [a] -> Maybe a
listToMaybe [Type]
tys)
    assignTy :: Usage
assignTy = DeclarationType -> Usage
declTypeUsage DeclarationType
declType

    go
      :: CompiledPrimitive
      -> NetlistMonad (Expr, [Declaration])
    go :: CompiledPrimitive -> NetlistMonad (Expr, [Declaration])
go =
      \case
        P.BlackBoxHaskell Text
bbName WorkInfo
wf UsedArguments
_usedArgs Bool
multiResult BlackBoxFunctionName
funcName (Int
_fHash, BlackBoxFunction
func) -> do
          bbFunRes <- BlackBoxFunction
func Bool
bbEasD (PrimInfo -> Text
primName PrimInfo
pInfo) [Either Term Type]
args [Type]
tys
          case bbFunRes of
            Left [Char]
err -> do
              -- Blackbox template function returned an error:
              let err' :: [Char]
err' = [[Char]] -> [Char]
unwords [ $(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Could not create blackbox"
                                 , [Char]
"template using", BlackBoxFunctionName -> [Char]
forall a. Show a => a -> [Char]
show BlackBoxFunctionName
funcName, [Char]
"for"
                                 , Text -> [Char]
forall a. Show a => a -> [Char]
show Text
bbName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".", [Char]
"Function reported: \n\n"
                                 , [Char]
err ]
              (_,sp) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
              throw (ClashException sp err' Nothing)
            Right (BlackBoxMeta {[BlackBoxTemplate]
[(Int, Int)]
[((Text, Text), BlackBox)]
[BlackBox]
Usage
TemplateKind
RenderVoid
bbOutputUsage :: Usage
bbKind :: TemplateKind
bbLibrary :: [BlackBoxTemplate]
bbImports :: [BlackBoxTemplate]
bbFunctionPlurality :: [(Int, Int)]
bbIncludes :: [((Text, Text), BlackBox)]
bbRenderVoid :: RenderVoid
bbResultNames :: [BlackBox]
bbResultInits :: [BlackBox]
bbResultInits :: BlackBoxMeta -> [BlackBox]
bbResultNames :: BlackBoxMeta -> [BlackBox]
bbRenderVoid :: BlackBoxMeta -> RenderVoid
bbIncludes :: BlackBoxMeta -> [((Text, Text), BlackBox)]
bbFunctionPlurality :: BlackBoxMeta -> [(Int, Int)]
bbImports :: BlackBoxMeta -> [BlackBoxTemplate]
bbLibrary :: BlackBoxMeta -> [BlackBoxTemplate]
bbKind :: BlackBoxMeta -> TemplateKind
bbOutputUsage :: BlackBoxMeta -> Usage
..}, BlackBox
bbTemplate) ->
              -- Blackbox template generation successful. Rerun 'go', but this time
              -- around with a 'normal' @BlackBox@
              CompiledPrimitive -> NetlistMonad (Expr, [Declaration])
go (Text
-> WorkInfo
-> RenderVoid
-> Bool
-> TemplateKind
-> ()
-> Usage
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [(Int, Int)]
-> [((Text, Text), BlackBox)]
-> [BlackBox]
-> [BlackBox]
-> BlackBox
-> CompiledPrimitive
forall a b c d.
Text
-> WorkInfo
-> RenderVoid
-> Bool
-> TemplateKind
-> c
-> Usage
-> [a]
-> [a]
-> [(Int, Int)]
-> [((Text, Text), b)]
-> [b]
-> [b]
-> b
-> Primitive a b c d
P.BlackBox
                    Text
bbName WorkInfo
wf RenderVoid
bbRenderVoid Bool
multiResult TemplateKind
bbKind () Usage
bbOutputUsage
                    [BlackBoxTemplate]
bbLibrary [BlackBoxTemplate]
bbImports [(Int, Int)]
bbFunctionPlurality [((Text, Text), BlackBox)]
bbIncludes
                    [BlackBox]
bbResultNames [BlackBox]
bbResultInits BlackBox
bbTemplate)
        -- See 'setupMultiResultPrim' in "Clash.Normalize.Transformations":
        P.BlackBox {name :: forall a b c d. Primitive a b c d -> Text
name=Text
"c$multiPrimSelect"} ->
          (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall a. a -> NetlistMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Expr
Noop, [])
        p :: CompiledPrimitive
p@P.BlackBox {multiResult :: forall a b c d. Primitive a b c d -> Bool
multiResult=Bool
True, Text
name :: forall a b c d. Primitive a b c d -> Text
name :: Text
name, BlackBox
template :: BlackBox
template :: forall a b c d. Primitive a b c d -> b
template} -> do
          -- Multi result primitives assign their results to signals
          -- provided as arguments. Hence, we ignore any declarations
          -- from 'resBndr1'.
          tcm <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
          let (args1, resArgs) = splitMultiPrimArgs (multiPrimInfo' tcm pInfo) args
          (bbCtx, ctxDcls) <- mkBlackBoxContext (primName pInfo) declType resArgs args1
          (templ, templDecl) <- prepareBlackBox name template bbCtx
          let bbDecl = Text
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> BlackBoxContext
-> Declaration
N.BlackBoxD Text
name (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
          return (Noop, ctxDcls ++ templDecl ++ tickDecls ++ [bbDecl])
        p :: CompiledPrimitive
p@(P.BlackBox {BlackBox
template :: forall a b c d. Primitive a b c d -> b
template :: BlackBox
template, name :: forall a b c d. Primitive a b c d -> Text
name=Text
pNm, TemplateKind
kind :: TemplateKind
kind :: forall a b c d. Primitive a b c d -> TemplateKind
kind,Usage
outputUsage :: Usage
outputUsage :: forall a b c d. Primitive a b c d -> Usage
outputUsage}) ->
          case TemplateKind
kind of
            TemplateKind
TDecl -> do
              resM <- HasCallStack =>
Bool
-> NetlistId
-> NetlistMonad (Maybe (Id, Identifier, [Declaration]))
Bool
-> NetlistId
-> NetlistMonad (Maybe (Id, Identifier, [Declaration]))
resBndr1 Bool
True NetlistId
dst
              case resM of
                Just (Id
dst',Identifier
dstNm,[Declaration]
dstDecl) -> do
                  (bbCtx,ctxDcls)   <- HasCallStack =>
Text
-> DeclarationType
-> [Id]
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
Text
-> DeclarationType
-> [Id]
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext (PrimInfo -> Text
primName PrimInfo
pInfo) DeclarationType
declType [Id
dst'] [Either Term Type]
args
                  (templ,templDecl) <- prepareBlackBox pNm template bbCtx
                  let 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
                  declareUse outputUsage dstNm
                  return (Identifier dstNm Nothing,dstDecl ++ ctxDcls ++ templDecl ++ tickDecls ++ [bbDecl])

                -- Render declarations as a Noop when requested
                Maybe (Id, Identifier, [Declaration])
Nothing | RenderVoid
RenderVoid <- CompiledPrimitive -> RenderVoid
forall a b c d. Primitive a b c d -> RenderVoid
renderVoid CompiledPrimitive
p -> do
                  -- TODO: We should probably 'mkBlackBoxContext' to accept empty lists
                  let dst1 :: Id
dst1 = Type -> TmName -> Id
mkLocalId Type
ty (Text -> Unique -> TmName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"__VOID_TDECL_NOOP__" Unique
0)
                  (bbCtx,ctxDcls) <- HasCallStack =>
Text
-> DeclarationType
-> [Id]
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
Text
-> DeclarationType
-> [Id]
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext (PrimInfo -> Text
primName PrimInfo
pInfo) DeclarationType
declType [Id
dst1] [Either Term Type]
args
                  (templ,templDecl) <- prepareBlackBox pNm template bbCtx
                  let 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
                  return (Noop, ctxDcls ++ templDecl ++ tickDecls ++ [bbDecl])

                -- Otherwise don't render them
                Maybe (Id, Identifier, [Declaration])
Nothing -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
Noop,[])
            TemplateKind
TExpr -> do
              if Bool
bbEasD
                then do
                  resM <- HasCallStack =>
Bool
-> NetlistId
-> NetlistMonad (Maybe (Id, Identifier, [Declaration]))
Bool
-> NetlistId
-> NetlistMonad (Maybe (Id, Identifier, [Declaration]))
resBndr1 Bool
True NetlistId
dst
                  case resM of
                    Just (Id
dst',Identifier
dstNm,[Declaration]
dstDecl) -> do
                      (bbCtx,ctxDcls) <- HasCallStack =>
Text
-> DeclarationType
-> [Id]
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
Text
-> DeclarationType
-> [Id]
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext (PrimInfo -> Text
primName PrimInfo
pInfo) DeclarationType
declType [Id
dst'] [Either Term Type]
args
                      (bbTempl,templDecl) <- prepareBlackBox pNm template bbCtx
                      let bbE =  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
                      tmpAssgn <- case declType of
                        DeclarationType
Concurrent -> HasCallStack => Identifier -> Expr -> NetlistMonad Declaration
Identifier -> Expr -> NetlistMonad Declaration
contAssign Identifier
dstNm Expr
bbE
                        DeclarationType
Sequential -> HasCallStack =>
Blocking -> Identifier -> Expr -> NetlistMonad Declaration
Blocking -> Identifier -> Expr -> NetlistMonad Declaration
procAssign Blocking
Blocking Identifier
dstNm Expr
bbE
                      return (Identifier dstNm Nothing, dstDecl ++ ctxDcls ++ templDecl ++ [tmpAssgn])

                    -- Render expression as a Noop when requested
                    Maybe (Id, Identifier, [Declaration])
Nothing | RenderVoid
RenderVoid <- CompiledPrimitive -> RenderVoid
forall a b c d. Primitive a b c d -> RenderVoid
renderVoid CompiledPrimitive
p -> do
                      -- TODO: We should probably 'mkBlackBoxContext' to accept empty lists
                      let dst1 :: Id
dst1 = Type -> TmName -> Id
mkLocalId Type
ty (Text -> Unique -> TmName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"__VOID_TEXPRD_NOOP__" Unique
0)
                      (bbCtx,ctxDcls) <- HasCallStack =>
Text
-> DeclarationType
-> [Id]
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
Text
-> DeclarationType
-> [Id]
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext (PrimInfo -> Text
primName PrimInfo
pInfo) DeclarationType
declType [Id
dst1] [Either Term Type]
args
                      (templ,templDecl) <- prepareBlackBox pNm template bbCtx
                      let 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
                      return (Noop, ctxDcls ++ templDecl ++ tickDecls ++ [bbDecl])

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

                    -- Otherwise don't render them
                    Maybe (Id, Identifier, [Declaration])
Nothing -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Identifier -> Maybe Modifier -> Expr
Identifier (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"__VOID__") Maybe Modifier
forall a. Maybe a
Nothing,[])
        P.Primitive Text
pNm WorkInfo
_ Text
_
          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Prim.tagToEnum#" -> do
              hwTy <- [Char] -> Type -> NetlistMonad HWType
N.unsafeCoreTypeToHWTypeM' $(curLoc) Type
ty
              case args of
                [Right (ConstTy (TyCon TyConName
tcN)), Left (C.Literal (IntLiteral Integer
i))] -> do
                  tcm <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
                  let dcs = TyCon -> [DataCon]
tyConDataCons (TyConName -> TyConMap -> TyCon
forall a b. Uniquable a => a -> UniqMap b -> b
UniqMap.find TyConName
tcN TyConMap
tcm)
                      dc  = [DataCon]
dcs [DataCon] -> Int -> DataCon
forall a. HasCallStack => [a] -> Int -> a
!! Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i
                  (exprN,dcDecls) <- mkDcApplication declType [hwTy] dst dc []
                  return (exprN,dcDecls)
                [Right Type
_, Left Term
scrut] -> do
                  tcm     <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
                  let scrutTy = TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
scrut
                  (scrutExpr,scrutDecls) <-
                    mkExpr False declType (NetlistId (Id.unsafeMake "c$tte_rhs") scrutTy) scrut
                  case scrutExpr of
                    Identifier Identifier
id_ Maybe Modifier
Nothing -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Either Identifier Identifier -> Expr
DataTag HWType
hwTy (Identifier -> Either Identifier Identifier
forall a b. a -> Either a b
Left Identifier
id_),[Declaration]
scrutDecls)
                    Expr
_ -> do
                      scrutHTy <- [Char] -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(curLoc) Type
scrutTy
                      tmpRhs <- Id.make "c$tte_rhs"
                      netDecl <- N.mkInit declType assignTy tmpRhs scrutHTy scrutExpr
                      return (DataTag hwTy (Left tmpRhs), netDecl ++ scrutDecls)
                [Either Term Type]
_ -> [Char] -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => [Char] -> a
error ([Char] -> NetlistMonad (Expr, [Declaration]))
-> [Char] -> NetlistMonad (Expr, [Declaration])
forall a b. (a -> b) -> a -> b
$ $(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"tagToEnum: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show ((Either Term Type -> [Char]) -> [Either Term Type] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> [Char]) -> (Type -> [Char]) -> Either Term Type -> [Char]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Type -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr) [Either Term Type]
args)
          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Prim.dataToTag#" -> case [Either Term Type]
args of
              [Right Type
_,Left (Data DataCon
dc)] -> do
                iw <- Getting Int NetlistEnv Int -> NetlistMonad Int
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting Int NetlistEnv Int
Getter NetlistEnv Int
intWidth
                return (N.Literal (Just (Signed iw,iw)) (NumLit $ toInteger $ dcTag dc - 1),[])
              [Right Type
_,Left Term
scrut] -> do
                tcm      <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
                let scrutTy = TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
scrut
                scrutHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy
                (scrutExpr,scrutDecls) <-
                  mkExpr False declType (NetlistId (Id.unsafeMake "c$dtt_rhs") scrutTy) scrut
                case scrutExpr of
                  Identifier Identifier
id_ Maybe Modifier
Nothing -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Either Identifier Identifier -> Expr
DataTag HWType
scrutHTy (Identifier -> Either Identifier Identifier
forall a b. b -> Either a b
Right Identifier
id_),[Declaration]
scrutDecls)
                  Expr
_ -> do
                    tmpRhs <- Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.make Text
"c$dtt_rhs"
                    netDecl <- N.mkInit declType assignTy tmpRhs scrutHTy scrutExpr
                    return (DataTag scrutHTy (Right tmpRhs),netDecl ++ scrutDecls)
              [Either Term Type]
_ -> [Char] -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => [Char] -> a
error ([Char] -> NetlistMonad (Expr, [Declaration]))
-> [Char] -> NetlistMonad (Expr, [Declaration])
forall a b. (a -> b) -> a -> b
$ $(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"dataToTag: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show ((Either Term Type -> [Char]) -> [Either Term Type] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> [Char]) -> (Type -> [Char]) -> Either Term Type -> [Char]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Type -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr) [Either Term Type]
args)

          | Text
pNm Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem`
            [Text
"GHC.Prim.dataToTagSmall#", Text
"GHC.Prim.dataToTagLarge#"] -> case [Either Term Type]
args of
              [Right Type
_, Right Type
_,Left (Data DataCon
dc)] -> do
                iw <- Getting Int NetlistEnv Int -> NetlistMonad Int
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting Int NetlistEnv Int
Getter NetlistEnv Int
intWidth
                return (N.Literal (Just (Signed iw,iw)) (NumLit $ toInteger $ dcTag dc - 1),[])
              [Right Type
_, Right Type
_,Left Term
scrut] -> do
                tcm      <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
                let scrutTy = TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
scrut
                scrutHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy
                (scrutExpr,scrutDecls) <-
                  mkExpr False declType (NetlistId (Id.unsafeMake "c$dtt_rhs") scrutTy) scrut
                case scrutExpr of
                  Identifier Identifier
id_ Maybe Modifier
Nothing -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Either Identifier Identifier -> Expr
DataTag HWType
scrutHTy (Identifier -> Either Identifier Identifier
forall a b. b -> Either a b
Right Identifier
id_),[Declaration]
scrutDecls)
                  Expr
_ -> do
                    tmpRhs <- Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.make Text
"c$dtt_rhs"
                    netDecl <- N.mkInit declType assignTy tmpRhs scrutHTy scrutExpr
                    return (DataTag scrutHTy (Right tmpRhs),netDecl ++ scrutDecls)
              [Either Term Type]
_ -> [Char] -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => [Char] -> a
error ([Char] -> NetlistMonad (Expr, [Declaration]))
-> [Char] -> NetlistMonad (Expr, [Declaration])
forall a b. (a -> b) -> a -> b
$ $(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"dataToTag: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show ((Either Term Type -> [Char]) -> [Either Term Type] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> [Char]) -> (Type -> [Char]) -> Either Term Type -> [Char]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Type -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr) [Either Term Type]
args)

          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Explicit.SimIO.mealyIO" -> do
              resM <- HasCallStack =>
Bool
-> NetlistId
-> NetlistMonad (Maybe (Id, Identifier, [Declaration]))
Bool
-> NetlistId
-> NetlistMonad (Maybe (Id, Identifier, [Declaration]))
resBndr1 Bool
True NetlistId
dst
              case resM of
                Just (Id
_,Identifier
dstNm,[Declaration]
dstDecl) -> do
                  tcm <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
                  mealyDecls <- collectMealy dstNm dst tcm (lefts args)
                  return (Noop, dstDecl ++ mealyDecls)
                Maybe (Id, Identifier, [Declaration])
Nothing -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall a. a -> NetlistMonad a
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
== Text
"Clash.Explicit.SimIO.bindSimIO#" -> do
              (expr,decls) <- NetlistId -> [Term] -> NetlistMonad (Expr, [Declaration])
collectBindIO NetlistId
dst ([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args)
              resM <- resBndr True dst
              case resM of
                Just ([Id]
_,[Identifier]
dstNms,[Declaration]
dstDecl) -> case Expr
expr of
                  Expr
Noop ->
                    (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
Noop,[Declaration]
decls)
                  Expr
_ -> case [Identifier]
dstNms of
                    [Identifier
dstNm] -> do
                      Usage -> Identifier -> NetlistMonad ()
declareUse (Blocking -> Usage
Proc Blocking
Blocking) Identifier
dstNm
                      assn <- HasCallStack =>
Blocking -> Identifier -> Expr -> NetlistMonad Declaration
Blocking -> Identifier -> Expr -> NetlistMonad Declaration
procAssign Blocking
Blocking Identifier
dstNm Expr
expr
                      return ( Identifier dstNm Nothing
                             , dstDecl ++ decls ++ [assn])
                    [Identifier]
_ -> [Char] -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => [Char] -> a
error ([Char] -> NetlistMonad (Expr, [Declaration]))
-> [Char] -> NetlistMonad (Expr, [Declaration])
forall a b. (a -> b) -> a -> b
$ $(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"bindSimIO: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe ([Id], [Identifier], [Declaration]) -> [Char]
forall a. Show a => a -> [Char]
show Maybe ([Id], [Identifier], [Declaration])
resM
                Maybe ([Id], [Identifier], [Declaration])
_ ->
                  (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
Noop,[Declaration]
decls)

          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"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
== Text
"Clash.Explicit.SimIO.fmapSimIO#" -> do
              resM <- HasCallStack =>
Bool
-> NetlistId
-> NetlistMonad (Maybe (Id, Identifier, [Declaration]))
Bool
-> NetlistId
-> NetlistMonad (Maybe (Id, Identifier, [Declaration]))
resBndr1 Bool
True NetlistId
dst
              case resM of
                Just (Id
_,Identifier
dstNm,[Declaration]
dstDecl) -> case [Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args of
                  (Term
fun0:Term
arg0:[Term]
_) -> do
                    tcm <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
                    let arg1 = TyConMap -> Term -> Term
unSimIO TyConMap
tcm Term
arg0
                        fun1 = case Term
fun0 of
                          Lam Id
b Term
bE ->
                            let is0 :: InScopeSet
is0 = UniqMap (Var Any) -> InScopeSet
mkInScopeSet (Getting (UniqMap (Var Any)) Term Id
-> (Id -> UniqMap (Var Any)) -> Term -> UniqMap (Var Any)
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting (UniqMap (Var Any)) Term Id
Fold Term Id
freeIds Id -> UniqMap (Var Any)
forall a. Var a -> UniqMap (Var Any)
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 Doc ()
"mkPrimitive.fmapSimIO" Subst
subst Term
bE
                          Term
_ -> Term -> [Either Term Type] -> Term
mkApps Term
fun0 [Term -> Either Term Type
forall a b. a -> Either a b
Left Term
arg1]
                    (expr,bindDecls) <- mkExpr False Sequential dst fun1
                    assn <- case expr of
                              Expr
Noop -> [Declaration] -> NetlistMonad [Declaration]
forall a. a -> NetlistMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
                              Expr
_ -> do Usage -> Identifier -> NetlistMonad ()
declareUse (Blocking -> Usage
Proc Blocking
Blocking) Identifier
dstNm
                                      assn <- HasCallStack =>
Blocking -> Identifier -> Expr -> NetlistMonad Declaration
Blocking -> Identifier -> Expr -> NetlistMonad Declaration
procAssign Blocking
Blocking Identifier
dstNm Expr
expr
                                      pure [assn]
                    return (Identifier dstNm Nothing, dstDecl ++ bindDecls ++ assn)
                  [Term]
args1 -> [Char] -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => [Char] -> a
error ([Char]
"internal error: fmapSimIO# has insufficient arguments"
                                  [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Term] -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr [Term]
args1)
                Maybe (Id, Identifier, [Declaration])
Nothing -> case [Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args of
                  (Term
_:Term
arg0:[Term]
_) -> do
                    (_,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
                    return (Noop, bindDecls)
                  [Term]
args1 -> [Char] -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => [Char] -> a
error ([Char]
"internal error: fmapSimIO# has insufficient arguments"
                                  [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Term] -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr [Term]
args1)


          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Explicit.SimIO.unSimIO#" ->
              case [Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args of
                (Term
arg:[Term]
_) -> HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Sequential NetlistId
dst Term
arg
                [Term]
_ -> [Char] -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: insufficient arguments"

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

          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Num.Integer.IS" -> do
              (expr,decls) <- case [Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args of
                (Term
arg:[Term]
_) -> HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
declType NetlistId
dst Term
arg
                [Term]
_ -> [Char] -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: insufficient arguments"
              iw <- Lens.view intWidth
              return (N.DataCon (Signed iw) (DC (Void Nothing,-1)) [expr],decls)

          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Num.Integer.IP" -> do
              (expr,decls) <- case [Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args of
                (Term
arg:[Term]
_) -> HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
declType NetlistId
dst Term
arg
                [Term]
_ -> [Char] -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: insufficient arguments"
              case expr of
                N.Literal Maybe (HWType, Int)
Nothing (NumLit Integer
_) -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
expr,[Declaration]
decls)
                Expr
_ -> [Char] -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => [Char] -> a
error [Char]
"non-constant ByteArray# not supported"

          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Num.Integer.IN" -> do
              (expr,decls) <- case [Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args of
                (Term
arg:[Term]
_) -> HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
declType NetlistId
dst Term
arg
                [Term]
_ -> [Char] -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: insufficient arguments"
              case expr of
                N.Literal Maybe (HWType, Int)
Nothing (NumLit Integer
i) ->
                  (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall a. a -> NetlistMonad a
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 (Integer -> Literal
NumLit (Integer -> Integer
forall a. Num a => a -> a
negate Integer
i)),[Declaration]
decls)
                Expr
_ -> [Char] -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => [Char] -> a
error [Char]
"non-constant ByteArray# not supported"

          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Num.Natural.NS" -> do
              (expr,decls) <- case [Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args of
                (Term
arg:[Term]
_) -> HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
declType NetlistId
dst Term
arg
                [Term]
_ -> [Char] -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: insufficient arguments"
              iw <- Lens.view intWidth
              return (N.DataCon (Unsigned iw) (DC (Void Nothing,-1)) [expr],decls)

          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Num.Integer.NB" -> do
              (expr,decls) <- case [Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args of
                (Term
arg:[Term]
_) -> HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
declType NetlistId
dst Term
arg
                [Term]
_ -> [Char] -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: insufficient arguments"
              case expr of
                N.Literal Maybe (HWType, Int)
Nothing (NumLit Integer
_) -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
expr,[Declaration]
decls)
                Expr
_ -> [Char] -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => [Char] -> a
error [Char]
"non-constant ByteArray# not supported"

          | Bool
otherwise ->
              (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> BlackBoxContext
-> Bool
-> Expr
BlackBoxE Text
"" [] [] []
                        (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 [Text
"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], [Identifier], [Declaration]))
resBndr Bool
mkDec NetlistId
dst' = do
      resHwTy <- case [Type]
tys of
        (Type
ty1:[Type]
_) -> [Char] -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(curLoc) Type
ty1
        [Type]
_ -> [Char] -> NetlistMonad HWType
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: insufficient types"
      if isVoid resHwTy then
        pure Nothing
      else
        case dst' of
          NetlistId Identifier
dstL Type
ty' -> case Bool
mkDec of
            Bool
False -> do
              -- TODO: check that it's okay to use `mkUnsafeSystemName`
              let nm' :: Name a
nm' = Text -> Unique -> Name a
forall a. Text -> Unique -> Name a
mkUnsafeSystemName (Identifier -> Text
Id.toText Identifier
dstL) Unique
0
                  id_ :: Id
id_ = Type -> TmName -> Id
mkLocalId Type
ty' TmName
forall {a}. Name a
nm'
              Maybe ([Id], [Identifier], [Declaration])
-> NetlistMonad (Maybe ([Id], [Identifier], [Declaration]))
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (([Id], [Identifier], [Declaration])
-> Maybe ([Id], [Identifier], [Declaration])
forall a. a -> Maybe a
Just ([Id
id_],[Identifier
dstL],[]))
            Bool
True -> do
              nm2 <- Identifier -> Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Identifier -> Text -> m Identifier
Id.suffix Identifier
dstL Text
"res"
              -- TODO: check that it's okay to use `mkUnsafeInternalName`
              let nm3 = Text -> Unique -> Name a
forall a. Text -> Unique -> Name a
mkUnsafeSystemName (Identifier -> Text
Id.toText Identifier
nm2) Unique
0
                  id_ = Type -> TmName -> Id
mkLocalId Type
ty TmName
forall {a}. Name a
nm3

              idDeclM <- mkNetDecl (id_, mkApps (Prim pInfo) args)
              case idDeclM of
                [] -> Maybe ([Id], [Identifier], [Declaration])
-> NetlistMonad (Maybe ([Id], [Identifier], [Declaration]))
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe ([Id], [Identifier], [Declaration])
forall a. Maybe a
Nothing
                [Declaration
idDecl] -> Maybe ([Id], [Identifier], [Declaration])
-> NetlistMonad (Maybe ([Id], [Identifier], [Declaration]))
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (([Id], [Identifier], [Declaration])
-> Maybe ([Id], [Identifier], [Declaration])
forall a. a -> Maybe a
Just ([Id
id_],[Identifier
nm2],[Declaration
idDecl]))
                [Declaration]
ids -> [Char] -> NetlistMonad (Maybe ([Id], [Identifier], [Declaration]))
forall a. HasCallStack => [Char] -> a
error [I.i|
                  Unexpected nested use of multi result primitive. Ids:

                    #{show ids}

                  Multi primitive should only appear on the RHS of a
                  let-binding. Please report this as a bug.
                |]

          CoreId Id
dstR ->
            Maybe ([Id], [Identifier], [Declaration])
-> NetlistMonad (Maybe ([Id], [Identifier], [Declaration]))
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (([Id], [Identifier], [Declaration])
-> Maybe ([Id], [Identifier], [Declaration])
forall a. a -> Maybe a
Just ([Id
dstR], [HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId Id
dstR], []))
          MultiId [Id]
ids ->
            Maybe ([Id], [Identifier], [Declaration])
-> NetlistMonad (Maybe ([Id], [Identifier], [Declaration]))
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (([Id], [Identifier], [Declaration])
-> Maybe ([Id], [Identifier], [Declaration])
forall a. a -> Maybe a
Just ([Id]
ids, (Id -> Identifier) -> [Id] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId [Id]
ids, []))

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