{-# 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
  => 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 :: HasCallStack =>
Identifier
-> NetlistId -> TyConMap -> [Term] -> NetlistMonad [Declaration]
collectMealy Identifier
dstNm NetlistId
dst TyConMap
tcm (Term
kd:Term
clk:Term
mealyFun:Term
mealyInit:Term
mealyIn:[Term]
_) = do
  let ([Either Id TyVar] -> [Id]
forall a b. [Either a b] -> [a]
lefts -> [Id]
args0,Term
res0) = Term -> ([Either Id TyVar], Term)
collectBndrs Term
mealyFun
      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
res0 UniqMap (Var Any) -> UniqMap (Var Any) -> UniqMap (Var Any)
forall a. Semigroup a => a -> a -> a
<>
                          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
mealyInit UniqMap (Var Any) -> UniqMap (Var Any) -> UniqMap (Var Any)
forall a. Semigroup a => a -> a -> a
<>
                          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
mealyIn)
      -- Given that we're creating a sequential list of statements from the
      -- let-bindings, make sure that everything is inverse topologically sorted
      ([LetBinding]
bs,Id
res) = case Term
res0 of
        Letrec [LetBinding]
bsU Term
e | let bsN :: [LetBinding]
bsN = HasCallStack => [LetBinding] -> [LetBinding]
[LetBinding] -> [LetBinding]
inverseTopSortLetBindings [LetBinding]
bsU -> case Term
e of
          C.Var Id
resN -> ([LetBinding]
bsN,Id
resN)
          Term
_ ->
            let u :: Id
u = case NetlistId
dst of
                      CoreId Id
u0 -> Id
u0
                      NetlistId
_ -> InScopeSet -> Id -> Id
forall a. (Uniquable a, ClashPretty a) => InScopeSet -> a -> a
uniqAway InScopeSet
is0
                            (Type -> TmName -> Id
mkLocalId (TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
e)
                                        (Text -> Unique -> TmName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"mealyres" Unique
0))
            in  ([LetBinding]
bsN [LetBinding] -> [LetBinding] -> [LetBinding]
forall a. [a] -> [a] -> [a]
++ [(Id
u,Term
e)], Id
u)
        Term
e ->
          let u :: Id
u = case NetlistId
dst of
                    CoreId Id
u0 -> Id
u0
                    NetlistId
_ -> InScopeSet -> Id -> Id
forall a. (Uniquable a, ClashPretty a) => InScopeSet -> a -> a
uniqAway InScopeSet
is0
                           (Type -> TmName -> Id
mkLocalId (TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
e)
                                      (Text -> Unique -> TmName
forall a. Text -> Unique -> Name a
mkUnsafeSystemName Text
"mealyres" Unique
0))
          in  ([(Id
u,Term
e)], Id
u)
#if __GLASGOW_HASKELL__ >= 900
      args1 :: [Id]
args1 = [Id]
args0
#else
      -- Drop the 'State# World' argument
      args1 = init args0
#endif
      -- 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 a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length (TyConMap -> [Type] -> [Type]
splitShouldSplit TyConMap
tcm [TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
mealyInit])
      ([Id]
sArgs,[Id]
iArgs) = Int -> [Id] -> ([Id], [Id])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
mealyInitLength [Id]
args1
  -- Give all binders a unique name
  let sBindings :: [LetBinding]
sBindings = (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
  normE <- HasCallStack =>
InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([Bool], [(Identifier, HWType)], [Declaration],
      [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([Bool], [(Identifier, HWType)], [Declaration],
      [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
mkUniqueNormalized InScopeSet
is0 Maybe (Maybe TopEntity)
forall a. Maybe a
Nothing ([], [LetBinding]
sBindings, Id
res)
  case normE of
    -- We're not expecting any input or output wrappers
    ([Bool]
_,[],[],[(Identifier, HWType)]
_,[],[LetBinding]
binders0,Just Id
result) -> do
      let ([LetBinding]
sBinders,[LetBinding]
binders1) = Int -> [LetBinding] -> ([LetBinding], [LetBinding])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Id] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Id]
sArgs) [LetBinding]
binders0
          ([LetBinding]
iBinders,[LetBinding]
binders2) = Int -> [LetBinding] -> ([LetBinding], [LetBinding])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Id] -> Int
forall a. [a] -> 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 [LetBinding]
_ (C.Var {}) -> [LetBinding]
binders2
            Term
_                   -> [LetBinding] -> [LetBinding]
forall a. HasCallStack => [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
      netDeclsSeq <- (LetBinding -> NetlistMonad [Declaration])
-> [LetBinding] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m [b]) -> [a] -> m [b]
concatMapM LetBinding -> NetlistMonad [Declaration]
mkNetDecl ([LetBinding]
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'
      netDeclsInp <- concatMapM mkNetDecl 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 = case Term
res0 of
                        Letrec [LetBinding]
_ (C.Var {}) -> [LetBinding]
binders2
                        Term
_ -> case NetlistId
dst of
                          -- See above why we do this.
                          CoreId Id
u0 -> [LetBinding] -> [LetBinding]
forall a. HasCallStack => [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. HasCallStack => [a] -> a
last [LetBinding]
binders2))]
                          NetlistId
