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

  Handle -> [SGR] -> IO ()
hSetSGR Handle
stderr [ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity]

  case ClashOpts -> Bool
opt_werror ClashOpts
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. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
noSrcSpan String
msg Maybe String
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 -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"[WARNING] " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
      Handle -> [SGR] -> IO ()
hSetSGR Handle
stderr [SGR
ANSI.Reset]
      Handle -> IO ()
hFlush Handle
stderr

-- | Generate the context for a BlackBox instantiation.
mkBlackBoxContext
  :: HasCallStack
  => TextS.Text
  -- ^ Blackbox function name
  -> [Id]
  -- ^ Identifiers binding the primitive/blackbox application
  -> [Either Term Type]
  -- ^ Arguments of the primitive/blackbox application
  -> NetlistMonad (BlackBoxContext,[Declaration])
mkBlackBoxContext :: Text
-> [Id]
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext Text
bbName [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 (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 (String -> Identifier
forall a. HasCallStack => String -> a
error String
"mkBlackBoxContext: head") ([Identifier] -> Maybe Identifier
forall a. [a] -> Maybe a
listToMaybe [Identifier]
resNms)
    [HWType]
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)
mapM (String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(String
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
    ([(Expr, HWType, Bool)]
imps,[[Declaration]]
impDecls) <- [((Expr, HWType, Bool), [Declaration])]
-> ([(Expr, HWType, Bool)], [[Declaration]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([((Expr, HWType, Bool), [Declaration])]
 -> ([(Expr, HWType, Bool)], [[Declaration]]))
-> NetlistMonad [((Expr, HWType, Bool), [Declaration])]
-> NetlistMonad ([(Expr, HWType, Bool)], [[Declaration]])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Term -> NetlistMonad ((Expr, HWType, Bool), [Declaration]))
-> [Int]
-> [Term]
-> NetlistMonad [((Expr, HWType, Bool), [Declaration])]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Text
-> Identifier
-> Int
-> Term
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
mkArgument Text
bbName Identifier
resNm) [Int
0..] [Term]
termArgs
    (IntMap
  [(Either BlackBox (Identifier, [Declaration]), Usage,
    [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
    BlackBoxContext)]
funs,[[Declaration]]
funDecls) <-
      (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]))
-> 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]])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM
        ([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 ((Id -> Type) -> [Id] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
forall a. HasType a => a -> Type
coreTypeOf [Id]
resIds))
        IntMap
  [(Either BlackBox (Identifier, [Declaration]), Usage,
    [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
    BlackBoxContext)]
forall a. IntMap a
IntMap.empty
        ([Term] -> [Int] -> [(Term, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Term]
termArgs [Int
0..])

    -- Make context result
    let ress :: [Expr]
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

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

    -- Set "context name" to value set by `Clash.Magic.setName`, default to the
    -- name of the closest binder
    [Text]
ctxName1 <- [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe ((Identifier -> Text) -> [Identifier] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Identifier -> Text
Id.toText [Identifier]
resNms) (Maybe [Text] -> [Text])
-> (Maybe Text -> Maybe [Text]) -> Maybe Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> [Text]) -> Maybe Text -> Maybe [Text]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> [Text]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe Text -> [Text])
-> NetlistMonad (Maybe Text) -> NetlistMonad [Text]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Maybe Text) NetlistEnv (Maybe Text)
-> NetlistMonad (Maybe Text)
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting (Maybe Text) NetlistEnv (Maybe Text)
Lens' NetlistEnv (Maybe Text)
setName
    -- Update "context name" with prefixes and suffixes set by
    -- `Clash.Magic.prefixName` and `Clash.Magic.suffixName`
    [Text]
ctxName2 <- (Text -> NetlistMonad Text) -> [Text] -> NetlistMonad [Text]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> NetlistMonad Text
affixName [Text]
ctxName1

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

        (Int -> Identity Int) -> NetlistState -> Identity NetlistState
Lens' NetlistState Int
curBBlvl ((Int -> Identity Int) -> NetlistState -> Identity NetlistState)
-> Int -> NetlistMonad ()
forall s (m :: Type -> Type) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
Lens.+= Int
1
        ([(Either BlackBox (Identifier, [Declaration]), Usage,
  [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
  BlackBoxContext)]
fs,[[Declaration]]
ds) <- case [Id]
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
-> Id
-> Term
-> NetlistMonad
     ((Either BlackBox (Identifier, [Declaration]), Usage,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext),
      [Declaration])
Text
-> Id
-> Term
-> NetlistMonad
     ((Either BlackBox (Identifier, [Declaration]), Usage,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext),
      [Declaration])
mkFunInput Text
bbName Id
resId Term
arg)
          [Id]
_ -> String
-> NetlistMonad
     ([(Either BlackBox (Identifier, [Declaration]), Usage,
        [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
        BlackBoxContext)],
      [[Declaration]])
forall a. HasCallStack => String -> a
error String
"internal error: insufficient resIds"
        (Int -> Identity Int) -> NetlistState -> Identity NetlistState
Lens' NetlistState Int
curBBlvl ((Int -> Identity Int) -> NetlistState -> Identity NetlistState)
-> Int -> NetlistMonad ()
forall s (m :: Type -> Type) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
Lens.-= Int
1

        let im' :: IntMap
  [(Either BlackBox (Identifier, [Declaration]), Usage,
    [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
    BlackBoxContext)]
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
        (IntMap
   [(Either BlackBox (Identifier, [Declaration]), Usage,
     [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
     BlackBoxContext)],
 [Declaration])
-> NetlistMonad
     (IntMap
        [(Either BlackBox (Identifier, [Declaration]), Usage,
          [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
          BlackBoxContext)],
      [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (IntMap
  [(Either BlackBox (Identifier, [Declaration]), Usage,
    [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
    BlackBoxContext)]
im', [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
ds)
      else
        (IntMap
   [(Either BlackBox (Identifier, [Declaration]), Usage,
     [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
     BlackBoxContext)],
 [Declaration])
-> NetlistMonad
     (IntMap
        [(Either BlackBox (Identifier, [Declaration]), Usage,
          [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
          BlackBoxContext)],
      [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (IntMap
  [(Either BlackBox (Identifier, [Declaration]), Usage,
    [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
    BlackBoxContext)]
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 String
verifyBlackBoxContext BlackBoxContext
bbCtx BlackBox
templ of
    Maybe String
Nothing -> do
      (BlackBox
t2,[Declaration]
decls) <-
        (BlackBoxTemplate -> NetlistMonad (BlackBox, [Declaration]))
-> (String
    -> Int
    -> TemplateFunction
    -> NetlistMonad (BlackBox, [Declaration]))
-> BlackBox
-> NetlistMonad (BlackBox, [Declaration])
forall r.
(BlackBoxTemplate -> r)
-> (String -> Int -> TemplateFunction -> r) -> BlackBox -> r
onBlackBox
          (((BlackBoxTemplate, [Declaration]) -> (BlackBox, [Declaration]))
-> NetlistMonad (BlackBoxTemplate, [Declaration])
-> NetlistMonad (BlackBox, [Declaration])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((BlackBoxTemplate -> BlackBox)
-> (BlackBoxTemplate, [Declaration]) -> (BlackBox, [Declaration])
forall (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)
          (\String
bbName Int
bbHash TemplateFunction
bbFunc -> (BlackBox, [Declaration]) -> NetlistMonad (BlackBox, [Declaration])
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (String -> Int -> TemplateFunction -> BlackBox
BBFunction String
bbName Int
bbHash TemplateFunction
bbFunc, []))
          BlackBox
templ
      [Declaration]
-> (Declaration -> NetlistMonad ()) -> NetlistMonad ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Declaration]
decls Declaration -> NetlistMonad ()
goDecl
      (BlackBox, [Declaration]) -> NetlistMonad (BlackBox, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (BlackBox
t2,[Declaration]
decls)
    Just String
err0 -> do
      (Identifier
_,SrcSpan
sp) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
      let err1 :: String
err1 = [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [ String
"Couldn't instantiate blackbox for "
                        , Text -> String
Data.Text.unpack (BlackBoxContext -> Text
bbName BlackBoxContext
bbCtx), String
". Verification "
                        , String
"procedure reported:\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err0 ]
      ClashException -> NetlistMonad (BlackBox, [Declaration])
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err1) Maybe String
forall a. Maybe a
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 backend
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 :: Usage
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 }
      Usage -> Identifier -> NetlistMonad ()
declareUse Usage
use Identifier
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 (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.
  -> Int
  -- ^ Argument n (zero-indexed). Used for error message.
  -> Term
  -> NetlistMonad ( (Expr,HWType,Bool)
                  , [Declaration]
                  )
mkArgument :: Text
-> Identifier
-> Int
-> Term
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
mkArgument Text
bbName Identifier
bndr Int
nArg Term
e = do
    TyConMap
tcm   <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
    let ty :: Type
ty = TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
e
    Int
iw    <- Getting Int NetlistEnv Int -> NetlistMonad Int
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting Int NetlistEnv Int
Getter NetlistEnv Int
intWidth
    Maybe HWType
hwTyM <- (FilteredHWType -> HWType) -> Maybe FilteredHWType -> Maybe HWType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap FilteredHWType -> HWType
stripFiltered (Maybe FilteredHWType -> Maybe HWType)
-> NetlistMonad (Maybe FilteredHWType)
-> NetlistMonad (Maybe HWType)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> NetlistMonad (Maybe FilteredHWType)
N.termHWTypeM Term
e
    let eTyMsg :: String
eTyMsg = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall p. PrettyPrec p => p -> String
showPpr Type
ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
    ((Expr
e',HWType
t,Bool
l),[Declaration]
d) <- case Maybe HWType
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 (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 (m :: Type -> Type) a. Monad m => a -> m a
return ((String -> Expr
forall a. HasCallStack => String -> a
error ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Forced to evaluate untranslatable type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
eTyMsg), Maybe HWType -> HWType
Void Maybe HWType
forall a. Maybe a
Nothing, Bool
False), [])
      Just 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 (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 (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
          (Expr
e',[Declaration]
d) <- Bool
-> Bool
-> DeclarationType
-> NetlistId
-> PrimInfo
-> [Either Term Type]
-> [Declaration]
-> NetlistMonad (Expr, [Declaration])
mkPrimitive Bool
True Bool
False DeclarationType
Concurrent (Identifier -> Type -> NetlistId
NetlistId Identifier
bndr Type
ty) PrimInfo
pinfo [Either Term Type]
args [Declaration]
tickDecls
          case Expr
e' of
            (Identifier Identifier
_ Maybe Modifier
_) -> ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Expr
e',HWType
hwTy,Bool
False), [Declaration]
d)
            Expr
_                -> ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Expr
e',HWType
hwTy,Term -> Bool
isLiteral Term
e), [Declaration]
d)
        (Data DataCon
dc, [Either Term Type]
args,[TickInfo]
_) -> do
          (Expr
exprN,[Declaration]
dcDecls) <- HasCallStack =>
DeclarationType
-> [HWType]
-> NetlistId
-> DataCon
-> [Term]
-> NetlistMonad (Expr, [Declaration])
DeclarationType
-> [HWType]
-> NetlistId
-> DataCon
-> [Term]
-> NetlistMonad (Expr, [Declaration])
mkDcApplication DeclarationType
Concurrent [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)
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Expr
exprN,HWType
hwTy,Term -> Bool
isLiteral Term
e),[Declaration]
dcDecls)
        (Case Term
scrut Type
ty' [Alt
alt],[],[TickInfo]
_) -> do
          (Expr
projection,[Declaration]
decls) <- Bool
-> NetlistId
-> Term
-> Type
-> Alt
-> NetlistMonad (Expr, [Declaration])
mkProjection Bool
False (Identifier -> Type -> NetlistId
NetlistId Identifier
bndr Type
ty) Term
scrut Type
ty' Alt
alt
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Expr
projection,HWType
hwTy,Bool
False),[Declaration]
decls)
        (Let Bind Term
_bnds Term
_term, [], [TickInfo]
_ticks) -> do
          (Expr
exprN, [Declaration]
letDecls) <- HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Concurrent (Identifier -> Type -> NetlistId
NetlistId Identifier
bndr Type
ty) Term
e
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Expr
exprN,HWType
hwTy,Bool
False),[Declaration]
letDecls)
        (Term, [Either Term Type], [TickInfo])
_ -> do
          let errMsg :: String
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 (m :: Type -> Type) a. Monad m => a -> m a
return ((Identifier -> Maybe Modifier -> Expr
Identifier (String -> Identifier
forall a. HasCallStack => String -> a
error ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errMsg)) Maybe Modifier
forall a. Maybe a
Nothing, HWType
hwTy, Bool
False), [])

    ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Expr
e',HWType
t,Bool
l),[Declaration]
d)

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

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

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

    [PrimitiveWarning]
-> CompiledPrimitive -> NetlistMonad CompiledPrimitive
go [PrimitiveWarning]
ws CompiledPrimitive
cp

  go ((WarnNonSynthesizable String
warning):[PrimitiveWarning]
ws) CompiledPrimitive
cp = do
    Bool
isTB <- Getting Bool NetlistState Bool -> NetlistMonad Bool
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting Bool NetlistState Bool
Lens' NetlistState Bool
isTestBench
    if Bool
isTB then [PrimitiveWarning]
-> CompiledPrimitive -> NetlistMonad CompiledPrimitive
go [PrimitiveWarning]
ws CompiledPrimitive
cp else [PrimitiveWarning]
-> CompiledPrimitive -> NetlistMonad CompiledPrimitive
go ((String -> PrimitiveWarning
WarnAlways String
warning)PrimitiveWarning -> [PrimitiveWarning] -> [PrimitiveWarning]
forall a. a -> [a] -> [a]
:[PrimitiveWarning]
ws) CompiledPrimitive
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 (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 (String -> Type
forall a. HasCallStack => String -> a
error String
"mkPrimitive") ([Type] -> Maybe Type
forall a. [a] -> Maybe a
listToMaybe [Type]
tys)

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

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

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

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

                    -- Otherwise don't render them
                    Maybe (Id, Identifier, [Declaration])
Nothing -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
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
                  Maybe (Id, Identifier, [Declaration])
resM <- HasCallStack =>
Bool
-> NetlistId
-> NetlistMonad (Maybe (Id, Identifier, [Declaration]))
Bool
-> NetlistId
-> NetlistMonad (Maybe (Id, Identifier, [Declaration]))
resBndr1 Bool
False NetlistId
dst
                  case Maybe (Id, Identifier, [Declaration])
resM of
                    Just (Id
dst',Identifier
_,[Declaration]
_) -> do
                      (BlackBoxContext
bbCtx,[Declaration]
ctxDcls)      <- HasCallStack =>
Text
-> [Id]
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
Text
-> [Id]
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext (PrimInfo -> Text
primName PrimInfo
pInfo) [Id
dst'] [Either Term Type]
args
                      (BlackBox
bbTempl,[Declaration]
templDecl0) <- Text
-> BlackBox
-> BlackBoxContext
-> NetlistMonad (BlackBox, [Declaration])
prepareBlackBox Text
pNm BlackBox
template BlackBoxContext
bbCtx
                      let templDecl1 :: [Declaration]
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
                      (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> BlackBoxContext
-> Bool
-> Expr
BlackBoxE Text
pNm (CompiledPrimitive -> [BlackBoxTemplate]
forall a b c d. Primitive a b c d -> [a]
libraries CompiledPrimitive
p) (CompiledPrimitive -> [BlackBoxTemplate]
forall a b c d. Primitive a b c d -> [a]
imports CompiledPrimitive
p) (CompiledPrimitive -> [((Text, Text), BlackBox)]
forall a b c d. Primitive a b c d -> [((Text, Text), b)]
includes CompiledPrimitive
p) BlackBox
bbTempl BlackBoxContext
bbCtx Bool
bbEParen,[Declaration]
ctxDcls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
templDecl1)
                    -- Render expression as a Noop when requested
                    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 -> Int -> TmName
forall a. Text -> Int -> Name a
mkUnsafeSystemName Text
"__VOID_TEXPRE_NOOP__" Int
0)
                      (BlackBoxContext
bbCtx,[Declaration]
ctxDcls) <- HasCallStack =>
Text
-> [Id]
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
Text
-> [Id]
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext (PrimInfo -> Text
primName PrimInfo
pInfo) [Id
dst1] [Either Term Type]
args
                      (BlackBox
templ,[Declaration]
templDecl) <- Text
-> BlackBox
-> BlackBoxContext
-> NetlistMonad (BlackBox, [Declaration])
prepareBlackBox Text
pNm BlackBox
template BlackBoxContext
bbCtx
                      let bbDecl :: Declaration
bbDecl = Text
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> BlackBoxContext
-> Declaration
N.BlackBoxD Text
pNm (CompiledPrimitive -> [BlackBoxTemplate]
forall a b c d. Primitive a b c d -> [a]
libraries CompiledPrimitive
p) (CompiledPrimitive -> [BlackBoxTemplate]
forall a b c d. Primitive a b c d -> [a]
imports CompiledPrimitive
p)
                                               (CompiledPrimitive -> [((Text, Text), BlackBox)]
forall a b c d. Primitive a b c d -> [((Text, Text), b)]
includes CompiledPrimitive
p) BlackBox
templ BlackBoxContext
bbCtx
                      (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
Noop, [Declaration]
ctxDcls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
templDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
bbDecl])

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

          | Text
pNm Text -> [Text] -> Bool
forall (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
                Int
iw <- Getting Int NetlistEnv Int -> NetlistMonad Int
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting Int NetlistEnv Int
Getter NetlistEnv Int
intWidth
                (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (HWType, Int) -> Literal -> Expr
N.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
Signed Int
iw,Int
iw)) (Integer -> Literal
NumLit (Integer -> Literal) -> Integer -> Literal
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ DataCon -> Int
dcTag DataCon
dc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1),[])
              [Right Type
_, Right Type
_,Left Term
scrut] -> do
                TyConMap
tcm      <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
                let scrutTy :: Type
scrutTy = TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
scrut
                HWType
scrutHTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(String
curLoc) Type
scrutTy
                (Expr
scrutExpr,[Declaration]
scrutDecls) <-
                  HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Concurrent (Identifier -> Type -> NetlistId
NetlistId (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"c$dtt_rhs") Type
scrutTy) Term
scrut
                case Expr
scrutExpr of
                  Identifier Identifier
id_ Maybe Modifier
Nothing -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
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
                    Identifier
tmpRhs <- Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.make Text
"c$dtt_rhs"
                    let assignTy :: Usage
assignTy = case DeclarationType
declType of { DeclarationType
Concurrent -> Usage
Cont ; DeclarationType
Sequential -> Blocking -> Usage
Proc Blocking
Blocking }
                    [Declaration]
netDecl <- HasCallStack =>
DeclarationType
-> Usage
-> Identifier
-> HWType
-> Expr
-> NetlistMonad [Declaration]
DeclarationType
-> Usage
-> Identifier
-> HWType
-> Expr
-> NetlistMonad [Declaration]
N.mkInit DeclarationType
declType Usage
assignTy Identifier
tmpRhs HWType
scrutHTy Expr
scrutExpr
                    (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
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
tmpRhs),[Declaration]
netDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
scrutDecls)
              [Either Term Type]
_ -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error (String -> NetlistMonad (Expr, [Declaration]))
-> String -> NetlistMonad (Expr, [Declaration])
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"dataToTag: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show ((Either Term Type -> String) -> [Either Term Type] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> String) -> (Type -> String) -> Either Term Type -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Term -> String
forall p. PrettyPrec p => p -> String
showPpr Type -> String
forall p. PrettyPrec p => p -> String
showPpr) [Either Term Type]
args)

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

          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Explicit.SimIO.bindSimIO#" -> do
              (Expr
expr,[Declaration]
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)
              Maybe ([Id], [Identifier], [Declaration])
resM <- Bool
-> NetlistId
-> NetlistMonad (Maybe ([Id], [Identifier], [Declaration]))
resBndr Bool
True NetlistId
dst
              case Maybe ([Id], [Identifier], [Declaration])
resM of
                Just ([Id]
_,[Identifier]
dstNms,[Declaration]
dstDecl) -> case Expr
expr of
                  Expr
Noop ->
                    (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
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
                      (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ( Identifier -> Maybe Modifier -> Expr
Identifier Identifier
dstNm Maybe Modifier
forall a. Maybe a
Nothing
                             , [Declaration]
dstDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
decls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Identifier -> Usage -> Expr -> Declaration
Assignment Identifier
dstNm (Blocking -> Usage
Proc Blocking
Blocking) Expr
expr])
                    [Identifier]
_ -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error (String -> NetlistMonad (Expr, [Declaration]))
-> String -> NetlistMonad (Expr, [Declaration])
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"bindSimIO: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe ([Id], [Identifier], [Declaration]) -> String
forall a. Show a => a -> String
show Maybe ([Id], [Identifier], [Declaration])
resM
                Maybe ([Id], [Identifier], [Declaration])
_ ->
                  (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
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
              Maybe (Id, Identifier, [Declaration])
resM <- HasCallStack =>
Bool
-> NetlistId
-> NetlistMonad (Maybe (Id, Identifier, [Declaration]))
Bool
-> NetlistId
-> NetlistMonad (Maybe (Id, Identifier, [Declaration]))
resBndr1 Bool
True NetlistId
dst
              case Maybe (Id, Identifier, [Declaration])
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
                    TyConMap
tcm <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
                    let arg1 :: Term
arg1 = TyConMap -> Term -> Term
unSimIO TyConMap
tcm Term
arg0
                        fun1 :: Term
fun1 = case Term
fun0 of
                          Lam Id
b Term
bE ->
                            let is0 :: InScopeSet
is0 = VarSet -> InScopeSet
mkInScopeSet (Getting VarSet Term Id -> (Id -> VarSet) -> Term -> VarSet
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting VarSet Term Id
Fold Term Id
freeIds Id -> VarSet
forall a. Var a -> VarSet
unitVarSet Term
fun0)
                                subst :: Subst
subst = Subst -> Id -> Term -> Subst
extendIdSubst (InScopeSet -> Subst
mkSubst InScopeSet
is0) Id
b Term
arg1
                            in  HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm 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
expr,[Declaration]
bindDecls) <- HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Sequential NetlistId
dst Term
fun1
                    [Declaration]
assn <- case Expr
expr of
                              Expr
Noop -> [Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
                              Expr
_ -> do Usage -> Identifier -> NetlistMonad ()
declareUse (Blocking -> Usage
Proc Blocking
Blocking) Identifier
dstNm
                                      [Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [Identifier -> Usage -> Expr -> Declaration
Assignment Identifier
dstNm (Blocking -> Usage
Proc Blocking
Blocking) Expr
expr]
                    (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
dstNm Maybe Modifier
forall a. Maybe a
Nothing, [Declaration]
dstDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
bindDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
assn)
                  [Term]
args1 -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error (String
"internal error: fmapSimIO# has insufficient arguments"
                                  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Term] -> String
forall p. PrettyPrec p => p -> String
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
                    (Expr
_,[Declaration]
bindDecls) <- HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
True DeclarationType
Sequential NetlistId
dst Term
arg0
                    (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
Noop, [Declaration]
bindDecls)
                  [Term]
args1 -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error (String
"internal error: fmapSimIO# has insufficient arguments"
                                  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Term] -> String
forall p. PrettyPrec p => p -> String
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]
_ -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error String
"internal error: insufficient arguments"

          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Explicit.SimIO.pureSimIO#" -> do
              (Expr
expr,[Declaration]
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]
_ -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error String
"internal error: insufficient arguments"
              Maybe ([Id], [Identifier], [Declaration])
resM <- Bool
-> NetlistId
-> NetlistMonad (Maybe ([Id], [Identifier], [Declaration]))
resBndr Bool
True NetlistId
dst
              case Maybe ([Id], [Identifier], [Declaration])
resM of
                Just ([Id]
_,[Identifier]
dstNms,[Declaration]
dstDecl) -> case Expr
expr of
                  Expr
Noop ->
                    (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
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
                      (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ( Identifier -> Maybe Modifier -> Expr
Identifier Identifier
dstNm Maybe Modifier
forall a. Maybe a
Nothing
                             , [Declaration]
dstDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
decls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Identifier -> Usage -> Expr -> Declaration
Assignment Identifier
dstNm (Blocking -> Usage
Proc Blocking
Blocking) Expr
expr])
                    [Identifier]
_ -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error String
"internal error"
                Maybe ([Id], [Identifier], [Declaration])
_ ->
                  (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
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
expr,[Declaration]
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
Concurrent NetlistId
dst Term
arg
                [Term]
_ -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error String
"internal error: insufficient arguments"
              Int
iw <- Getting Int NetlistEnv Int -> NetlistMonad Int
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting Int NetlistEnv Int
Getter NetlistEnv Int
intWidth
              (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Modifier -> [Expr] -> Expr
N.DataCon (Int -> HWType
Signed Int
iw) ((HWType, Int) -> Modifier
DC (Maybe HWType -> HWType
Void Maybe HWType
forall a. Maybe a
Nothing,-Int
1)) [Expr
expr],[Declaration]
decls)

          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Num.Integer.IP" -> do
              (Expr
expr,[Declaration]
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
Concurrent NetlistId
dst Term
arg
                [Term]
_ -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error String
"internal error: insufficient arguments"
              case Expr
expr of
                N.Literal Maybe (HWType, Int)
Nothing (NumLit Integer
_) -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
expr,[Declaration]
decls)
                Expr
_ -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error String
"non-constant ByteArray# not supported"

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

          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Num.Natural.NS" -> do
              (Expr
expr,[Declaration]
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
Concurrent NetlistId
dst Term
arg
                [Term]
_ -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error String
"internal error: insufficient arguments"
              Int
iw <- Getting Int NetlistEnv Int -> NetlistMonad Int
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting Int NetlistEnv Int
Getter NetlistEnv Int
intWidth
              (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Modifier -> [Expr] -> Expr
N.DataCon (Int -> HWType
Unsigned Int
iw) ((HWType, Int) -> Modifier
DC (Maybe HWType -> HWType
Void Maybe HWType
forall a. Maybe a
Nothing,-Int
1)) [Expr
expr],[Declaration]
decls)

          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Num.Integer.NB" -> do
              (Expr
expr,[Declaration]
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
Concurrent NetlistId
dst Term
arg
                [Term]
_ -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error String
"internal error: insufficient arguments"
              case Expr
expr of
                N.Literal Maybe (HWType, Int)
Nothing (NumLit Integer
_) -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
expr,[Declaration]
decls)
                Expr
_ -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error String
"non-constant ByteArray# not supported"

          | Bool
otherwise ->
              (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> BlackBoxContext
-> Bool
-> Expr
BlackBoxE 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
      HWType
resHwTy <- case [Type]
tys of
        (Type
ty1:[Type]
_) -> String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(String
curLoc) Type
ty1
        [Type]
_ -> String -> NetlistMonad HWType
forall a. HasCallStack => String -> a
error String
"internal error: insufficient types"
      if HWType -> Bool
isVoid HWType
resHwTy then
        Maybe ([Id], [Identifier], [Declaration])
-> NetlistMonad (Maybe ([Id], [Identifier], [Declaration]))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe ([Id], [Identifier], [Declaration])
forall a. Maybe a
Nothing
      else
        case NetlistId
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 -> Int -> Name a
forall a. Text -> Int -> Name a
mkUnsafeSystemName (Identifier -> Text
Id.toText Identifier
dstL) Int
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 (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
              Identifier
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 :: Name a
nm3 = Text -> Int -> Name a
forall a. Text -> Int -> Name a
mkUnsafeSystemName (Identifier -> Text
Id.toText Identifier
nm2) Int
0
                  id_ :: Id
id_ = Type -> TmName -> Id
mkLocalId Type
ty TmName
forall a. Name a
nm3

              [Declaration]
idDeclM <- LetBinding -> NetlistMonad [Declaration]
mkNetDecl (Id
id_, Term -> [Either Term Type] -> Term
mkApps (PrimInfo -> Term
Prim PrimInfo
pInfo) [Either Term Type]
args)
              case [Declaration]
idDeclM of
                [] -> Maybe ([Id], [Identifier], [Declaration])
-> NetlistMonad (Maybe ([Id], [Identifier], [Declaration]))
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 (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 -> String -> NetlistMonad (Maybe ([Id], [Identifier], [Declaration]))
forall a. HasCallStack => String -> 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 (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 (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 :: 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 (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 (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 (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])
_ -> String -> NetlistMonad (Maybe (Id, Identifier, [Declaration]))
forall a. HasCallStack => String -> a
error String
"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 :: 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 = VarSet -> InScopeSet
mkInScopeSet (Getting VarSet Term Id -> (Id -> VarSet) -> Term -> VarSet
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting VarSet Term Id
Fold Term Id
freeIds Id -> VarSet
forall a. Var a -> VarSet
unitVarSet Term
res0 VarSet -> VarSet -> VarSet
forall a. Semigroup a => a -> a -> a
<>
                          Getting VarSet Term Id -> (Id -> VarSet) -> Term -> VarSet
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting VarSet Term Id
Fold Term Id
freeIds Id -> VarSet
forall a. Var a -> VarSet
unitVarSet Term
mealyInit VarSet -> VarSet -> VarSet
forall a. Semigroup a => a -> a -> a
<>
                          Getting VarSet Term Id -> (Id -> VarSet) -> Term -> VarSet
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting VarSet Term Id
Fold Term Id
freeIds Id -> VarSet
forall a. Var a -> VarSet
unitVarSet Term
mealyIn)
      -- Given that we're creating a sequential list of statements from the
      -- let-bindings, make sure that everything is inverse topologically sorted
      ([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 -> Int -> TmName
forall a. Text -> Int -> Name a
mkUnsafeSystemName Text
"mealyres" Int
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 -> Int -> TmName
forall a. Text -> Int -> Name a
mkUnsafeSystemName Text
"mealyres" Int
0))
          in  ([(Id
u,Term
e)], Id
u)
#if __GLASGOW_HASKELL__ >= 900
      args1 = args0
#else
      -- Drop the 'State# World' argument
      args1 :: [Id]
args1 = [Id] -> [Id]
forall a. [a] -> [a]
init [Id]
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 (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
  ([Bool], [(Identifier, HWType)], [Declaration],
 [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
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 ([Bool], [(Identifier, HWType)], [Declaration],
 [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
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 (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 (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. [a] -> [a]
init [LetBinding]
binders2

      -- Create new net declarations for state-binders, input-binders, and all
      -- the "original" let-bindings in 'mealyFun'
      --
      -- The first set is only assigned in the always block, so they must be
      -- 'reg' in Verilog terminology
      [Declaration]
netDeclsSeq <- (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'
      [Declaration]
netDeclsInp <- (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]
iBinders

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

      -- When the body the let-expression of 'mealyFun' was variable reference,
      -- or in case we had to create a new identifier because the original LHS
      -- was not available: then we need to assign
      (Expr
resExpr,[Declaration]
resDecls) <- case Term
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 (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)

      [Declaration]
resAssn <- case Expr
resExpr of
            Expr
Noop -> [Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
            Expr
_ -> do
              Seq
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
              [Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [[Seq] -> Declaration
Seq [[Seq] -> Seq
AlwaysComb [Seq
assign]]]

      -- Create the declarations for the "initial state" block
      let sDst :: NetlistId
sDst = case [LetBinding]
sBinders of
                   [] -> String -> NetlistId
forall a. HasCallStack => String -> a
error String
"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)

      (Expr
exprInit,[Declaration]
initDecls) <- HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Sequential NetlistId
sDst Term
mealyInit

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

      -- Create the declarations that corresponding to the input
      let iDst :: NetlistId
iDst = case [LetBinding]
iBinders of
                   []      -> String -> NetlistId
forall a. HasCallStack => String -> a
error String
"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)

      (Expr
exprArg,[Declaration]
inpDeclsMisc) <- HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Concurrent NetlistId
iDst Term
mealyIn

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

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

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

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

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

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

-- | Collect the sequential declarations for 'bindIO'
collectBindIO :: NetlistId -> [Term] -> NetlistMonad (Expr,[Declaration])
#if __GLASGOW_HASKELL__ >= 900
collectBindIO dst (m:Lam x q@e:_) = do
#else
collectBindIO :: NetlistId -> [Term] -> NetlistMonad (Expr, [Declaration])
collectBindIO NetlistId
dst (Term
m:Lam Id
x q :: Term
q@(Lam Id
_ Term
e):[Term]
_) = do
#endif
  TyConMap
tcm <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
  ([Declaration]
ds0,Subst
subst) <- TyConMap -> NetlistMonad ([Declaration], Subst)
collectAction TyConMap
tcm
  let qS :: Term
qS = HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm Doc ()
"collectBindIO1" Subst
subst Term
q
  case TyConMap -> Term -> Either String ([Id], [LetBinding], Id)
splitNormalized TyConMap
tcm Term
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 = VarSet -> InScopeSet
mkInScopeSet (Getting VarSet Term Id -> (Id -> VarSet) -> Term -> VarSet
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting VarSet Term Id
Fold Term Id
freeIds Id -> VarSet
forall a. Var a -> VarSet
unitVarSet Term
qS)
      ([Bool], [(Identifier, HWType)], [Declaration],
 [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
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 ([Bool], [(Identifier, HWType)], [Declaration],
 [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
normE of
        ([Bool]
_,[(Identifier, HWType)]
_,[],[(Identifier, HWType)]
_,[],[LetBinding]
binders,Just Id
result) -> do
          [Declaration]
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
          [Declaration]
netDecls <- (LetBinding -> NetlistMonad [Declaration])
-> [LetBinding] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m [b]) -> [a] -> m [b]
concatMapM LetBinding -> NetlistMonad [Declaration]
mkNetDecl [LetBinding]
binders
          (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Identifier -> Maybe Modifier -> Expr
Identifier (HasCallStack => Id -> Identifier
Id -> Identifier
Id.unsafeFromCoreId Id
result) Maybe Modifier
forall a. Maybe a
Nothing, [Declaration]
netDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
ds0 [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
ds1)
        ([Bool], [(Identifier, HWType)], [Declaration],
 [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
_ -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error String
"internal error"
    Either String ([Id], [LetBinding], Id)
_ -> case HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm Doc ()
"collectBindIO2" Subst
subst Term
e of
      Letrec {} -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error String
"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
expr,[Declaration]
ds1) <- NetlistId -> [Term] -> NetlistMonad (Expr, [Declaration])
collectBindIO NetlistId
dst ([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args)
            (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
expr, [Declaration]
ds0 [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
ds1)
      Term
eS -> do
        (Expr
expr,[Declaration]
ds1) <- HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Sequential NetlistId
dst Term
eS
        (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
expr, [Declaration]
ds0 [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
ds1)
 where
  collectAction :: TyConMap -> NetlistMonad ([Declaration], Subst)
collectAction TyConMap
tcm = case TyConMap -> Term -> Either String ([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 = VarSet -> InScopeSet
mkInScopeSet (Getting VarSet Term Id -> (Id -> VarSet) -> Term -> VarSet
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting VarSet Term Id
Fold Term Id
freeIds Id -> VarSet
forall a. Var a -> VarSet
unitVarSet Term
m)
      ([Bool], [(Identifier, HWType)], [Declaration],
 [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
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 ([Bool], [(Identifier, HWType)], [Declaration],
 [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
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)]
          [Declaration]
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
          [Declaration]
netDecls <- (LetBinding -> NetlistMonad [Declaration])
-> [LetBinding] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m [b]) -> [a] -> m [b]
concatMapM LetBinding -> NetlistMonad [Declaration]
mkNetDecl [LetBinding]
binders
          ([Declaration], Subst) -> NetlistMonad ([Declaration], Subst)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Declaration]
netDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
ds1,Subst -> Id -> Term -> Subst
extendIdSubst (InScopeSet -> Subst
mkSubst InScopeSet
eInScopeSet) Id
x (Id -> Term
Var (LetBinding -> Id
forall a b. (a, b) -> a
fst LetBinding
b)))
        ([Bool], [(Identifier, HWType)], [Declaration],
 [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
_ -> String -> NetlistMonad ([Declaration], Subst)
forall a. HasCallStack => String -> a
error String
"internal error"
    Either String ([Id], [LetBinding], Id)
_ -> do
      ([Id
x'],Subst
s) <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique (InScopeSet -> Subst
mkSubst InScopeSet
eInScopeSet) [Id
x]
      [Declaration]
netDecls <- (LetBinding -> NetlistMonad [Declaration])
-> [LetBinding] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m [b]) -> [a] -> m [b]
concatMapM LetBinding -> NetlistMonad [Declaration]
mkNetDecl [(Id
x',Term
m)]
      [Declaration]
ds1 <- HasCallStack =>
DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
mkDeclarations' DeclarationType
Sequential Id
x' Term
m
      ([Declaration], Subst) -> NetlistMonad ([Declaration], Subst)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Declaration]
netDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
ds1,Subst
s)

  eInScopeSet :: InScopeSet
eInScopeSet = VarSet -> InScopeSet
mkInScopeSet (Getting VarSet Term Id -> (Id -> VarSet) -> Term -> VarSet
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting VarSet Term Id
Fold Term Id
freeIds Id -> VarSet
forall a. Var a -> VarSet
unitVarSet Term
e)

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

-- | Collect the sequential declarations for 'appIO'
collectAppIO :: NetlistId -> [Term] -> [Term] -> NetlistMonad (Expr,[Declaration])
collectAppIO :: NetlistId -> [Term] -> [Term] -> NetlistMonad (Expr, [Declaration])
collectAppIO 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
    TyConMap
tcm <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
    let argN :: [Either Term b]
argN = (Term -> Either Term b) -> [Term] -> [Either Term b]
forall a b. (a -> b) -> [a] -> [b]
map (Term -> Either Term b
forall a b. a -> Either a b
Left (Term -> Either Term b) -> (Term -> Term) -> Term -> Either Term b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyConMap -> Term -> Term
unSimIO TyConMap
tcm) (Term
arg0Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
:Term
arg1Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
:[Term]
rest)
    HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Sequential NetlistId
dst (Term -> [Either Term Type] -> Term
mkApps Term
fun0 [Either Term Type]
forall b. [Either Term b]
argN)
  (Prim (PrimInfo 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])
_ -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error (String
"internal error:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Term] -> String
forall p. PrettyPrec p => p -> String
showPpr (Term
fun1Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
:Term
arg1Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
:[Term]
rest))


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

-- | Unwrap the new-type wrapper for things of type SimIO, this is needed to
-- allow applications of the `State# World` token to the underlying IO type.
--
-- XXX: this is most likely needed because Ghc2Core that threw away the cast
-- that this unwrapping; we should really start to support casts.
unSimIO
  :: TyConMap
  -> Term
  -> Term
unSimIO :: TyConMap -> Term -> Term
unSimIO 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
_ -> String -> Term
forall a. HasCallStack => String -> a
error (String
"internal error:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
arg)

-- | Create an template instantiation text and a partial blackbox content for an
-- argument term, given that the term is a function. Errors if the term is not
-- a function
mkFunInput
  :: HasCallStack
  => TextS.Text
  -- ^ Name of the primitive of which the function in question is an argument.
  -- Used for error reporting.
  -> 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 :: Text
-> Id
-> Term
-> NetlistMonad
     ((Either BlackBox (Identifier, [Declaration]), Usage,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext),
      [Declaration])
mkFunInput Text
parentName 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
  TyConMap
tcm <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
  -- TODO: Rewrite this function to use blackbox functions. Right now it
  -- TODO: generates strings that are later parsed/interpreted again. Silly!
  Either
  (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Identifier, [Declaration]), Usage)
templ <- case Term
appE of
            Prim PrimInfo
p -> do
              CompiledPrimitive
bb  <- HasCallStack => Text -> NetlistMonad CompiledPrimitive
Text -> NetlistMonad CompiledPrimitive
extractPrimWarnOrFail (PrimInfo -> Text
primName PrimInfo
p)
              case CompiledPrimitive
bb of
                P.BlackBox {Bool
[BlackBoxTemplate]
[(Int, Int)]
[((Text, Text), BlackBox)]
[BlackBox]
()
Text
Usage
BlackBox
WorkInfo
TemplateKind
RenderVoid
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
template :: BlackBox
resultInits :: [BlackBox]
resultNames :: [BlackBox]
includes :: [((Text, Text), BlackBox)]
functionPlurality :: [(Int, Int)]
imports :: [BlackBoxTemplate]
libraries :: [BlackBoxTemplate]
outputUsage :: Usage
warning :: ()
kind :: TemplateKind
multiResult :: Bool
renderVoid :: RenderVoid
workInfo :: WorkInfo
name :: Text
renderVoid :: forall a b c d. Primitive a b c d -> RenderVoid
outputUsage :: forall a b c d. Primitive a b c d -> Usage
kind :: forall a b c d. Primitive a b c d -> TemplateKind
includes :: forall a b c d. Primitive a b c d -> [((Text, Text), b)]
imports :: forall a b c d. Primitive a b c d -> [a]
libraries :: forall a b c d. Primitive a b c d -> [a]
template :: forall a b c d. Primitive a b c d -> b
multiResult :: forall a b c d. Primitive a b c d -> Bool
name :: forall a b c d. Primitive a b c d -> Text
..} ->
                  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. 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 ->
                  String
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad
      (Either
         (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Identifier, [Declaration]), Usage)))
-> String
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Unexpected blackbox type: "
                                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Primitive " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
pn
                                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
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
                  String
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a. HasCallStack => String -> 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)
                  Either String (BlackBoxMeta, BlackBox)
bbhRes <- BlackBoxFunction
func Bool
True Text
pName [Either Term Type]
args [Type
resTy]
                  case Either String (BlackBoxMeta, BlackBox)
bbhRes of
                    Left String
err ->
                      String
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad
      (Either
         (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Identifier, [Declaration]), Usage)))
-> String
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ BlackBoxFunctionName -> String
forall a. Show a => a -> String
show BlackBoxFunctionName
fName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" yielded an error: "
                                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
                    Right (BlackBoxMeta{[BlackBoxTemplate]
[(Int, Int)]
[((Text, Text), BlackBox)]
[BlackBox]
Usage
TemplateKind
RenderVoid
bbResultInits :: [BlackBox]
bbResultNames :: [BlackBox]
bbRenderVoid :: RenderVoid
bbIncludes :: [((Text, Text), BlackBox)]
bbFunctionPlurality :: [(Int, Int)]
bbImports :: [BlackBoxTemplate]
bbLibrary :: [BlackBoxTemplate]
bbKind :: TemplateKind
bbOutputUsage :: Usage
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
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 (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

              Maybe FilteredHWType
resHTyM0 <- Type -> NetlistMonad (Maybe FilteredHWType)
coreTypeToHWTypeM Type
resTy
              let resHTyM1 :: Maybe (HWType, [[Bool]])
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 Maybe (HWType, [[Bool]])
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
Cont (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 (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
Cont))

                -- 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 = String -> [[Bool]] -> Int -> [Bool]
forall a. HasCallStack => String -> [a] -> Int -> a
indexNote ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"No areVoids with index: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
dcI) [[Bool]]
areVoids0 Int
dcI
                      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
Cont 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 (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
Cont))

                -- 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 = String -> [[Bool]] -> Int -> [Bool]
forall a. HasCallStack => String -> [a] -> Int -> a
indexNote ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"No areVoids with index: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
dcI) [[Bool]]
areVoids0 Int
dcI
                      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
Cont 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 (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
Cont))

                -- 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
Cont 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 (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
Cont))

                -- 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
Cont 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 (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
Cont))

                -- 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
Cont 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 (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
Cont))

                -- 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
Cont 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 (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
Cont))

                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 (m :: Type -> Type) a. Monad m => a -> m a
return (String
-> Either
     (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Identifier, [Declaration]), Usage)
forall a. HasCallStack => String -> a
error (String
 -> Either
      (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
       [((Text, Text), BlackBox)], Text, BlackBox)
      ((Identifier, [Declaration]), Usage))
-> String
-> Either
     (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Identifier, [Declaration]), Usage)
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Encountered Void in mkFunInput."
                                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" This is a bug in Clash.")

                Maybe (HWType, [[Bool]])
_ -> String
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad
      (Either
         (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Identifier, [Declaration]), Usage)))
-> String
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Cannot make function input for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
e
            C.Var Id
fun -> do
              VarEnv TopEntityT
topAnns <- Getting (VarEnv TopEntityT) NetlistState (VarEnv TopEntityT)
-> NetlistMonad (VarEnv TopEntityT)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (VarEnv TopEntityT) NetlistState (VarEnv TopEntityT)
Lens' NetlistState (VarEnv TopEntityT)
topEntityAnns
              case Id -> VarEnv TopEntityT -> Maybe TopEntityT
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
fun VarEnv TopEntityT
topAnns of
                Just TopEntityT
_ ->
                  String
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad
      (Either
         (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Identifier, [Declaration]), Usage)))
-> String
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Cannot make function input for partially applied Synthesize-annotated: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
e
                Maybe TopEntityT
_ -> do
                  BindingMap
normalized <- Getting BindingMap NetlistState BindingMap
-> NetlistMonad BindingMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting BindingMap NetlistState BindingMap
Lens' NetlistState BindingMap
bindings
                  case Id -> BindingMap -> Maybe (Binding Term)
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
fun BindingMap
normalized of
                    Just Binding Term
_ -> do
                      (ComponentMeta
meta,N.Component Identifier
compName [(Identifier, HWType)]
compInps [(Usage, (Identifier, HWType), Maybe Expr)]
compOutps [Declaration]
_) <-
                        NetlistMonad (ComponentMeta, Component)
-> NetlistMonad (ComponentMeta, Component)
forall a. NetlistMonad a -> NetlistMonad a
preserveVarEnv (NetlistMonad (ComponentMeta, Component)
 -> NetlistMonad (ComponentMeta, Component))
-> NetlistMonad (ComponentMeta, Component)
-> NetlistMonad (ComponentMeta, Component)
forall a b. (a -> b) -> a -> b
$ HasCallStack => Id -> NetlistMonad (ComponentMeta, Component)
Id -> NetlistMonad (ComponentMeta, Component)
genComponent Id
fun

                      let
                        ComponentMeta{[Bool]
cmWereVoids :: ComponentMeta -> [Bool]
cmWereVoids :: [Bool]
cmWereVoids} = ComponentMeta
meta
                        inpAssign :: (Identifier, c) -> d -> (Expr, PortDirection, c, d)
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 -> Identifier
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 :: [Expr]
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 :: [(Expr, PortDirection, HWType, Expr)]
inpAssigns = ((Identifier, HWType)
 -> Expr -> (Expr, PortDirection, HWType, Expr))
-> [(Identifier, HWType)]
-> [Expr]
-> [(Expr, PortDirection, HWType, Expr)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Identifier, HWType) -> Expr -> (Expr, PortDirection, HWType, Expr)
forall c d. (Identifier, c) -> d -> (Expr, PortDirection, c, d)
inpAssign [(Identifier, HWType)]
compInps [Expr]
inpVars
                        outpAssigns :: [(Expr, PortDirection, HWType, Expr)]
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 ->
                            String -> [(Expr, PortDirection, HWType, Expr)]
forall a. HasCallStack => String -> 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.
                            |]
                      Identifier
instLabel <- Identifier -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Identifier -> m Identifier
Id.next Identifier
compName
                      let
                        portMap :: PortMap
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 :: Declaration
instDecl = EntityOrComponent
-> Maybe Text
-> [Attr Text]
-> Identifier
-> Identifier
-> [(Expr, HWType, Expr)]
-> PortMap
-> Declaration
InstDecl EntityOrComponent
Entity Maybe Text
forall a. Maybe a
Nothing [] Identifier
compName Identifier
instLabel [] PortMap
portMap
                      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 (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
instDecl]), Usage
Cont))
                    Maybe (Binding Term)
Nothing -> String
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad
      (Either
         (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Identifier, [Declaration]), Usage)))
-> String
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Cannot make function input for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
e
            C.Lam {} -> do
              let is0 :: InScopeSet
is0 = VarSet -> InScopeSet
mkInScopeSet (Getting VarSet Term Id -> (Id -> VarSet) -> Term -> VarSet
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting VarSet Term Id
Fold Term Id
freeIds Id -> VarSet
forall a. Var a -> VarSet
unitVarSet Term
appE)
              ((TemplateKind, 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 (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 (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
_ -> String
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad
      (Either
         (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Identifier, [Declaration]), Usage)))
-> String
-> NetlistMonad
     (Either
        (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Identifier, [Declaration]), Usage))
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Cannot make function input for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
e
  let pNm :: Text
pNm = case Term
appE of
              Prim PrimInfo
p -> PrimInfo -> Text
primName PrimInfo
p
              Term
_ -> Text
"__INTERNAL__"
  (BlackBoxContext
bbCtx,[Declaration]
dcls) <- HasCallStack =>
Text
-> [Id]
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
Text
-> [Id]
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext Text
pNm [Id
resId] [Either Term Type]
args
  case Either
  (TemplateKind, Usage, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Identifier, [Declaration]), Usage)
templ of
    Left (TemplateKind
TDecl,Usage
outputUsage,[BlackBoxTemplate]
libs,[BlackBoxTemplate]
imps,[((Text, Text), BlackBox)]
inc,Text
_,BlackBox
templ') -> do
      (BlackBox
l',[Declaration]
templDecl)
        <- (BlackBoxTemplate -> NetlistMonad (BlackBox, [Declaration]))
-> (String
    -> Int
    -> TemplateFunction
    -> NetlistMonad (BlackBox, [Declaration]))
-> BlackBox
-> NetlistMonad (BlackBox, [Declaration])
forall r.
(BlackBoxTemplate -> r)
-> (String -> Int -> TemplateFunction -> r) -> BlackBox -> r
onBlackBox
            (((BlackBoxTemplate, [Declaration]) -> (BlackBox, [Declaration]))
-> NetlistMonad (BlackBoxTemplate, [Declaration])
-> NetlistMonad (BlackBox, [Declaration])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((BlackBoxTemplate -> BlackBox)
-> (BlackBoxTemplate, [Declaration]) -> (BlackBox, [Declaration])
forall (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)
            (\String
bbName Int
bbHash TemplateFunction
bbFunc -> (BlackBox, [Declaration]) -> NetlistMonad (BlackBox, [Declaration])
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((BlackBox, [Declaration])
 -> NetlistMonad (BlackBox, [Declaration]))
-> (BlackBox, [Declaration])
-> NetlistMonad (BlackBox, [Declaration])
forall a b. (a -> b) -> a -> b
$ (String -> Int -> TemplateFunction -> BlackBox
BBFunction String
bbName Int
bbHash TemplateFunction
bbFunc, []))
            BlackBox
templ'
      ((Either BlackBox (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. Monad m => a -> m a
return ((BlackBox -> Either BlackBox (Identifier, [Declaration])
forall a b. a -> Either a b
Left BlackBox
l',Usage
outputUsage,[BlackBoxTemplate]
libs,[BlackBoxTemplate]
imps,[((Text, Text), BlackBox)]
inc,BlackBoxContext
bbCtx),[Declaration]
dcls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
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]))
-> (String
    -> 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)
-> (String -> Int -> TemplateFunction -> r) -> BlackBox -> r
onBlackBox
        (\BlackBoxTemplate
t -> do Text
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'' :: Identifier
t'' = HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake (Text -> Text
Text.toStrict Text
t')
                      assn :: Declaration
assn = Identifier -> Usage -> Expr -> Declaration
Assignment (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"~RESULT") Usage
Cont (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
t'' Maybe Modifier
forall a. Maybe a
Nothing)
                  ((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. Monad m => a -> m a
return (((Identifier, [Declaration])
-> Either BlackBox (Identifier, [Declaration])
forall a b. b -> Either a b
Right (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"",[Declaration
assn]),Usage
Cont,[BlackBoxTemplate]
libs,[BlackBoxTemplate]
imps,[((Text, Text), BlackBox)]
inc,BlackBoxContext
bbCtx),[Declaration]
dcls))
        (\String
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
Cont
                            (Text
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> BlackBoxContext
-> Bool
-> Expr
BlackBoxE Text
nm [BlackBoxTemplate]
libs [BlackBoxTemplate]
imps [((Text, Text), BlackBox)]
inc BlackBox
templ' BlackBoxContext
bbCtx' Bool
False)
                Doc ()
p <- 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])
                Doc () -> State state (Doc ())
forall (m :: Type -> Type) a. Monad m => a -> m a
return Doc ()
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 (m :: Type -> Type) a. Monad m => a -> m a
return ((BlackBox -> Either BlackBox (Identifier, [Declaration])
forall a b. a -> Either a b
Left (String -> Int -> TemplateFunction -> BlackBox
BBFunction String
bbName Int
bbHash ([Int]
-> (BlackBoxContext -> Bool)
-> (forall s. Backend s => BlackBoxContext -> State s (Doc ()))
-> TemplateFunction
TemplateFunction [Int]
k BlackBoxContext -> Bool
g forall s. Backend s => BlackBoxContext -> State s (Doc ())
f'))
                  ,Usage
Cont
                  ,[]
                  ,[]
                  ,[]
                  ,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 (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
    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
      TyConMap
tcm <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
      HWType
resTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(String
curLoc) (TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
app)
      let ([Term]
tmArgs,[Type]
tyArgs) = [Either Term Type] -> ([Term], [Type])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Term Type]
args
      if [Type] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Type]
tyArgs
        then
          [TickInfo]
-> ([Declaration]
    -> NetlistMonad (Either a ((Identifier, [Declaration]), Usage)))
-> NetlistMonad (Either a ((Identifier, [Declaration]), Usage))
forall a.
[TickInfo] -> ([Declaration] -> NetlistMonad a) -> NetlistMonad a
withTicks [TickInfo]
ticks (([Declaration]
  -> NetlistMonad (Either a ((Identifier, [Declaration]), Usage)))
 -> NetlistMonad (Either a ((Identifier, [Declaration]), Usage)))
-> ([Declaration]
    -> NetlistMonad (Either a ((Identifier, [Declaration]), Usage)))
-> NetlistMonad (Either a ((Identifier, [Declaration]), Usage))
forall a b. (a -> b) -> a -> b
$ \[Declaration]
tickDecls -> do
            Identifier
resNm <- Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.make Text
"result"
            [Declaration]
appDecls <- HasCallStack =>
Identifier
-> Id -> [Term] -> [Declaration] -> NetlistMonad [Declaration]
Identifier
-> Id -> [Term] -> [Declaration] -> NetlistMonad [Declaration]
mkFunApp Identifier
resNm Id
fun [Term]
tmArgs [Declaration]
tickDecls
            let assn :: [Declaration]
assn = [ Identifier -> Usage -> Expr -> Declaration
Assignment (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"~RESULT") Usage
Cont (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 ]
            Identifier
nm <- Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic Text
"block"
            Either a ((Identifier, [Declaration]), Usage)
-> NetlistMonad (Either a ((Identifier, [Declaration]), Usage))
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 ((Identifier
nm,[Declaration]
assn[Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++[Declaration]
appDecls), Usage
Cont))
        else do
          (Identifier
_,SrcSpan
sp) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
          ClashException
-> NetlistMonad (Either a ((Identifier, [Declaration]), Usage))
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Not in normal form: Var-application with Type arguments:\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
app) Maybe String
forall a. Maybe a
Nothing)
    goExpr Term
e' = do
      TyConMap
tcm <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
      let eType :: Type
eType = TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
e'
      (Expr
appExpr,[Declaration]
appDecls) <- HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Concurrent (Identifier -> Type -> NetlistId
NetlistId (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"c$bb_res") Type
eType) Term
e'
      let assn :: Declaration
assn = Identifier -> Usage -> Expr -> Declaration
Assignment (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"~RESULT") Usage
Cont Expr
appExpr
      Identifier
nm <- if [Declaration] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Declaration]
appDecls
               then Identifier -> NetlistMonad Identifier
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"")
               else Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic Text
"block"
      Either a ((Identifier, [Declaration]), Usage)
-> NetlistMonad (Either a ((Identifier, [Declaration]), Usage))
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 ((Identifier
nm,[Declaration]
appDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
assn]), Usage
Cont))

    go :: InScopeSet
-> Int
-> Term
-> NetlistMonad (Either a ((Identifier, [Declaration]), Usage))
go InScopeSet
is0 Int
n (Lam Id
id_ Term
e') = do
      Int
lvl <- Getting Int NetlistState Int -> NetlistMonad Int
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting Int NetlistState Int
Lens' NetlistState Int
curBBlvl
      let nm :: Text
nm    = [Text] -> Text
TextS.concat
                    [Text
"~ARGN[",String -> Text
TextS.pack (Int -> String
forall a. Show a => a -> String
show Int
lvl),Text
"][",String -> Text
TextS.pack (Int -> String
forall a. Show a => a -> String
show Int
n),Text
"]"]
          v' :: Id
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 :: Text
nameOcc = Text
nm}) Id
id_)
          subst :: Subst
subst = Subst -> Id -> Term -> Subst
extendIdSubst (InScopeSet -> Subst
mkSubst InScopeSet
is0) Id
id_ (Id -> Term
C.Var Id
v')
          e'' :: Term
e''   = HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm Doc ()
"mkFunInput.goLam" Subst
subst Term
e'
          is1 :: InScopeSet
is1   = InScopeSet -> Id -> InScopeSet
forall a. InScopeSet -> Var a -> InScopeSet
extendInScopeSet InScopeSet
is0 Id
v'
      InScopeSet
-> Int
-> Term
-> NetlistMonad (Either a ((Identifier, [Declaration]), Usage))
go InScopeSet
is1 (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+(Int
1::Int)) Term
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
Cont (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 (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
Cont))

    go InScopeSet
_ Int
_ (Case Term
scrut Type
ty [Alt
alt]) = do
      TyConMap
tcm <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
      let sTy :: Type
sTy = TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
scrut
      (Expr
projection,[Declaration]
decls) <- Bool
-> NetlistId
-> Term
-> Type
-> Alt
-> NetlistMonad (Expr, [Declaration])
mkProjection Bool
False (Identifier -> Type -> NetlistId
NetlistId (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"c$bb_res") Type
sTy) Term
scrut Type
ty Alt
alt
      let assn :: Declaration
assn = Identifier -> Usage -> Expr -> Declaration
Assignment (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"~RESULT") Usage
Cont Expr
projection
      Identifier
nm <- if [Declaration] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Declaration]
decls
               then Identifier -> NetlistMonad Identifier
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"")
               else Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic Text
"projection"
      Either a ((Identifier, [Declaration]), Usage)
-> NetlistMonad (Either a ((Identifier, [Declaration]), Usage))
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 ((Identifier
nm,[Declaration]
decls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
assn]), Usage
Cont))

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

    go InScopeSet
is0 Int
_ e' :: Term
e'@(Let{}) = do
      TyConMap
tcm <- Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache
      let normE :: Either String ([Id], [LetBinding], Id)
normE = TyConMap -> Term -> Either String ([Id], [LetBinding], Id)
splitNormalized TyConMap
tcm Term
e'
      ([Bool]
_,[],[],[(Identifier, HWType)]
_,[],[LetBinding]
binders,Maybe Id
resultM) <- case Either String ([Id], [LetBinding], Id)
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 String
err -> String
-> NetlistMonad
     ([Bool], [(Identifier, HWType)], [Declaration],
      [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
forall a. HasCallStack => String -> a
error String
err
      case Maybe Id
resultM of
        Just Id
result -> do
          -- TODO: figure out what to do with multires blackboxes here
          [Declaration]
netDecls <- (LetBinding -> NetlistMonad [Declaration])
-> [LetBinding] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m [b]) -> [a] -> m [b]
concatMapM LetBinding -> NetlistMonad [Declaration]
mkNetDecl ([LetBinding] -> NetlistMonad [Declaration])
-> [LetBinding] -> NetlistMonad [Declaration]
forall a b. (a -> b) -> a -> b
$ [LetBinding]
binders
          [Declaration]
decls    <- (LetBinding -> NetlistMonad [Declaration])
-> [LetBinding] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m [b]) -> [a] -> m [b]
concatMapM ((Id -> Term -> NetlistMonad [Declaration])
-> LetBinding -> NetlistMonad [Declaration]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HasCallStack => Id -> Term -> NetlistMonad [Declaration]
Id -> Term -> NetlistMonad [Declaration]
mkDeclarations) [LetBinding]
binders
          Identifier
nm <- Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic Text
"fun"
          let resultId :: Identifier
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 :: Declaration
resDecl = Identifier -> Usage -> Expr -> Declaration
Assignment (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"~RESULT") Usage
Cont (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
resultId Maybe Modifier
forall a. Maybe a
Nothing)
          Either a ((Identifier, [Declaration]), Usage)
-> NetlistMonad (Either a ((Identifier, [Declaration]), Usage))
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 ((Identifier
nm,Declaration
resDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
netDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
decls), Usage
Cont))
        Maybe Id
Nothing -> Either a ((Identifier, [Declaration]), Usage)
-> NetlistMonad (Either a ((Identifier, [Declaration]), Usage))
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
_ []) =
      String
-> NetlistMonad (Either a ((Identifier, [Declaration]), Usage))
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad (Either a ((Identifier, [Declaration]), Usage)))
-> String
-> NetlistMonad (Either a ((Identifier, [Declaration]), Usage))
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Cannot make function input for case without alternatives: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall a. Show a => a -> String
show Term
e'

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