_ -> [LetBinding]
binders2
      seqDecls <- concat <$> mapM (uncurry (mkDeclarations' Sequential)) 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,resDecls) <- case res0 of
        Letrec [LetBinding]
_ (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)
        Term
_ -> case NetlistId
dst of
          CoreId {} -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall a. a -> NetlistMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Expr
Noop,[])
          NetlistId
_ -> HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Sequential NetlistId
dst (Id -> Term
C.Var Id
result)

      resAssn <- case resExpr of
            Expr
Noop -> [Declaration] -> NetlistMonad [Declaration]
forall a. a -> NetlistMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
            Expr
_ -> do
              assign <- Declaration -> Seq
SeqDecl (Declaration -> Seq)
-> NetlistMonad Declaration -> NetlistMonad Seq
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack =>
Blocking -> Identifier -> Expr -> NetlistMonad Declaration
Blocking -> Identifier -> Expr -> NetlistMonad Declaration
procAssign Blocking
Blocking Identifier
dstNm Expr
resExpr
              pure [Seq [AlwaysComb [assign]]]

      -- Create the declarations for the "initial state" block
      let sDst = case [LetBinding]
sBinders of
                   [] -> [Char] -> NetlistId
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: insufficient sBinders"
                   [(Id
b,Term
_)] -> Id -> NetlistId
CoreId Id
b
                   [LetBinding]
_       -> [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,initDecls) <- mkExpr False Sequential sDst mealyInit

      initAssign <- case exprInit of
        Identifier Identifier
_ Maybe Modifier
Nothing -> [Declaration] -> NetlistMonad [Declaration]
forall a. a -> NetlistMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
        Expr
Noop -> [Declaration] -> NetlistMonad [Declaration]
forall a. a -> NetlistMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
        Expr
_ -> case [LetBinding]
sBinders of
          ((Id
b,Term
_):[LetBinding]
_) -> do assn <- HasCallStack =>
Blocking -> Identifier -> Expr -> NetlistMonad Declaration
Blocking -> Identifier -> Expr -> NetlistMonad Declaration
procAssign Blocking
Blocking (HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId Id
b) Expr
exprInit
                          pure [assn]
          [LetBinding]
_ -> [Char] -> NetlistMonad [Declaration]
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: insufficient sBinders"

      -- Create the declarations that corresponding to the input
      let iDst = case [LetBinding]
iBinders of
                   []      -> [Char] -> NetlistId
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: insufficient iBinders"
                   [(Id
b,Term
_)] -> Id -> NetlistId
CoreId Id
b
                   [LetBinding]
_       -> [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,inpDeclsMisc) <- mkExpr False Concurrent iDst mealyIn

      argAssign <- case iBinders of
        ((Id
i,Term
_):[LetBinding]
_) -> do assn <- HasCallStack => Identifier -> Expr -> NetlistMonad Declaration
Identifier -> Expr -> NetlistMonad Declaration
contAssign (HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId Id
i) Expr
exprArg
                        pure [assn]
        [LetBinding]
_ -> [Char] -> NetlistMonad [Declaration]
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: insufficient iBinders"

      -- Split netdecl declarations and other declarations
      let (netDeclsSeqMisc,seqDeclsOther) = partition isNet (seqDecls ++ resDecls)
          (netDeclsInit,initDeclsOther)   = partition isNet initDecls
      -- All assignments happens within a sequential block, so the nets need to
      -- be of type 'reg' in Verilog nomenclature
      let netDeclsSeq1 = [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.
      kdTy <- unsafeCoreTypeToHWTypeM $(curLoc) (inferCoreTypeOf tcm kd)
      let edge = case HWType -> HWType
stripVoid (FilteredHWType -> HWType
stripFiltered FilteredHWType
kdTy) of
                   KnownDomain Text
_ Integer
_ ActiveEdge
Rising ResetKind
_ InitBehavior
_ ResetPolarity
_  -> ActiveEdge
Falling
                   KnownDomain Text
_ Integer
_ ActiveEdge
Falling ResetKind
_ InitBehavior
_ ResetPolarity
_ -> ActiveEdge
Rising
                   HWType
_ -> [Char] -> ActiveEdge
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error"
      (clkExpr,clkDecls) <-
        mkExpr False Concurrent (NetlistId (Id.unsafeMake "__MEALY_CLK__") (inferCoreTypeOf tcm clk)) clk

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

      -- Collate everything
      return (clkDecls ++ netDeclsSeq1 ++ netDeclsInp1 ++ argAssign ++
                [ Seq [Initial (map SeqDecl (initDeclsOther ++ initAssign))]
                , Seq [AlwaysClocked edge clkExpr (map SeqDecl seqDeclsOther)]
                ] ++ resAssn)
    ([Bool], [(Identifier, HWType)], [Declaration],
 [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
_ -> [Char] -> NetlistMonad [Declaration]
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error"
 where
  isNet :: Declaration -> Bool
isNet NetDecl' {} = Bool
True
  isNet Declaration
_ = Bool
False

collectMealy Identifier
_ NetlistId
_ TyConMap
_ [Term]
_ = [Char] -> NetlistMonad [Declaration]
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error"

-- | Collect the sequential declarations for 'bindIO'
collectBindIO :: NetlistId -> [Term] -> NetlistMonad (Expr,[Declaration])
#if __GLASGOW_HASKELL__ >= 900
collectBindIO :: NetlistId -> [Term] -> NetlistMonad (Expr, [Declaration])
collectBindIO NetlistId
dst (Term
m:Lam Id
x q :: Term
q@Term
e:[Term]
_) = do
#else
collectBindIO dst (m:Lam x q@(Lam _ e):_) = do
#endif
  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
  (ds0,subst) <- collectAction tcm
  let qS = HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm Doc ()
"collectBindIO1" Subst
subst Term
q
  case splitNormalized tcm qS of
    Right ([Id]
args,[LetBinding]
bs0,Id
res) -> do
      let bs :: [LetBinding]
bs = HasCallStack => [LetBinding] -> [LetBinding]
[LetBinding] -> [LetBinding]
inverseTopSortLetBindings [LetBinding]
bs0
      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
qS)
      normE <- HasCallStack =>
InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([Bool], [(Identifier, HWType)], [Declaration],
      [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([Bool], [(Identifier, HWType)], [Declaration],
      [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
mkUniqueNormalized InScopeSet
is0 Maybe (Maybe TopEntity)
forall a. Maybe a
Nothing ([Id]
args,[LetBinding]
bs,Id
res)
      case normE of
        ([Bool]
_,[(Identifier, HWType)]
_,[],[(Identifier, HWType)]
_,[],[LetBinding]
binders,Just Id
result) -> do
          ds1 <- (LetBinding -> NetlistMonad [Declaration])
-> [LetBinding] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m [b]) -> [a] -> m [b]
concatMapM ((Id -> Term -> NetlistMonad [Declaration])
-> LetBinding -> NetlistMonad [Declaration]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (HasCallStack =>
DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
mkDeclarations' DeclarationType
Sequential)) [LetBinding]
binders
          netDecls <- concatMapM mkNetDecl binders
          return (Identifier (Id.unsafeFromCoreId result) Nothing, netDecls ++ ds0 ++ ds1)
        ([Bool], [(Identifier, HWType)], [Declaration],
 [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
_ -> [Char] -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error"
    Either [Char] ([Id], [LetBinding], Id)
_ -> case HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm Doc ()
"collectBindIO2" Subst
subst Term
e of
      Letrec {} -> [Char] -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error"
      (Term -> (Term, [Either Term Type])
collectArgs -> (Prim PrimInfo
p,[Either Term Type]
args))
        | PrimInfo -> Text
primName PrimInfo
p Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Explicit.SimIO.bindSimIO#" -> do
            (expr,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)
            return (expr, ds0 ++ ds1)
      Term
eS -> do
        (expr,ds1) <- HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Sequential NetlistId
dst Term
eS
        return (expr, ds0 ++ ds1)
 where
  collectAction :: TyConMap -> NetlistMonad ([Declaration], Subst)
collectAction TyConMap
tcm = case TyConMap -> Term -> Either [Char] ([Id], [LetBinding], Id)
splitNormalized TyConMap
tcm Term
m of
    Right ([Id]
args,[LetBinding]
bs0,Id
res) -> do
      let bs :: [LetBinding]
bs = HasCallStack => [LetBinding] -> [LetBinding]
[LetBinding] -> [LetBinding]
inverseTopSortLetBindings [LetBinding]
bs0
      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
m)
      normE <- HasCallStack =>
InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([Bool], [(Identifier, HWType)], [Declaration],
      [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([Bool], [(Identifier, HWType)], [Declaration],
      [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
mkUniqueNormalized InScopeSet
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 normE of
        ([Bool]
_,[(Identifier, HWType)]
_,[],[(Identifier, HWType)]
_,[],binders :: [LetBinding]
binders@(LetBinding
b:[LetBinding]
_),Just Id
result) -> do
          let binders1 :: [LetBinding]
binders1 = Int -> [LetBinding] -> [LetBinding]
forall a. Int -> [a] -> [a]
drop Int
1 [LetBinding]
binders [LetBinding] -> [LetBinding] -> [LetBinding]
forall a. [a] -> [a] -> [a]
++ [(LetBinding -> Id
forall a b. (a, b) -> a
fst LetBinding
b, Id -> Term
C.Var Id
result)]
          ds1 <- (LetBinding -> NetlistMonad [Declaration])
-> [LetBinding] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m [b]) -> [a] -> m [b]
concatMapM ((Id -> Term -> NetlistMonad [Declaration])
-> LetBinding -> NetlistMonad [Declaration]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (HasCallStack =>
DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
mkDeclarations' DeclarationType
Sequential)) [LetBinding]
binders1
          netDecls <- concatMapM mkNetDecl binders
          return (netDecls ++ ds1,extendIdSubst (mkSubst eInScopeSet) x (Var (fst b)))
        ([Bool], [(Identifier, HWType)], [Declaration],
 [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
_ -> [Char] -> NetlistMonad ([Declaration], Subst)
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error"
    Either [Char] ([Id], [LetBinding], Id)
_ -> do
      ([x'],s) <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique (InScopeSet -> Subst
mkSubst InScopeSet
eInScopeSet) [Id
x]
      netDecls <- concatMapM mkNetDecl [(x',m)]
      ds1 <- mkDeclarations' Sequential x' m
      return (netDecls ++ ds1,s)

  eInScopeSet :: InScopeSet
eInScopeSet = 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
e)

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

-- | Collect the sequential declarations for 'appIO'
collectAppIO :: NetlistId -> [Term] -> [Term] -> NetlistMonad (Expr,[Declaration])
collectAppIO :: NetlistId -> [Term] -> [Term] -> NetlistMonad (Expr, [Declaration])
collectAppIO NetlistId
dst (Term
fun1:Term
arg1:[Term]
_) [Term]
rest = case Term -> (Term, [Either Term Type])
collectArgs Term
fun1 of
  (Prim (PrimInfo Text
"Clash.Explicit.SimIO.fmapSimIO#" Type
_ WorkInfo
_ IsMultiPrim
_ PrimUnfolding
_),([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts -> (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 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)
    mkExpr False Sequential dst (mkApps fun0 argN)
  (Prim (PrimInfo Text
"Clash.Explicit.SimIO.apSimIO#" Type
_ WorkInfo
_ IsMultiPrim
_ PrimUnfolding
_),([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)
  (Term, [Either Term Type])
_ -> [Char] -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => [Char] -> a
error ([Char]
"internal error:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Term] -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr (Term
fun1Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
:Term
arg1Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
:[Term]
rest))


collectAppIO NetlistId
_ [Term]
es [Term]
_ = [Char] -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => [Char] -> a
error ([Char]
"internal error:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Term] -> [Char]
forall p. PrettyPrec p => p -> [Char]
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 TyConMap
tcm Term
arg =
  let argTy :: Type
argTy = TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
arg
  in  case Type -> TypeView
tyView Type
argTy of
        TyConApp TyConName
_ [Type
tcArg] ->
          Term -> [Either Term Type] -> Term
mkApps (PrimInfo -> Term
Prim (Text
-> Type -> WorkInfo -> IsMultiPrim -> PrimUnfolding -> PrimInfo
PrimInfo
                          Text
"Clash.Explicit.SimIO.unSimIO#"
                          (Type -> Type -> Type
mkFunTy Type
argTy Type
tcArg)
                          WorkInfo
WorkNever
                          IsMultiPrim
SingleResult
                          PrimUnfolding
NoUnfolding))
                 [Term -> Either Term Type
forall a b. a -> Either a b
Left Term
arg]
        TypeView
_ -> [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char]
"internal error:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
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
  => TextS.Text
  -- ^ Name of the primitive of which the function in question is an argument.
  -- Used for error reporting.
  -> DeclarationType
  -- ^ Are we concurrent or sequential?
  -> Id
  -- ^ Identifier binding the encompassing primitive/blackbox application. Used
  -- as a name hint if 'mkFunInput' needs intermediate signals.
  -> Term
  -- ^ The function argument term
  -> NetlistMonad
      ((Either BlackBox (Identifier,[Declaration])
       ,Usage
       ,[BlackBoxTemplate]
       ,[BlackBoxTemplate]
       ,[((TextS.Text,TextS.Text),BlackBox)]
       ,BlackBoxContext)
      ,[Declaration])
mkFunInput :: HasCallStack =>
Text
-> DeclarationType
-> Id
-> Term
-> NetlistMonad
     ((Either BlackBox (Identifier, [Declaration]), Usage,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext),
      [Declaration])
mkFunInput Text
parentName DeclarationType
declType Id
resId Term
e =
 let (Term
appE,[Either Term Type]
args,[TickInfo]
ticks) = Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks Term
e
 in  [TickInfo]
-> ([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 a.
[TickInfo] -> ([Declaration] -> NetlistMonad a) -> NetlistMonad a
withTicks [TickInfo]
ticks (([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]))
-> ([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 a b. (a -> b) -> a -> b
$ \[Declaration]
tickDecls -> 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
  -- TODO: Rewrite this function to use blackbox functions. Right now it
  -- TODO: generates strings that are later parsed/interpreted again. Silly!
  templ <- case appE of
            Prim PrimInfo
p -> do
              bb  <- HasCallStack => Text -> NetlistMonad CompiledPrimitive
Text -> NetlistMonad CompiledPrimitive
extractPrimWarnOrFail (PrimInfo -> Text
primName PrimInfo
p)
              case bb of
                P.BlackBox {Bool
[BlackBoxTemplate]
[(Int, Int)]
[((Text, Text), BlackBox)]
[BlackBox]
()
Text
WorkInfo
Usage
BlackBox
TemplateKind
RenderVoid
name :: forall a b c d. Primitive a b c d -> Text
multiResult :: forall a b c d. Primitive a b c d -> Bool
template :: forall a b c d. Primitive a b c d -> b
libraries :: forall a b c d. Primitive a b c d -> [a]
imports :: forall a b c d. Primitive a b c d -> [a]
includes :: forall a b c d. Primitive a b c d -> [((Text, Text), b)]
kind :: forall a b c d. Primitive a b c d -> TemplateKind
outputUsage :: forall a b c d. Primitive a b c d -> Usage
renderVoid :: forall a b c d. Primitive a b c d -> RenderVoid
name :: Text
workInfo :: WorkInfo
renderVoid :: RenderVoid
multiResult :: Bool
kind :: TemplateKind
warning :: ()
outputUsage :: Usage
libraries :: [BlackBoxTemplate]
imports :: [BlackBoxTemplate]
functionPlurality :: [(Int, Int)]
includes :: [((Text, Text), BlackBox)]
resultNames :: [BlackBox]
resultInits :: [BlackBox]
template :: BlackBox
resultInits :: forall a b c d. Primitive a b c d -> [b]
resultNames :: forall a b c d. Primitive a b c d -> [b]
functionPlurality :: forall a b c d. Primitive a b c d -> [(Int, Int)]
warning :: forall a b c d. Primitive a b c d -> c
workInfo :: forall a b c d. Primitive a b c d -> WorkInfo
..} ->
                  Either
  (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Identifier, [Declaration]), Usage)
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a. a -> NetlistMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
 [((Text, Text), BlackBox)], Text, BlackBox)
-> Either
     (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Identifier, [Declaration]), Usage)
forall a b. a -> Either a b
Left (TemplateKind
kind,Usage
outputUsage,[BlackBoxTemplate]
libraries,[BlackBoxTemplate]
imports,[((Text, Text), BlackBox)]
includes,PrimInfo -> Text
primName PrimInfo
p,BlackBox
template))
                P.Primitive Text
pn WorkInfo
_ Text
pt ->
                  [Char]
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> NetlistMonad
      (Either
         (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Identifier, [Declaration]), Usage)))
-> [Char]
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a b. (a -> b) -> a -> b
$ $(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Unexpected blackbox type: "
                                    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Primitive " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
pn
                                    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
pt
                P.BlackBoxHaskell{name :: forall a b c d. Primitive a b c d -> Text
name=Text
pName, multiResult :: forall a b c d. Primitive a b c d -> Bool
multiResult=Bool
True} ->
                  -- TODO: dev pointers
                  [Char]
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a. HasCallStack => [Char] -> a
error [I.i|
                    Encountered multiresult primitive as a direct argument to
                    another primitive. This should not happen.

                      Encountered: #{pName}

                    Please report this as an issue.
                  |]
                P.BlackBoxHaskell{name :: forall a b c d. Primitive a b c d -> Text
name=Text
pName, functionName :: forall a b c d. Primitive a b c d -> BlackBoxFunctionName
functionName=BlackBoxFunctionName
fName, function :: forall a b c d. Primitive a b c d -> d
function=(Int
_, BlackBoxFunction
func)} -> do
                  -- Determine result type of this blackbox. If it's not a
                  -- function, simply use its term type.
                  let ([Type]
_, Type
resTy) = TyConMap -> Type -> ([Type], Type)
splitFunTys TyConMap
tcm (TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
e)
                  bbhRes <- BlackBoxFunction
func Bool
True Text
pName [Either Term Type]
args [Type
resTy]
                  case bbhRes of
                    Left [Char]
err ->
                      [Char]
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> NetlistMonad
      (Either
         (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Identifier, [Declaration]), Usage)))
-> [Char]
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a b. (a -> b) -> a -> b
$ $(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ BlackBoxFunctionName -> [Char]
forall a. Show a => a -> [Char]
show BlackBoxFunctionName
fName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" yielded an error: "
                                        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err
                    Right (BlackBoxMeta{[BlackBoxTemplate]
[(Int, Int)]
[((Text, Text), BlackBox)]
[BlackBox]
Usage
TemplateKind
RenderVoid
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
bbOutputUsage :: Usage
bbKind :: TemplateKind
bbLibrary :: [BlackBoxTemplate]
bbImports :: [BlackBoxTemplate]
bbFunctionPlurality :: [(Int, Int)]
bbIncludes :: [((Text, Text), BlackBox)]
bbRenderVoid :: RenderVoid
bbResultNames :: [BlackBox]
bbResultInits :: [BlackBox]
..}, BlackBox
template) ->
                      Either
  (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Identifier, [Declaration]), Usage)
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a. a -> NetlistMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either
   (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
    [((Text, Text), BlackBox)], Text, BlackBox)
   ((Identifier, [Declaration]), Usage)
 -> NetlistMonad
      (Either
         (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Identifier, [Declaration]), Usage)))
-> Either
     (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Identifier, [Declaration]), Usage)
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a b. (a -> b) -> a -> b
$
                        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
 [((Text, Text), BlackBox)], Text, BlackBox)
-> Either
     (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Identifier, [Declaration]), Usage)
forall a b. a -> Either a b
Left ( TemplateKind
bbKind, Usage
bbOutputUsage, [BlackBoxTemplate]
bbLibrary, [BlackBoxTemplate]
bbImports
                             , [((Text, Text), BlackBox)]
bbIncludes, Text
pName, BlackBox
template)
            Data DataCon
dc -> do
              let eTy :: Type
eTy = TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
e
                  ([Type]
_,Type
resTy) = TyConMap -> Type -> ([Type], Type)
splitFunTys TyConMap
tcm Type
eTy

              resHTyM0 <- Type -> NetlistMonad (Maybe FilteredHWType)
coreTypeToHWTypeM Type
resTy
              let resHTyM1 = (\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 resHTyM1 of
                -- Special case where coreTypeToHWTypeM determined a type to
                -- be completely transparent.
                Just (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]
areVoids)
                  let arg :: Identifier
arg = HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake ([Text] -> Text
TextS.concat [Text
"~ARG[", Int -> Text
forall a. Show a => a -> Text
showt Int
nonVoidArgI, Text
"]"])
                  let assign :: Declaration
assign = Identifier -> Usage -> Expr -> Declaration
Assignment (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"~RESULT") Usage
assignTy (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
arg Maybe Modifier
forall a. Maybe a
Nothing)
                  Either
  (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Identifier, [Declaration]), Usage)
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Identifier, [Declaration]), Usage)
-> Either
     (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Identifier, [Declaration]), Usage)
forall a b. b -> Either a b
Right ((HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"", [Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
assign]), Usage
assignTy))

                -- 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 Text
_ [(Text, [HWType])]
_), [[Bool]]
areVoids0) -> do
                  let
                      dcI :: Int
dcI       = DataCon -> Int
dcTag DataCon
dc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                      areVoids1 :: [Bool]
areVoids1 = [Char] -> [[Bool]] -> Int -> [Bool]
forall a. HasCallStack => [Char] -> [a] -> Int -> a
indexNote ($(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"No areVoids with index: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
dcI) [[Bool]]
areVoids0 Int
dcI
                      mkArg :: a -> Identifier
mkArg a
i   = HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake (Text
"~ARG[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
showt a
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]")
                      dcInps :: [Expr]
dcInps    = [Identifier -> Maybe Modifier -> Expr
Identifier (Int -> Identifier
forall {a}. Show a => a -> Identifier
mkArg Int
x) 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     = Identifier -> Usage -> Expr -> Declaration
Assignment (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"~RESULT") Usage
assignTy Expr
dcApp
                  Either
  (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Identifier, [Declaration]), Usage)
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Identifier, [Declaration]), Usage)
-> Either
     (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Identifier, [Declaration]), Usage)
forall a b. b -> Either a b
Right ((HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"",[Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
dcAss]), Usage
assignTy))

                -- CustomSP the same as SP, but with a user-defined bit
                -- level representation
                Just (resHTy :: HWType
resHTy@(CustomSP {}), [[Bool]]
areVoids0) -> do
                  let
                      dcI :: Int
dcI       = DataCon -> Int
dcTag DataCon
dc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                      areVoids1 :: [Bool]
areVoids1 = [Char] -> [[Bool]] -> Int -> [Bool]
forall a. HasCallStack => [Char] -> [a] -> Int -> a
indexNote ($(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"No areVoids with index: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
dcI) [[Bool]]
areVoids0 Int
dcI
                      mkArg :: a -> Identifier
mkArg a
i   = HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake (Text
"~ARG[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
showt a
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]")
                      dcInps :: [Expr]
dcInps    = [Identifier -> Maybe Modifier -> Expr
Identifier (Int -> Identifier
forall {a}. Show a => a -> Identifier
mkArg Int
x) 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     = Identifier -> Usage -> Expr -> Declaration
Assignment (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"~RESULT") Usage
assignTy Expr
dcApp
                  Either
  (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Identifier, [Declaration]), Usage)
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Identifier, [Declaration]), Usage)
-> Either
     (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Identifier, [Declaration]), Usage)
forall a b. b -> Either a b
Right ((HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"",[Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
dcAss]), Usage
assignTy))

                -- Like SP, we have to retrieve the index BEFORE filtering voids
                Just (resHTy :: HWType
resHTy@(Product Text
_ Maybe [Text]
_ [HWType]
_), [Bool]
areVoids1:[[Bool]]
_) -> do
                  let mkArg :: a -> Identifier
mkArg a
i    = HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake (Text
"~ARG[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
showt a
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]")
                      dcInps :: [Expr]
dcInps    = [ Identifier -> Maybe Modifier -> Expr
Identifier (Int -> Identifier
forall {a}. Show a => a -> Identifier
mkArg Int
x) 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
0)) [Expr]
dcInps
                      dcAss :: Declaration
dcAss     = Identifier -> Usage -> Expr -> Declaration
Assignment (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"~RESULT") Usage
assignTy Expr
dcApp
                  Either
  (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Identifier, [Declaration]), Usage)
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Identifier, [Declaration]), Usage)
-> Either
     (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Identifier, [Declaration]), Usage)
forall a b. b -> Either a b
Right ((HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"",[Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
dcAss]), Usage
assignTy))

                -- 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 Int
_ HWType
_), [[Bool]]
_areVoids) -> do
                  let mkArg :: a -> Identifier
mkArg a
i = HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake (Text
"~ARG[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
showt a
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]")
                      dcInps :: [Expr]
dcInps = [ Identifier -> Maybe Modifier -> Expr
Identifier (Int -> Identifier
forall {a}. Show a => a -> Identifier
mkArg Int
x) Maybe Modifier
forall a. Maybe a
Nothing | Int
x <- [(Int
1::Int)..Int
2] ]
                      dcApp :: Expr
dcApp  = HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
resHTy ((HWType, Int) -> Modifier
DC (HWType
resHTy,Int
1)) [Expr]
dcInps
                      dcAss :: Declaration
dcAss  = Identifier -> Usage -> Expr -> Declaration
Assignment (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"~RESULT") Usage
assignTy Expr
dcApp
                  Either
  (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Identifier, [Declaration]), Usage)
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Identifier, [Declaration]), Usage)
-> Either
     (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Identifier, [Declaration]), Usage)
forall a b. b -> Either a b
Right ((HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"",[Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
dcAss]), Usage
assignTy))

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

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

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

                Maybe (HWType, [[Bool]])
_ -> [Char]
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> NetlistMonad
      (Either
         (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Identifier, [Declaration]), Usage)))
-> [Char]
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a b. (a -> b) -> a -> b
$ $(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Cannot make function input for: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
e
            C.Var Id
fun -> do
              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 lookupVarEnv fun topAnns of
                Just TopEntityT
_ ->
                  [Char]
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> NetlistMonad
      (Either
         (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Identifier, [Declaration]), Usage)))
-> [Char]
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a b. (a -> b) -> a -> b
$ $(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Cannot make function input for partially applied Synthesize-annotated: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
e
                Maybe TopEntityT
_ -> do
                  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 lookupVarEnv fun normalized of
                    Just Binding Term
_ -> do
                      (meta,N.Component compName compInps compOutps _) <-
                        NetlistMonad (ComponentMeta, Component)
-> NetlistMonad (ComponentMeta, Component)
forall a. NetlistMonad a -> NetlistMonad a
preserveVarEnv (NetlistMonad (ComponentMeta, Component)
 -> NetlistMonad (ComponentMeta, Component))
-> NetlistMonad (ComponentMeta, Component)
-> NetlistMonad (ComponentMeta, Component)
forall a b. (a -> b) -> a -> b
$ HasCallStack => Id -> NetlistMonad (ComponentMeta, Component)
Id -> NetlistMonad (ComponentMeta, Component)
genComponent Id
fun

                      let
                        ComponentMeta{cmWereVoids} = meta
                        inpAssign (Identifier
i, c
t) d
e' = (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
i Maybe Modifier
forall a. Maybe a
Nothing, PortDirection
In, c
t, d
e')
                        inpVar a
i = HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake (Text
"~VAR[arg" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
showt a
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"][" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
showt a
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]")
                        inpVars = [Identifier -> Maybe Modifier -> Expr
Identifier (Int -> Identifier
forall {a}. Show a => a -> Identifier
inpVar Int
i)  Maybe Modifier
forall a. Maybe a
Nothing | Int
i <- [Bool] -> [Int]
originalIndices [Bool]
cmWereVoids]
                        inpAssigns = ((Identifier, HWType)
 -> Expr -> (Expr, PortDirection, HWType, Expr))
-> [(Identifier, HWType)]
-> [Expr]
-> [(Expr, PortDirection, HWType, Expr)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Identifier, HWType) -> Expr -> (Expr, PortDirection, HWType, Expr)
forall {c} {d}. (Identifier, c) -> d -> (Expr, PortDirection, c, d)
inpAssign [(Identifier, HWType)]
compInps [Expr]
inpVars
                        outpAssigns = case [(Usage, (Identifier, HWType), Maybe Expr)]
compOutps of
                          [] -> [] -- See issue #2549
                          [(Usage
_,(Identifier, HWType)
compOutp,Maybe Expr
_)] ->
                            [ ( Identifier -> Maybe Modifier -> Expr
Identifier ((Identifier, HWType) -> Identifier
forall a b. (a, b) -> a
fst (Identifier, HWType)
compOutp) Maybe Modifier
forall a. Maybe a
Nothing
                              , PortDirection
Out
                              , (Identifier, HWType) -> HWType
forall a b. (a, b) -> b
snd (Identifier, HWType)
compOutp
                              , Identifier -> Maybe Modifier -> Expr
Identifier (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"~RESULT") Maybe Modifier
forall a. Maybe a
Nothing )
                            ]
                          [(Usage, (Identifier, HWType), Maybe Expr)]
outps ->
                            [Char] -> [(Expr, PortDirection, HWType, Expr)]
forall a. HasCallStack => [Char] -> a
error [I.i|
                              Cannot handle multi-result function as an argument to
                              a primitive.

                              Primitive: #{parentName}

                              Argument: #{showPpr fun} :: #{showPpr (varType fun)}

                              Outputs: #{show (map (\(_,x,_) -> x) outps)}

                              Please report this as an issue.
                            |]
                      instLabel <- Id.next compName
                      let
                        portMap = [(Expr, PortDirection, HWType, Expr)] -> PortMap
NamedPortMap ([(Expr, PortDirection, HWType, Expr)]
outpAssigns [(Expr, PortDirection, HWType, Expr)]
-> [(Expr, PortDirection, HWType, Expr)]
-> [(Expr, PortDirection, HWType, Expr)]
forall a. [a] -> [a] -> [a]
++ [(Expr, PortDirection, HWType, Expr)]
inpAssigns)
                        instDecl = EntityOrComponent
-> Maybe Text
-> [Attr Text]
-> Identifier
-> Identifier
-> [(Expr, HWType, Expr)]
-> PortMap
-> Declaration
InstDecl EntityOrComponent
Entity Maybe Text
forall a. Maybe a
Nothing [] Identifier
compName Identifier
instLabel [] PortMap
portMap
                      return (Right ((Id.unsafeMake "",tickDecls ++ [instDecl]), Cont))
                    Maybe (Binding Term)
Nothing -> [Char]
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> NetlistMonad
      (Either
         (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Identifier, [Declaration]), Usage)))
-> [Char]
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a b. (a -> b) -> a -> b
$ $(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Cannot make function input for: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
e
            C.Lam {} -> do
              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
appE)
              ((TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
  [((Text, Text), BlackBox)], Text, BlackBox)
 -> Either
      (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
       [((Text, Text), BlackBox)], Text, BlackBox)
      ((Identifier, [Declaration]), Usage))
-> (((Identifier, [Declaration]), Usage)
    -> Either
         (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Identifier, [Declaration]), Usage))
-> Either
     (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Identifier, [Declaration]), Usage)
-> Either
     (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Identifier, [Declaration]), Usage)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
 [((Text, Text), BlackBox)], Text, BlackBox)
-> Either
     (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Identifier, [Declaration]), Usage)
forall a b. a -> Either a b
Left (((Identifier, [Declaration]), Usage)
-> Either
     (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Identifier, [Declaration]), Usage)
forall a b. b -> Either a b
Right (((Identifier, [Declaration]), Usage)
 -> Either
      (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
       [((Text, Text), BlackBox)], Text, BlackBox)
      ((Identifier, [Declaration]), Usage))
-> (((Identifier, [Declaration]), Usage)
    -> ((Identifier, [Declaration]), Usage))
-> ((Identifier, [Declaration]), Usage)
-> Either
     (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Identifier, [Declaration]), Usage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Identifier, [Declaration]) -> (Identifier, [Declaration]))
-> ((Identifier, [Declaration]), Usage)
-> ((Identifier, [Declaration]), Usage)
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 (([Declaration] -> [Declaration])
-> (Identifier, [Declaration]) -> (Identifier, [Declaration])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: Type -> Type -> Type) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ([Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++))) (Either
   (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
    [((Text, Text), BlackBox)], Text, BlackBox)
   ((Identifier, [Declaration]), Usage)
 -> Either
      (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
       [((Text, Text), BlackBox)], Text, BlackBox)
      ((Identifier, [Declaration]), Usage))
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> InScopeSet
-> Int
-> Term
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall {a}.
InScopeSet
-> Int
-> Term
-> NetlistMonad (Either a ((Identifier, [Declaration]), Usage))
go InScopeSet
is0 Int
0 Term
appE
            Term
_ -> [Char]
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> NetlistMonad
      (Either
         (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Identifier, [Declaration]), Usage)))
-> [Char]
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a b. (a -> b) -> a -> b
$ $(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Cannot make function input for: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
e
  let pNm = case Term
appE of
              Prim PrimInfo
p -> PrimInfo -> Text
primName PrimInfo
p
              Term
_ -> Text
"__INTERNAL__"
  (bbCtx,dcls) <- mkBlackBoxContext pNm declType [resId] args
  case templ of
    Left (TemplateKind
TDecl,Usage
outputUsage,[BlackBoxTemplate]
libs,[BlackBoxTemplate]
imps,[((Text, Text), BlackBox)]
inc,Text
_,BlackBox
templ') -> do
      (l',templDecl)
        <- (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 ((BlackBox, [Declaration])
 -> NetlistMonad (BlackBox, [Declaration]))
-> (BlackBox, [Declaration])
-> NetlistMonad (BlackBox, [Declaration])
forall a b. (a -> b) -> a -> b
$ ([Char] -> Int -> TemplateFunction -> BlackBox
BBFunction [Char]
bbName Int
bbHash TemplateFunction
bbFunc, []))
            BlackBox
templ'
      return ((Left l',outputUsage,libs,imps,inc,bbCtx),dcls ++ templDecl)
    Left (TemplateKind
TExpr,Usage
_,[BlackBoxTemplate]
libs,[BlackBoxTemplate]
imps,[((Text, Text), BlackBox)]
inc,Text
nm,BlackBox
templ') -> do
      (BlackBoxTemplate
 -> NetlistMonad
      ((Either BlackBox (Identifier, [Declaration]), Usage,
        [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
        BlackBoxContext),
       [Declaration]))
-> ([Char]
    -> Int
    -> TemplateFunction
    -> NetlistMonad
         ((Either BlackBox (Identifier, [Declaration]), Usage,
           [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
           BlackBoxContext),
          [Declaration]))
-> BlackBox
-> NetlistMonad
     ((Either BlackBox (Identifier, [Declaration]), Usage,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext),
      [Declaration])
forall r.
(BlackBoxTemplate -> r)
-> ([Char] -> Int -> TemplateFunction -> r) -> BlackBox -> r
onBlackBox
        (\BlackBoxTemplate
t -> do t' <- Ap NetlistMonad Text -> NetlistMonad Text
forall {k} (f :: k -> Type) (a :: k). Ap f a -> f a
getAp (BlackBoxTemplate -> Ap NetlistMonad Text
forall (m :: Type -> Type).
Monad m =>
BlackBoxTemplate -> Ap m Text
prettyBlackBox BlackBoxTemplate
t)
                  let t'' = HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake (Text -> Text
Text.toStrict Text
t')
                      assn = Identifier -> Usage -> Expr -> Declaration
Assignment (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"~RESULT") Usage
assignTy (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
t'' Maybe Modifier
forall a. Maybe a
Nothing)
                  return ((Right (Id.unsafeMake "",[assn]),assignTy,libs,imps,inc,bbCtx),dcls))
        (\[Char]
bbName Int
bbHash (TemplateFunction [Int]
k BlackBoxContext -> Bool
g forall s. Backend s => BlackBoxContext -> State s (Doc ())
_) -> do
          let f' :: BlackBoxContext -> State state (Doc ())
f' BlackBoxContext
bbCtx' = do
                let assn :: Declaration
assn = Identifier -> Usage -> Expr -> Declaration
Assignment (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"~RESULT") Usage
assignTy
                            (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)
                p <- Ap (State state) (Doc ()) -> State state (Doc ())
forall {k} (f :: k -> Type) (a :: k). Ap f a -> f a
getAp (Identifier -> [Declaration] -> Ap (State state) (Doc ())
forall state.
Backend state =>
Identifier -> [Declaration] -> Ap (State state) (Doc ())
Backend.blockDecl (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"") [Declaration
assn])
                return p
          ((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 a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((BlackBox -> Either BlackBox (Identifier, [Declaration])
forall a b. a -> Either a b
Left ([Char] -> Int -> TemplateFunction -> BlackBox
BBFunction [Char]
bbName Int
bbHash ([Int]
-> (BlackBoxContext -> Bool)
-> (forall s. Backend s => BlackBoxContext -> State s (Doc ()))
-> TemplateFunction
TemplateFunction [Int]
k BlackBoxContext -> Bool
g BlackBoxContext -> State s (Doc ())
forall s. Backend s => BlackBoxContext -> State s (Doc ())
f'))
                  ,Usage
assignTy
                  ,[]
                  ,[]
                  ,[]
                  ,BlackBoxContext
bbCtx
                  )
                 ,[Declaration]
dcls
                 )
        )
        BlackBox
templ'
    Right ((Identifier, [Declaration])
decl,Usage
u) ->
      ((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 a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Identifier, [Declaration])
-> Either BlackBox (Identifier, [Declaration])
forall a b. b -> Either a b
Right (Identifier, [Declaration])
decl,Usage
u,[],[],[],BlackBoxContext
bbCtx),[Declaration]
dcls)
  where
    assignTy :: Usage
assignTy = DeclarationType -> Usage
declTypeUsage DeclarationType
declType

    goExpr :: Term
-> NetlistMonad (Either a ((Identifier, [Declaration]), Usage))
goExpr app :: Term
app@(Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks -> (C.Var Id
fun,args :: [Either Term Type]
args@(Either Term Type
_:[Either Term Type]
_),[TickInfo]
ticks)) = 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
      resTy <- unsafeCoreTypeToHWTypeM' $(curLoc) (inferCoreTypeOf tcm app)
      let (tmArgs,tyArgs) = partitionEithers args
      if null tyArgs
        then
          withTicks ticks $ \[Declaration]
tickDecls -> do
            resNm <- Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.make Text
"result"
            appDecls <- mkFunApp declType resNm fun tmArgs tickDecls
            let assn = [ Identifier -> Usage -> Expr -> Declaration
Assignment (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"~RESULT") Usage
assignTy (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
resNm Maybe Modifier
forall a. Maybe a
Nothing)
                       , Maybe Text -> Identifier -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Identifier
resNm HWType
resTy ]
            nm <- Id.makeBasic "block"
            return (Right ((nm,assn++appDecls), assignTy))
        else do
          (_,sp) <- Lens.use curCompNm
          throw (ClashException sp ($(curLoc) ++ "Not in normal form: Var-application with Type arguments:\n\n" ++ showPpr app) Nothing)
    goExpr 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 eType = TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
e'
      (appExpr,appDecls) <- mkExpr False declType (NetlistId (Id.unsafeMake "c$bb_res") eType) e'
      let assn = Identifier -> Usage -> Expr -> Declaration
Assignment (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"~RESULT") Usage
assignTy Expr
appExpr
      nm <- if null appDecls
               then return (Id.unsafeMake "")
               else Id.makeBasic "block"
      return (Right ((nm,appDecls ++ [assn]), assignTy))

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

    go InScopeSet
_ Int
_ (C.Var Id
v) = do
      let assn :: Declaration
assn = Identifier -> Usage -> Expr -> Declaration
Assignment (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"~RESULT") Usage
assignTy (Identifier -> Maybe Modifier -> Expr
Identifier (HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId Id
v) Maybe Modifier
forall a. Maybe a
Nothing)
      Either a ((Identifier, [Declaration]), Usage)
-> NetlistMonad (Either a ((Identifier, [Declaration]), Usage))
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Identifier, [Declaration]), Usage)
-> Either a ((Identifier, [Declaration]), Usage)
forall a b. b -> Either a b
Right ((HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"",[Declaration
assn]), Usage
assignTy))

    go InScopeSet
_ Int
_ (Case Term
scrut Type
ty [Alt
alt]) = 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 sTy = TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
scrut
      (projection,decls) <- mkProjection declType False (NetlistId (Id.unsafeMake "c$bb_res") sTy) scrut ty alt
      let assn = Identifier -> Usage -> Expr -> Declaration
Assignment (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"~RESULT") Usage
assignTy Expr
projection
      nm <- if null decls
               then return (Id.unsafeMake "")
               else Id.makeBasic "projection"
      return (Right ((nm,decls ++ [assn]), assignTy))

    go InScopeSet
_ Int
_ (Case Term
scrut Type
ty (Alt
alt:alts :: [Alt]
alts@(Alt
_:[Alt]
_))) = do
      resNm <- Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.make Text
"result"
      resTy <- unsafeCoreTypeToHWTypeM' $(curLoc) ty
      -- It's safe to use 'mkUnsafeSystemName' here: only the name, not the
      -- unique, will be used
      let resId'  = Identifier -> Type -> NetlistId
NetlistId Identifier
resNm Type
ty
      selectionDecls <- mkSelection declType resId' scrut ty (alt :| alts) []
      let assn = [ Maybe Text -> Identifier -> HWType -> Maybe Expr -> Declaration
NetDecl' Maybe Text
forall a. Maybe a
Nothing Identifier
resNm HWType
resTy Maybe Expr
forall a. Maybe a
Nothing
                 , Identifier -> Usage -> Expr -> Declaration
Assignment (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"~RESULT") Usage
assignTy (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
resNm Maybe Modifier
forall a. Maybe a
Nothing) ]
      nm <- Id.makeBasic "selection"
      return (Right ((nm,assn++selectionDecls), assignTy))

    go InScopeSet
is0 Int
_ e' :: Term
e'@(Let{}) = 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 normE = TyConMap -> Term -> Either [Char] ([Id], [LetBinding], Id)
splitNormalized TyConMap
tcm Term
e'
      (_,[],[],_,[],binders,resultM) <- case normE of
        Right ([Id], [LetBinding], Id)
norm -> HasCallStack =>
InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([Bool], [(Identifier, HWType)], [Declaration],
      [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([Bool], [(Identifier, HWType)], [Declaration],
      [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
mkUniqueNormalized InScopeSet
is0 Maybe (Maybe TopEntity)
forall a. Maybe a
Nothing ([Id], [LetBinding], Id)
norm
        Left [Char]
err -> [Char]
-> NetlistMonad
     ([Bool], [(Identifier, HWType)], [Declaration],
      [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
forall a. HasCallStack => [Char] -> a
error [Char]
err
      case resultM of
        Just Id
result -> do
          -- TODO: figure out what to do with multires blackboxes here
          netDecls <- (LetBinding -> NetlistMonad [Declaration])
-> [LetBinding] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m [b]) -> [a] -> m [b]
concatMapM LetBinding -> NetlistMonad [Declaration]
mkNetDecl ([LetBinding] -> NetlistMonad [Declaration])
-> [LetBinding] -> NetlistMonad [Declaration]
forall a b. (a -> b) -> a -> b
$ [LetBinding]
binders
          decls    <- concatMapM (uncurry mkDeclarations) binders
          nm <- Id.makeBasic "fun"
          let resultId = HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId Id
result
          -- TODO: Due to reasons lost in the mists of time, #1265 creates an
          -- assignement here, whereas it previously wouldn't. With the PR in
          -- tests break when reverting to the old behavior. In some cases this
          -- creates "useless" assignments. We should investigate whether we can
          -- get the old behavior back.
          let resDecl = Identifier -> Usage -> Expr -> Declaration
Assignment (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"~RESULT") Usage
assignTy (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
resultId Maybe Modifier
forall a. Maybe a
Nothing)
          return (Right ((nm,resDecl:netDecls ++ decls), assignTy))
        Maybe Id
Nothing -> Either a ((Identifier, [Declaration]), Usage)
-> NetlistMonad (Either a ((Identifier, [Declaration]), Usage))
forall a. a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Identifier, [Declaration]), Usage)
-> Either a ((Identifier, [Declaration]), Usage)
forall a b. b -> Either a b
Right ((HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"",[]), Usage
Cont))

    go InScopeSet
is0 Int
n (Tick TickInfo
_ Term
e') = InScopeSet
-> Int
-> Term
-> NetlistMonad (Either a ((Identifier, [Declaration]), Usage))
go InScopeSet
is0 Int
n Term
e'

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

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

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