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

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

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

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.IO.Class        (liftIO)
import           Data.Char                     (ord)
import           Data.Either                   (lefts, partitionEithers)
import qualified Data.HashMap.Lazy             as HashMap
import qualified Data.IntMap                   as IntMap
import           Data.List                     (elemIndex, partition)
import           Data.List.Extra               (countEq, mapAccumLM)
import           Data.Maybe                    (catMaybes, fromJust, fromMaybe)
import           Data.Semigroup.Monad
import qualified Data.Set                      as Set
import           Data.Text.Lazy                (fromStrict)
import qualified Data.Text.Lazy                as Text
import           Data.Text                     (unpack)
import qualified Data.Text                     as TextS
import           GHC.Stack
  (callStack, prettyCallStack)
import qualified System.Console.ANSI           as ANSI
import           System.Console.ANSI
  ( hSetSGR, SGR(SetConsoleIntensity, SetColor), Color(Magenta)
  , ConsoleIntensity(BoldIntensity), ConsoleLayer(Foreground), ColorIntensity(Vivid))
import           System.IO
  (hPutStrLn, stderr, hFlush, hIsTerminalDevice)
import           TextShow                      (showt)
import           Util                          (OverridingBool(..))

import           Clash.Annotations.Primitive
  (PrimitiveGuard(HasBlackBox, WarnNonSynthesizable, WarnAlways, DontTranslate),
   extractPrim)
import           Clash.Annotations.TopEntity
  (TopEntity(Synthesize), PortName(PortName))
import           Clash.Core.DataCon            as D (dcTag)
import           Clash.Core.FreeVars           (freeIds)
import           Clash.Core.Literal            as L (Literal (..))
import           Clash.Core.Name
  (Name (..), mkUnsafeSystemName)
import           Clash.Core.Pretty             (showPpr)
import           Clash.Core.Subst              (extendIdSubst, mkSubst, substTm)
import           Clash.Core.Term               as C
  (PrimInfo (..), Term (..), WorkInfo (..), collectArgs, collectArgsTicks, collectBndrs, mkApps)
import           Clash.Core.TermInfo
import           Clash.Core.Type               as C
  (Type (..), ConstTy (..), TypeView (..), mkFunTy, splitFunTys, splitFunTy, tyView)
import           Clash.Core.TyCon              as C (TyConMap, tyConDataCons)
import           Clash.Core.Util
  (inverseTopSortLetBindings, splitShouldSplit)
import           Clash.Core.Var                as V
  (Id, Var (..), mkLocalId, modifyVarName)
import           Clash.Core.VarEnv
  (extendInScopeSet, mkInScopeSet, lookupVarEnv, uniqAway, unitVarSet)
import {-# SOURCE #-} Clash.Netlist
  (genComponent, mkDcApplication, mkDeclarations, mkExpr, mkNetDecl,
   mkProjection, mkSelection, mkFunApp, mkDeclarations')
import qualified Clash.Backend                 as Backend
import           Clash.Debug                   (debugIsOn)
import           Clash.Driver.Types
  (opt_primWarn, opt_color, ClashOpts)
import           Clash.Netlist.BlackBox.Types  as B
import           Clash.Netlist.BlackBox.Util   as B
import           Clash.Netlist.Id              (IdType (..))
import           Clash.Netlist.Types           as N
import           Clash.Netlist.Util            as N
import           Clash.Primitives.Types        as P
import qualified Clash.Primitives.Util         as P
import           Clash.Signal.Internal         (ActiveEdge (..))
import           Clash.Unique                  (lookupUniqMap')
import           Clash.Util
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]
  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
  :: TextS.Text
  -- ^ Blackbox function name
  -> Id
  -- ^ Identifier binding the primitive/blackbox application
  -> [Either Term Type]
  -- ^ Arguments of the primitive/blackbox application
  -> NetlistMonad (BlackBoxContext,[Declaration])
mkBlackBoxContext :: Text
-> Id
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext Text
bbName Id
resId args :: [Either Term Type]
args@([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts -> [Term]
termArgs) = do
    -- Make context inputs
    let resNm :: Text
resNm = Name Term -> Text
forall a. Name a -> Text
nameOcc (Id -> Name Term
forall a. Var a -> Name a
varName Id
resId)
    HWType
resTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(String
curLoc) (Id -> Type
forall a. Var a -> Type
V.varType Id
resId)
    ([(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
-> Text
-> Int
-> Term
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
mkArgument Text
bbName Text
resNm) [Int
0..] [Term]
termArgs
    (IntMap
  [(Either BlackBox (Text, [Declaration]), WireOrReg,
    [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
    BlackBoxContext)]
funs,[[Declaration]]
funDecls) <-
      (IntMap
   [(Either BlackBox (Text, [Declaration]), WireOrReg,
     [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
     BlackBoxContext)]
 -> (Term, Int)
 -> NetlistMonad
      (IntMap
         [(Either BlackBox (Text, [Declaration]), WireOrReg,
           [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
           BlackBoxContext)],
       [Declaration]))
-> IntMap
     [(Either BlackBox (Text, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext)]
-> [(Term, Int)]
-> NetlistMonad
     (IntMap
        [(Either BlackBox (Text, [Declaration]), WireOrReg,
          [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
          BlackBoxContext)],
      [[Declaration]])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM
        (Type
-> IntMap
     [(Either BlackBox (Text, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext)]
-> (Term, Int)
-> NetlistMonad
     (IntMap
        [(Either BlackBox (Text, [Declaration]), WireOrReg,
          [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
          BlackBoxContext)],
      [Declaration])
addFunction (Id -> Type
forall a. Var a -> Type
V.varType Id
resId))
        IntMap
  [(Either BlackBox (Text, [Declaration]), WireOrReg,
    [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
    BlackBoxContext)]
forall a. IntMap a
IntMap.empty
        ([Term] -> [Int] -> [(Term, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Term]
termArgs [Int
0..])

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

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

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

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

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

prepareBlackBox
  :: TextS.Text
  -> BlackBox
  -> BlackBoxContext
  -> NetlistMonad (BlackBox,[Declaration])
prepareBlackBox :: Text
-> BlackBox
-> BlackBoxContext
-> NetlistMonad (BlackBox, [Declaration])
prepareBlackBox 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 (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first BlackBoxTemplate -> BlackBox
BBTemplate) (NetlistMonad (BlackBoxTemplate, [Declaration])
 -> NetlistMonad (BlackBox, [Declaration]))
-> (BlackBoxTemplate
    -> NetlistMonad (BlackBoxTemplate, [Declaration]))
-> BlackBoxTemplate
-> NetlistMonad (BlackBox, [Declaration])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IdType -> Text -> NetlistMonad Text)
-> BlackBoxContext
-> BlackBoxTemplate
-> NetlistMonad (BlackBoxTemplate, [Declaration])
forall (m :: Type -> Type).
Monad m =>
(IdType -> Text -> m Text)
-> BlackBoxContext
-> BlackBoxTemplate
-> m (BlackBoxTemplate, [Declaration])
setSym IdType -> Text -> NetlistMonad Text
mkUniqueIdentifier BlackBoxContext
bbCtx)
          (\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
      (BlackBox, [Declaration]) -> NetlistMonad (BlackBox, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (BlackBox
t2,[Declaration]
decls)
    Just String
err0 -> do
      (Text
_,SrcSpan
sp) <- Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
-> NetlistMonad (Text, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
Lens' NetlistState (Text, SrcSpan)
curCompNm
      let err1 :: String
err1 = [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [ 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)

-- | 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
  -> Int
  -- ^ Argument n (zero-indexed). Used for error message.
  -> Term
  -> NetlistMonad ( (Expr,HWType,Bool)
                  , [Declaration]
                  )
mkArgument :: Text
-> Text
-> Int
-> Term
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
mkArgument Text
bbName Text
bndr Int
nArg Term
e = do
    TyConMap
tcm   <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
    let ty :: Type
ty = TyConMap -> Term -> Type
termType TyConMap
tcm Term
e
    Int
iw    <- Getting Int NetlistState Int -> NetlistMonad Int
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting Int NetlistState Int
Lens' NetlistState Int
intWidth
    Maybe HWType
hwTyM <- (FilteredHWType -> HWType) -> Maybe FilteredHWType -> Maybe HWType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap FilteredHWType -> HWType
stripFiltered (Maybe FilteredHWType -> Maybe HWType)
-> NetlistMonad (Maybe FilteredHWType)
-> NetlistMonad (Maybe HWType)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> NetlistMonad (Maybe FilteredHWType)
N.termHWTypeM Term
e
    let eTyMsg :: String
eTyMsg = String
"(" String -> String -> 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
== Text
"Clash.Transformations.removedArg"
        -> ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Text -> Maybe Modifier -> Expr
Identifier (PrimInfo -> Text
primName PrimInfo
p) Maybe Modifier
forall a. Maybe a
Nothing, Maybe HWType -> HWType
Void Maybe HWType
forall a. Maybe a
Nothing, Bool
False),[])
        | Bool
otherwise
        -> ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((String -> Expr
forall a. HasCallStack => String -> a
error ($(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]
_) -> ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Text -> Maybe Modifier -> Expr
Identifier (Name Term -> Text
forall a. Name a -> Text
nameOcc (Id -> Name Term
forall a. Var a -> Name a
varName Id
v)) Maybe Modifier
forall a. Maybe a
Nothing,HWType
hwTy,Bool
False),[])
        (C.Literal (IntegerLiteral Integer
i),[],[TickInfo]
_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Maybe (HWType, Int) -> Literal -> Expr
N.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
Signed Int
iw,Int
iw)) (Integer -> Literal
N.NumLit Integer
i),HWType
hwTy,Bool
True),[])
        (C.Literal (IntLiteral Integer
i), [],[TickInfo]
_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Maybe (HWType, Int) -> Literal -> Expr
N.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
Signed Int
iw,Int
iw)) (Integer -> Literal
N.NumLit Integer
i),HWType
hwTy,Bool
True),[])
        (C.Literal (WordLiteral Integer
w), [],[TickInfo]
_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Maybe (HWType, Int) -> Literal -> Expr
N.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
Unsigned Int
iw,Int
iw)) (Integer -> Literal
N.NumLit Integer
w),HWType
hwTy,Bool
True),[])
        (C.Literal (CharLiteral Char
c), [],[TickInfo]
_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Maybe (HWType, Int) -> Literal -> Expr
N.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
Unsigned Int
21,Int
21)) (Integer -> Literal
N.NumLit (Integer -> Literal) -> (Int -> Integer) -> Int -> Literal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Literal) -> Int -> Literal
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c),HWType
hwTy,Bool
True),[])
        (C.Literal (StringLiteral String
s),[],[TickInfo]
_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Maybe (HWType, Int) -> Literal -> Expr
N.Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (String -> Literal
N.StringLit String
s),HWType
hwTy,Bool
True),[])
        (C.Literal (Int64Literal Integer
i), [],[TickInfo]
_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Maybe (HWType, Int) -> Literal -> Expr
N.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
Signed Int
64,Int
64)) (Integer -> Literal
N.NumLit Integer
i),HWType
hwTy,Bool
True),[])
        (C.Literal (Word64Literal Integer
i), [],[TickInfo]
_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Maybe (HWType, Int) -> Literal -> Expr
N.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
Unsigned Int
64,Int
64)) (Integer -> Literal
N.NumLit Integer
i),HWType
hwTy,Bool
True),[])
        (C.Literal (NaturalLiteral Integer
n), [],[TickInfo]
_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Maybe (HWType, Int) -> Literal -> Expr
N.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
Unsigned Int
iw,Int
iw)) (Integer -> Literal
N.NumLit Integer
n),HWType
hwTy,Bool
True),[])
        (Prim 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
-> NetlistId
-> PrimInfo
-> [Either Term Type]
-> [Declaration]
-> NetlistMonad (Expr, [Declaration])
mkPrimitive Bool
True Bool
False (Text -> Type -> NetlistId
NetlistId Text
bndr Type
ty) PrimInfo
pinfo [Either Term Type]
args [Declaration]
tickDecls
          case Expr
e' of
            (Identifier Text
_ 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 =>
[HWType]
-> NetlistId
-> DataCon
-> [Term]
-> NetlistMonad (Expr, [Declaration])
[HWType]
-> NetlistId
-> DataCon
-> [Term]
-> NetlistMonad (Expr, [Declaration])
mkDcApplication [HWType
hwTy] (Text -> Type -> NetlistId
NetlistId Text
bndr Type
ty) DataCon
dc ([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args)
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Expr
exprN,HWType
hwTy,Term -> Bool
isLiteral Term
e),[Declaration]
dcDecls)
        (Case Term
scrut Type
ty' [Alt
alt],[],[TickInfo]
_) -> do
          (Expr
projection,[Declaration]
decls) <- Bool
-> NetlistId
-> Term
-> Type
-> Alt
-> NetlistMonad (Expr, [Declaration])
mkProjection Bool
False (Text -> Type -> NetlistId
NetlistId Text
bndr Type
ty) Term
scrut Type
ty' Alt
alt
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Expr
projection,HWType
hwTy,Bool
False),[Declaration]
decls)
        (Letrec [LetBinding]
_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 (Text -> Type -> NetlistId
NetlistId Text
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 ((Text -> Maybe Modifier -> Expr
Identifier (String -> Text
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)
  NetlistState
  (HashMap Text GuardedCompiledPrimitive)
-> NetlistMonad (HashMap Text GuardedCompiledPrimitive)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
  (HashMap Text GuardedCompiledPrimitive)
  NetlistState
  (HashMap Text GuardedCompiledPrimitive)
Lens' NetlistState (HashMap Text GuardedCompiledPrimitive)
primitives
  case Maybe GuardedCompiledPrimitive
prim of
    Just GuardedCompiledPrimitive
guardedPrim ->
      -- See if we need to warn the user, or error because we encountered
      -- a primitive the user explicitly requested not to translate
      GuardedCompiledPrimitive -> NetlistMonad CompiledPrimitive
go GuardedCompiledPrimitive
guardedPrim
    Maybe GuardedCompiledPrimitive
Nothing -> do
      -- Blackbox requested, but no blackbox found at all!
      (Text
_,SrcSpan
sp) <- Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
-> NetlistMonad (Text, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
Lens' NetlistState (Text, SrcSpan)
curCompNm
      let msg :: String
msg = $(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
    :: GuardedCompiledPrimitive
    -> NetlistMonad CompiledPrimitive
  go :: GuardedCompiledPrimitive -> NetlistMonad CompiledPrimitive
go (HasBlackBox CompiledPrimitive
cp) =
    CompiledPrimitive -> NetlistMonad CompiledPrimitive
forall (m :: Type -> Type) a. Monad m => a -> m a
return CompiledPrimitive
cp

  go GuardedCompiledPrimitive
DontTranslate = do
    (Text
_,SrcSpan
sp) <- Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
-> NetlistMonad (Text, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
Lens' NetlistState (Text, SrcSpan)
curCompNm
    let msg :: String
msg = $(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)

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

    Bool -> NetlistMonad () -> NetlistMonad ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool
primWarn Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
seen)
      (NetlistMonad () -> NetlistMonad ())
-> NetlistMonad () -> NetlistMonad ()
forall a b. (a -> b) -> a -> b
$ IO () -> NetlistMonad ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO
      (IO () -> NetlistMonad ()) -> IO () -> NetlistMonad ()
forall a b. (a -> b) -> a -> b
$ ClashOpts -> String -> IO ()
warn ClashOpts
opts
      (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ 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)"

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

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

  go (WarnNonSynthesizable String
warning CompiledPrimitive
cp) = do
    Bool
isTB <- Getting Bool NetlistState Bool -> NetlistMonad Bool
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting Bool NetlistState Bool
Lens' NetlistState Bool
isTestBench
    if Bool
isTB then CompiledPrimitive -> NetlistMonad CompiledPrimitive
forall (m :: Type -> Type) a. Monad m => a -> m a
return CompiledPrimitive
cp else GuardedCompiledPrimitive -> NetlistMonad CompiledPrimitive
go (String -> CompiledPrimitive -> GuardedCompiledPrimitive
forall a. String -> a -> PrimitiveGuard a
WarnAlways String
warning CompiledPrimitive
cp)


mkPrimitive
  :: Bool
  -- ^ Put BlackBox expression in parenthesis
  -> Bool
  -- ^ Treat BlackBox expression as declaration
  -> NetlistId
  -- ^ Id to assign the result to
  -> PrimInfo
  -- ^ Primitive info
  -> [Either Term Type]
  -- ^ Arguments
  -> [Declaration]
  -- ^ Tick declarations
  -> NetlistMonad (Expr,[Declaration])
mkPrimitive :: Bool
-> Bool
-> NetlistId
-> PrimInfo
-> [Either Term Type]
-> [Declaration]
-> NetlistMonad (Expr, [Declaration])
mkPrimitive Bool
bbEParen Bool
bbEasD 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
    ty :: Type
ty = [Type] -> Type
forall a. [a] -> a
head (NetlistId -> [Type]
netlistTypes NetlistId
dst)

    go
      :: CompiledPrimitive
      -> NetlistMonad (Expr, [Declaration])
    go :: CompiledPrimitive -> NetlistMonad (Expr, [Declaration])
go =
      \case
        P.BlackBoxHaskell Text
bbName WorkInfo
wf UsedArguments
_usedArgs 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
ty
          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 ]
              (Text
_,SrcSpan
sp) <- Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
-> NetlistMonad (Text, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
Lens' NetlistState (Text, SrcSpan)
curCompNm
              ClashException -> NetlistMonad (Expr, [Declaration])
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp String
err' Maybe String
forall a. Maybe a
Nothing)
            Right (BlackBoxMeta {Bool
[BlackBoxTemplate]
[(Int, Int)]
[((Text, Text), BlackBox)]
TemplateKind
RenderVoid
bbRenderVoid :: BlackBoxMeta -> RenderVoid
bbIncludes :: BlackBoxMeta -> [((Text, Text), BlackBox)]
bbFunctionPlurality :: BlackBoxMeta -> [(Int, Int)]
bbImports :: BlackBoxMeta -> [BlackBoxTemplate]
bbLibrary :: BlackBoxMeta -> [BlackBoxTemplate]
bbKind :: BlackBoxMeta -> TemplateKind
bbOutputReg :: BlackBoxMeta -> Bool
bbRenderVoid :: RenderVoid
bbIncludes :: [((Text, Text), BlackBox)]
bbFunctionPlurality :: [(Int, Int)]
bbImports :: [BlackBoxTemplate]
bbLibrary :: [BlackBoxTemplate]
bbKind :: TemplateKind
bbOutputReg :: Bool
..}, BlackBox
bbTemplate) ->
              -- Blackbox template generation succesful. Rerun 'go', but this time
              -- around with a 'normal' @BlackBox@
              CompiledPrimitive -> NetlistMonad (Expr, [Declaration])
go (Text
-> WorkInfo
-> RenderVoid
-> TemplateKind
-> ()
-> Bool
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [(Int, Int)]
-> [((Text, Text), BlackBox)]
-> Maybe BlackBox
-> Maybe BlackBox
-> BlackBox
-> CompiledPrimitive
forall a b c d.
Text
-> WorkInfo
-> RenderVoid
-> TemplateKind
-> c
-> Bool
-> [a]
-> [a]
-> [(Int, Int)]
-> [((Text, Text), b)]
-> Maybe b
-> Maybe b
-> b
-> Primitive a b c d
P.BlackBox
                    Text
bbName WorkInfo
wf RenderVoid
bbRenderVoid TemplateKind
bbKind () Bool
bbOutputReg [BlackBoxTemplate]
bbLibrary [BlackBoxTemplate]
bbImports
                    [(Int, Int)]
bbFunctionPlurality [((Text, Text), BlackBox)]
bbIncludes Maybe BlackBox
forall a. Maybe a
Nothing Maybe BlackBox
forall a. Maybe a
Nothing BlackBox
bbTemplate)
        p :: CompiledPrimitive
p@P.BlackBox {} ->
          case CompiledPrimitive -> TemplateKind
forall a b c d. Primitive a b c d -> TemplateKind
kind CompiledPrimitive
p of
            TemplateKind
TDecl -> do
              let tempD :: BlackBox
tempD = CompiledPrimitive -> BlackBox
forall a b c d. Primitive a b c d -> b
template CompiledPrimitive
p
                  pNm :: Text
pNm = CompiledPrimitive -> Text
forall a b c d. Primitive a b c d -> Text
name CompiledPrimitive
p
              Maybe (Id, Text, [Declaration])
resM <- HasCallStack =>
Bool -> NetlistId -> NetlistMonad (Maybe (Id, Text, [Declaration]))
Bool -> NetlistId -> NetlistMonad (Maybe (Id, Text, [Declaration]))
resBndr1 Bool
True NetlistId
dst
              case Maybe (Id, Text, [Declaration])
resM of
                Just (Id
dst',Text
dstNm,[Declaration]
dstDecl) -> do
                  (BlackBoxContext
bbCtx,[Declaration]
ctxDcls)   <- 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
tempD BlackBoxContext
bbCtx
                  let bbDecl :: Declaration
bbDecl = Text
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> BlackBoxContext
-> Declaration
N.BlackBoxD Text
pNm (CompiledPrimitive -> [BlackBoxTemplate]
forall a b c d. Primitive a b c d -> [a]
libraries CompiledPrimitive
p) (CompiledPrimitive -> [BlackBoxTemplate]
forall a b c d. Primitive a b c d -> [a]
imports CompiledPrimitive
p)
                                           (CompiledPrimitive -> [((Text, Text), BlackBox)]
forall a b c d. Primitive a b c d -> [((Text, Text), b)]
includes CompiledPrimitive
p) BlackBox
templ BlackBoxContext
bbCtx
                  (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text -> Maybe Modifier -> Expr
Identifier Text
dstNm Maybe Modifier
forall a. Maybe a
Nothing,[Declaration]
dstDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
ctxDcls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
templDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
bbDecl])

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

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

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

                    -- Otherwise don't render them
                    Maybe (Id, Text, [Declaration])
Nothing -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text -> Maybe Modifier -> Expr
Identifier Text
"__VOID_TEXPRD__" Maybe Modifier
forall a. Maybe a
Nothing,[])
                else do
                  Maybe (Id, Text, [Declaration])
resM <- HasCallStack =>
Bool -> NetlistId -> NetlistMonad (Maybe (Id, Text, [Declaration]))
Bool -> NetlistId -> NetlistMonad (Maybe (Id, Text, [Declaration]))
resBndr1 Bool
False NetlistId
dst
                  case Maybe (Id, Text, [Declaration])
resM of
                    Just (Id
dst',Text
_,[Declaration]
_) -> do
                      (BlackBoxContext
bbCtx,[Declaration]
ctxDcls)      <- 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
tempE 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, Text, [Declaration])
Nothing | RenderVoid
RenderVoid <- CompiledPrimitive -> RenderVoid
forall a b c d. Primitive a b c d -> RenderVoid
renderVoid CompiledPrimitive
p -> do
                      let dst1 :: Id
dst1 = Type -> Name Term -> Id
mkLocalId Type
ty (Text -> Int -> Name Term
forall a. Text -> Int -> Name a
mkUnsafeSystemName Text
"__VOID_TEXPRE_NOOP__" Int
0)
                      (BlackBoxContext
bbCtx,[Declaration]
ctxDcls) <- 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
tempE BlackBoxContext
bbCtx
                      let bbDecl :: Declaration
bbDecl = Text
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> BlackBoxContext
-> Declaration
N.BlackBoxD Text
pNm (CompiledPrimitive -> [BlackBoxTemplate]
forall a b c d. Primitive a b c d -> [a]
libraries CompiledPrimitive
p) (CompiledPrimitive -> [BlackBoxTemplate]
forall a b c d. Primitive a b c d -> [a]
imports CompiledPrimitive
p)
                                               (CompiledPrimitive -> [((Text, Text), BlackBox)]
forall a b c d. Primitive a b c d -> [((Text, Text), b)]
includes CompiledPrimitive
p) BlackBox
templ BlackBoxContext
bbCtx
                      (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
Noop, [Declaration]
ctxDcls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
templDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
bbDecl])

                    -- Otherwise don't render them
                    Maybe (Id, Text, [Declaration])
Nothing -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text -> Maybe Modifier -> Expr
Identifier 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 NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
                  let dcs :: [DataCon]
dcs = TyCon -> [DataCon]
tyConDataCons (TyConMap
tcm TyConMap -> TyConName -> TyCon
forall a b. (HasCallStack, Uniquable a) => UniqMap b -> a -> b
`lookupUniqMap'` TyConName
tcN)
                      dc :: DataCon
dc  = [DataCon]
dcs [DataCon] -> Int -> DataCon
forall a. [a] -> Int -> a
!! Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i
                  (Expr
exprN,[Declaration]
dcDecls) <- HasCallStack =>
[HWType]
-> NetlistId
-> DataCon
-> [Term]
-> NetlistMonad (Expr, [Declaration])
[HWType]
-> NetlistId
-> DataCon
-> [Term]
-> NetlistMonad (Expr, [Declaration])
mkDcApplication [HWType
hwTy] NetlistId
dst DataCon
dc []
                  (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
exprN,[Declaration]
dcDecls)
                [Right Type
_, Left Term
scrut] -> do
                  TyConMap
tcm     <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
                  let scrutTy :: Type
scrutTy = TyConMap -> Term -> Type
termType TyConMap
tcm Term
scrut
                  (Expr
scrutExpr,[Declaration]
scrutDecls) <-
                    HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Concurrent (Text -> Type -> NetlistId
NetlistId Text
"c$tte_rhs" Type
scrutTy) Term
scrut
                  case Expr
scrutExpr of
                    Identifier Text
id_ Maybe Modifier
Nothing -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Either Text Text -> Expr
DataTag HWType
hwTy (Text -> Either Text Text
forall a b. a -> Either a b
Left Text
id_),[Declaration]
scrutDecls)
                    Expr
_ -> do
                      HWType
scrutHTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(String
curLoc) Type
scrutTy
                      Text
tmpRhs <- IdType -> Text -> NetlistMonad Text
mkUniqueIdentifier IdType
Extended Text
"c$tte_rhs"
                      let netDeclRhs :: Declaration
netDeclRhs   = Maybe Text -> Text -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Text
tmpRhs HWType
scrutHTy
                          netAssignRhs :: Declaration
netAssignRhs = Text -> Expr -> Declaration
Assignment Text
tmpRhs Expr
scrutExpr
                      (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Either Text Text -> Expr
DataTag HWType
hwTy (Text -> Either Text Text
forall a b. a -> Either a b
Left Text
tmpRhs),[Declaration
netDeclRhs,Declaration
netAssignRhs] [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
scrutDecls)
                [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 NetlistState Int -> NetlistMonad Int
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting Int NetlistState Int
Lens' NetlistState Int
intWidth
                (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (HWType, Int) -> Literal -> Expr
N.Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
Signed Int
iw,Int
iw)) (Integer -> Literal
NumLit (Integer -> Literal) -> Integer -> Literal
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ DataCon -> Int
dcTag DataCon
dc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1),[])
              [Right Type
_,Left Term
scrut] -> do
                TyConMap
tcm      <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
                let scrutTy :: Type
scrutTy = TyConMap -> Term -> Type
termType TyConMap
tcm Term
scrut
                HWType
scrutHTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(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 (Text -> Type -> NetlistId
NetlistId Text
"c$dtt_rhs" Type
scrutTy) Term
scrut
                case Expr
scrutExpr of
                  Identifier Text
id_ Maybe Modifier
Nothing -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Either Text Text -> Expr
DataTag HWType
scrutHTy (Text -> Either Text Text
forall a b. b -> Either a b
Right Text
id_),[Declaration]
scrutDecls)
                  Expr
_ -> do
                    Text
tmpRhs  <- IdType -> Text -> NetlistMonad Text
mkUniqueIdentifier IdType
Extended Text
"c$dtt_rhs"
                    let netDeclRhs :: Declaration
netDeclRhs   = Maybe Text -> Text -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Text
tmpRhs HWType
scrutHTy
                        netAssignRhs :: Declaration
netAssignRhs = Text -> Expr -> Declaration
Assignment Text
tmpRhs Expr
scrutExpr
                    (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> Either Text Text -> Expr
DataTag HWType
scrutHTy (Text -> Either Text Text
forall a b. b -> Either a b
Right Text
tmpRhs),[Declaration
netDeclRhs,Declaration
netAssignRhs] [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
scrutDecls)
              [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, Text, [Declaration])
resM <- HasCallStack =>
Bool -> NetlistId -> NetlistMonad (Maybe (Id, Text, [Declaration]))
Bool -> NetlistId -> NetlistMonad (Maybe (Id, Text, [Declaration]))
resBndr1 Bool
True NetlistId
dst
              case Maybe (Id, Text, [Declaration])
resM of
                Just (Id
_,Text
dstNm,[Declaration]
dstDecl) -> do
                  TyConMap
tcm <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
                  [Declaration]
mealyDecls <- HasCallStack =>
Text
-> NetlistId -> TyConMap -> [Term] -> NetlistMonad [Declaration]
Text
-> NetlistId -> TyConMap -> [Term] -> NetlistMonad [Declaration]
collectMealy Text
dstNm NetlistId
dst TyConMap
tcm ([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args)
                  (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
Noop, [Declaration]
dstDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
mealyDecls)
                Maybe (Id, Text, [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#" ->
              NetlistId -> [Term] -> NetlistMonad (Expr, [Declaration])
collectBindIO NetlistId
dst ([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args)

          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== 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, Text, [Declaration])
resM <- HasCallStack =>
Bool -> NetlistId -> NetlistMonad (Maybe (Id, Text, [Declaration]))
Bool -> NetlistId -> NetlistMonad (Maybe (Id, Text, [Declaration]))
resBndr1 Bool
True NetlistId
dst
              case Maybe (Id, Text, [Declaration])
resM of
                Just (Id
_,Text
dstNm,[Declaration]
dstDecl) -> do
                  TyConMap
tcm <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
                  let (Term
fun0:Term
arg0:[Term]
_) = [Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args
                      arg1 :: Term
arg1 = TyConMap -> Term -> Term
unSimIO TyConMap
tcm Term
arg0
                      fun1 :: Term
fun1 = case Term
fun0 of
                        Lam 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
                  let assn :: [Declaration]
assn = case Expr
expr of
                               Expr
Noop -> []
                               Expr
_ -> [Text -> Expr -> Declaration
Assignment Text
dstNm Expr
expr]
                  (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text -> Maybe Modifier -> Expr
Identifier Text
dstNm Maybe Modifier
forall a. Maybe a
Nothing, [Declaration]
dstDecl [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
bindDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
assn)
                Maybe (Id, Text, [Declaration])
Nothing -> do
                  let (Term
_:Term
arg0:[Term]
_) = [Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args
                  (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)

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

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

          | Bool
otherwise ->
              (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Text
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> BlackBoxContext
-> Bool
-> Expr
BlackBoxE 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], [Text], [Declaration]))
resBndr Bool
mkDec NetlistId
dst' = do
      HWType
resHwTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(String
curLoc) Type
ty
      if HWType -> Bool
isVoid HWType
resHwTy then
        Maybe ([Id], [Text], [Declaration])
-> NetlistMonad (Maybe ([Id], [Text], [Declaration]))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe ([Id], [Text], [Declaration])
forall a. Maybe a
Nothing
      else
        case NetlistId
dst' of
          NetlistId Text
dstL Type
_ -> 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 Text
dstL Int
0
                  id_ :: Id
id_ = Type -> Name Term -> Id
mkLocalId Type
ty Name Term
forall a. Name a
nm'
              Maybe ([Id], [Text], [Declaration])
-> NetlistMonad (Maybe ([Id], [Text], [Declaration]))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (([Id], [Text], [Declaration])
-> Maybe ([Id], [Text], [Declaration])
forall a. a -> Maybe a
Just ([Id
id_],[Text
dstL],[]))
            Bool
True -> do
              Text
nm1 <- IdType -> Text -> Text -> NetlistMonad Text
extendIdentifier IdType
Extended Text
dstL Text
"_res"
              Text
nm2 <- IdType -> Text -> NetlistMonad Text
mkUniqueIdentifier IdType
Extended Text
nm1
              -- TODO: check that it's okay to use `mkUnsafeInternalName`
              let nm3 :: Name a
nm3 = Text -> Int -> Name a
forall a. Text -> Int -> Name a
mkUnsafeSystemName Text
nm2 Int
0
                  id_ :: Id
id_ = Type -> Name Term -> Id
mkLocalId Type
ty Name Term
forall a. Name a
nm3
              Maybe Declaration
idDeclM <- LetBinding -> NetlistMonad (Maybe Declaration)
mkNetDecl (Id
id_,Term -> [Either Term Type] -> Term
mkApps (PrimInfo -> Term
Prim PrimInfo
pInfo) [Either Term Type]
args)
              case Maybe Declaration
idDeclM of
                Maybe Declaration
Nothing     -> Maybe ([Id], [Text], [Declaration])
-> NetlistMonad (Maybe ([Id], [Text], [Declaration]))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe ([Id], [Text], [Declaration])
forall a. Maybe a
Nothing
                Just Declaration
idDecl -> Maybe ([Id], [Text], [Declaration])
-> NetlistMonad (Maybe ([Id], [Text], [Declaration]))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (([Id], [Text], [Declaration])
-> Maybe ([Id], [Text], [Declaration])
forall a. a -> Maybe a
Just ([Id
id_],[Text
nm2],[Declaration
idDecl]))
          CoreId Id
dstR -> Maybe ([Id], [Text], [Declaration])
-> NetlistMonad (Maybe ([Id], [Text], [Declaration]))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (([Id], [Text], [Declaration])
-> Maybe ([Id], [Text], [Declaration])
forall a. a -> Maybe a
Just ([Id
dstR],[Name Term -> Text
forall a. Name a -> Text
nameOcc (Name Term -> Text) -> (Id -> Name Term) -> Id -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name Term
forall a. Var a -> Name a
varName (Id -> Text) -> Id -> Text
forall a b. (a -> b) -> a -> b
$ Id
dstR],[]))
          MultiId [Id]
ids -> Maybe ([Id], [Text], [Declaration])
-> NetlistMonad (Maybe ([Id], [Text], [Declaration]))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (([Id], [Text], [Declaration])
-> Maybe ([Id], [Text], [Declaration])
forall a. a -> Maybe a
Just ([Id]
ids,(Id -> Text) -> [Id] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Name Term -> Text
forall a. Name a -> Text
nameOcc (Name Term -> Text) -> (Id -> Name Term) -> Id -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name Term
forall a. Var a -> Name a
varName) [Id]
ids,[]))

    -- Like resBndr, but fails on MultiId
    resBndr1
      :: HasCallStack
      => Bool
      -> NetlistId
      -> NetlistMonad (Maybe (Id,Identifier,[Declaration]))
    resBndr1 :: Bool -> NetlistId -> NetlistMonad (Maybe (Id, Text, [Declaration]))
resBndr1 Bool
mkDec NetlistId
dst' = Bool
-> NetlistId -> NetlistMonad (Maybe ([Id], [Text], [Declaration]))
resBndr Bool
mkDec NetlistId
dst' NetlistMonad (Maybe ([Id], [Text], [Declaration]))
-> (Maybe ([Id], [Text], [Declaration])
    -> NetlistMonad (Maybe (Id, Text, [Declaration])))
-> NetlistMonad (Maybe (Id, Text, [Declaration]))
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe ([Id], [Text], [Declaration])
Nothing -> Maybe (Id, Text, [Declaration])
-> NetlistMonad (Maybe (Id, Text, [Declaration]))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe (Id, Text, [Declaration])
forall a. Maybe a
Nothing
      Just ([Id
id_],[Text
nm_],[Declaration]
decls) -> Maybe (Id, Text, [Declaration])
-> NetlistMonad (Maybe (Id, Text, [Declaration]))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Id, Text, [Declaration]) -> Maybe (Id, Text, [Declaration])
forall a. a -> Maybe a
Just (Id
id_,Text
nm_,[Declaration]
decls))
      Maybe ([Id], [Text], [Declaration])
_ -> String -> NetlistMonad (Maybe (Id, Text, [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 :: Text
-> NetlistId -> TyConMap -> [Term] -> NetlistMonad [Declaration]
collectMealy Text
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 HasCallStack => Term -> Term
Term -> Term
inverseTopSortLetBindings Term
res0 of
        Letrec [LetBinding]
bsN (C.Var Id
resN) -> ([LetBinding]
bsN,Id
resN)
        Letrec [LetBinding]
bsN 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 -> Name Term -> Id
mkLocalId (TyConMap -> Term -> Type
termType TyConMap
tcm Term
e)
                                      (Text -> Int -> Name Term
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 -> Name Term -> Id
mkLocalId (TyConMap -> Term -> Type
termType TyConMap
tcm Term
e)
                                      (Text -> Int -> Name Term
forall a. Text -> Int -> Name a
mkUnsafeSystemName Text
"mealyres" Int
0))
          in  ([(Id
u,Term
e)], Id
u)
      -- Drop the 'State# World' argument
      args1 :: [Id]
args1 = [Id] -> [Id]
forall a. [a] -> [a]
init [Id]
args0
      -- Take into account that the state argument is split over multiple
      -- binders because it contained types that are not allowed to occur in
      -- a HDL aggregate type
      mealyInitLength :: Int
mealyInitLength = [Type] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length (TyConMap -> [Type] -> [Type]
splitShouldSplit TyConMap
tcm [TyConMap -> Term -> Type
termType TyConMap
tcm Term
mealyInit])
      ([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
  ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
 [Declaration], [LetBinding], Maybe Id)
normE <- HasCallStack =>
InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
      [Declaration], [LetBinding], Maybe Id)
InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
      [Declaration], [LetBinding], Maybe Id)
mkUniqueNormalized InScopeSet
is0
             (Maybe TopEntity -> Maybe (Maybe TopEntity)
forall a. a -> Maybe a
Just (TopEntity -> Maybe TopEntity
forall a. a -> Maybe a
Just (String -> [PortName] -> PortName -> TopEntity
Synthesize String
"" [] (String -> PortName
PortName String
""))))
             ([],(Id -> LetBinding) -> [Id] -> [LetBinding]
forall a b. (a -> b) -> [a] -> [b]
map (,Term
mealyInit) [Id]
sArgs [LetBinding] -> [LetBinding] -> [LetBinding]
forall a. [a] -> [a] -> [a]
++ (Id -> LetBinding) -> [Id] -> [LetBinding]
forall a b. (a -> b) -> [a] -> [b]
map (,Term
mealyIn) [Id]
iArgs [LetBinding] -> [LetBinding] -> [LetBinding]
forall a. [a] -> [a] -> [a]
++ [LetBinding]
bs,Id
res)
  case ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
 [Declaration], [LetBinding], Maybe Id)
normE of
    -- We're not expecting any input or output wrappers
    ([Bool]
_,[],[],[(Text, 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 <- ([Maybe Declaration] -> [Declaration])
-> NetlistMonad [Maybe Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe Declaration] -> [Declaration]
forall a. [Maybe a] -> [a]
catMaybes ((LetBinding -> NetlistMonad (Maybe Declaration))
-> [LetBinding] -> NetlistMonad [Maybe Declaration]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LetBinding -> NetlistMonad (Maybe Declaration)
mkNetDecl ([LetBinding]
sBinders [LetBinding] -> [LetBinding] -> [LetBinding]
forall a. [a] -> [a] -> [a]
++ [LetBinding]
bindersN))
      -- The second set is assigned using concurrent assignment, so don't need
      -- to be 'reg'
      [Declaration]
netDeclsInp <- ([Maybe Declaration] -> [Declaration])
-> NetlistMonad [Maybe Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe Declaration] -> [Declaration]
forall a. [Maybe a] -> [a]
catMaybes ((LetBinding -> NetlistMonad (Maybe Declaration))
-> [LetBinding] -> NetlistMonad [Maybe Declaration]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LetBinding -> NetlistMonad (Maybe Declaration)
mkNetDecl [LetBinding]
iBinders)

      -- If the 'mealyFun' was not a let-expression with a variable reference
      -- as a body then we used the LHS of the entire 'mealyIO' expression as
      -- a new let-binding; otherwise 'mkUniqueNormalized' would not work.
      --
      -- However, 'mkUniqueNormalized' made a new unique name for that LHS,
      -- which is not what we want. We want to assign the last expression to the
      -- LHS of 'mealyIO'.
      let bindersE :: [LetBinding]
bindersE = case Term
res0 of
                        Letrec [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
Concurrent NetlistId
dst (Id -> Term
C.Var Id
result)
      let resAssn :: [Declaration]
resAssn = case Expr
resExpr of
            Expr
Noop -> []
            Expr
_ -> [[Seq] -> Declaration
Seq [[Seq] -> Seq
AlwaysComb [Declaration -> Seq
SeqDecl (Text -> Expr -> Declaration
Assignment Text
dstNm Expr
resExpr)]]]

      -- Create the declarations for the "initial state" block
      let sDst :: NetlistId
sDst = case [LetBinding]
sBinders of
                   [(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
      let initAssign :: [Declaration]
initAssign = case Expr
exprInit of
            Identifier Text
_ Maybe Modifier
Nothing -> []
            Expr
Noop -> []
            Expr
_ -> [Text -> Expr -> Declaration
Assignment (Id -> Text
id2identifier (LetBinding -> Id
forall a b. (a, b) -> a
fst ([LetBinding] -> LetBinding
forall a. [a] -> a
head [LetBinding]
sBinders))) Expr
exprInit]

      -- Create the declarations that corresponding to the input
      let iDst :: NetlistId
iDst = case [LetBinding]
iBinders of
                   [(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

      -- 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 -> Declaration) -> [Declaration] -> [Declaration]
forall a b. (a -> b) -> [a] -> [b]
map Declaration -> Declaration
toReg ([Declaration]
netDeclsSeq [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
netDeclsSeqMisc [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
netDeclsInit)

      -- We run mealy block in the opposite clock edge of the the ambient system
      -- because we're basically clocked logic; so we need to have our outputs
      -- ready before the ambient system starts sampling them. The clockGen code
      -- ensures that the "opposite" edge always comes first.
      FilteredHWType
kdTy <- String -> Type -> NetlistMonad FilteredHWType
unsafeCoreTypeToHWTypeM $(String
curLoc) (TyConMap -> Term -> Type
termType 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 (Text -> Type -> NetlistId
NetlistId Text
"__MEALY_CLK__" (TyConMap -> Term -> Type
termType TyConMap
tcm Term
clk)) Term
clk

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

      -- Collate everything
      [Declaration] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Declaration]
clkDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
netDeclsSeq1 [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
netDeclsInp1 [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++
                [ Text -> Expr -> Declaration
Assignment (Id -> Text
id2identifier (LetBinding -> Id
forall a b. (a, b) -> a
fst ([LetBinding] -> LetBinding
forall a. [a] -> a
head [LetBinding]
iBinders))) Expr
exprArg
                , [Seq] -> Declaration
Seq [[Seq] -> Seq
Initial ((Declaration -> Seq) -> [Declaration] -> [Seq]
forall a b. (a -> b) -> [a] -> [b]
map Declaration -> Seq
SeqDecl ([Declaration]
initDeclsOther [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
initAssign))]
                , [Seq] -> Declaration
Seq [ActiveEdge -> Expr -> [Seq] -> Seq
AlwaysClocked ActiveEdge
edge Expr
clkExpr ((Declaration -> Seq) -> [Declaration] -> [Seq]
forall a b. (a -> b) -> [a] -> [b]
map Declaration -> Seq
SeqDecl [Declaration]
seqDeclsOther)]
                ] [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
resAssn)
    ([Bool], [(Text, HWType)], [Declaration], [(Text, 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

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

collectMealy Text
_ 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])
collectBindIO :: NetlistId -> [Term] -> NetlistMonad (Expr, [Declaration])
collectBindIO NetlistId
dst (Term
m:Lam Id
x q :: Term
q@(Lam Id
_ Term
e):[Term]
_) = do
  TyConMap
tcm <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
  [Declaration]
ds0 <- TyConMap -> NetlistMonad [Declaration]
collectAction TyConMap
tcm
  case TyConMap -> Term -> Either String ([Id], [LetBinding], Id)
splitNormalized TyConMap
tcm Term
q of
    Right ([Id]
args,[LetBinding]
bs0,Id
res) -> do
      let Letrec [LetBinding]
bs Term
_ = HasCallStack => Term -> Term
Term -> Term
inverseTopSortLetBindings ([LetBinding] -> Term -> Term
Letrec [LetBinding]
bs0 (Id -> Term
C.Var Id
res))
      let is0 :: InScopeSet
is0 = VarSet -> InScopeSet
mkInScopeSet (Getting VarSet Term Id -> (Id -> VarSet) -> Term -> VarSet
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting VarSet Term Id
Fold Term Id
freeIds Id -> VarSet
forall a. Var a -> VarSet
unitVarSet Term
q)
      ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
 [Declaration], [LetBinding], Maybe Id)
normE <- HasCallStack =>
InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
      [Declaration], [LetBinding], Maybe Id)
InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
      [Declaration], [LetBinding], Maybe Id)
mkUniqueNormalized InScopeSet
is0 Maybe (Maybe TopEntity)
forall a. Maybe a
Nothing ([Id]
args,[LetBinding]
bs,Id
res)
      case ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
 [Declaration], [LetBinding], Maybe Id)
normE of
        ([Bool]
_,[(Text, HWType)]
_,[],[(Text, HWType)]
_,[],[LetBinding]
binders,Just Id
result) -> do
          [Declaration]
ds1 <- [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[Declaration]] -> [Declaration])
-> NetlistMonad [[Declaration]] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (LetBinding -> NetlistMonad [Declaration])
-> [LetBinding] -> NetlistMonad [[Declaration]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Id -> Term -> NetlistMonad [Declaration])
-> LetBinding -> NetlistMonad [Declaration]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (HasCallStack =>
DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
mkDeclarations' DeclarationType
Sequential)) [LetBinding]
binders
          [Declaration]
netDecls <- ([Maybe Declaration] -> [Declaration])
-> NetlistMonad [Maybe Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe Declaration] -> [Declaration]
forall a. [Maybe a] -> [a]
catMaybes ((LetBinding -> NetlistMonad (Maybe Declaration))
-> [LetBinding] -> NetlistMonad [Maybe Declaration]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LetBinding -> NetlistMonad (Maybe Declaration)
mkNetDecl [LetBinding]
binders)
          let assn :: Declaration
assn = Text -> Expr -> Declaration
Assignment ((Text -> Text) -> (Id -> Text) -> NetlistId -> Text
forall r.
HasCallStack =>
(Text -> r) -> (Id -> r) -> NetlistId -> r
netlistId1 Text -> Text
forall a. a -> a
id Id -> Text
id2identifier NetlistId
dst)
                                (Text -> Maybe Modifier -> Expr
Identifier (Id -> Text
id2identifier Id
result) Maybe Modifier
forall a. Maybe a
Nothing)
          (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
Noop, ([Declaration]
netDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
ds0 [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
ds1 [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
assn]))
        ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
 [Declaration], [LetBinding], Maybe Id)
_ -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error String
"internal error"
    Either String ([Id], [LetBinding], Id)
_ -> case 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
_ -> 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
e
        (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Expr
expr, [Declaration]
ds0 [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
ds1)
 where
  collectAction :: TyConMap -> NetlistMonad [Declaration]
collectAction 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 Letrec [LetBinding]
bs Term
_ = HasCallStack => Term -> Term
Term -> Term
inverseTopSortLetBindings ([LetBinding] -> Term -> Term
Letrec [LetBinding]
bs0 (Id -> Term
C.Var Id
res))
      let is0 :: InScopeSet
is0 = VarSet -> InScopeSet
mkInScopeSet (Getting VarSet Term Id -> (Id -> VarSet) -> Term -> VarSet
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting VarSet Term Id
Fold Term Id
freeIds Id -> VarSet
forall a. Var a -> VarSet
unitVarSet Term
m)
      ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
 [Declaration], [LetBinding], Maybe Id)
normE <- HasCallStack =>
InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
      [Declaration], [LetBinding], Maybe Id)
InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
      [Declaration], [LetBinding], Maybe Id)
mkUniqueNormalized InScopeSet
is0 Maybe (Maybe TopEntity)
forall a. Maybe a
Nothing ([Id]
args,(Id
x,Term
m)LetBinding -> [LetBinding] -> [LetBinding]
forall a. a -> [a] -> [a]
:[LetBinding]
bs,Id
res)
      case ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
 [Declaration], [LetBinding], Maybe Id)
normE of
        ([Bool]
_,[(Text, HWType)]
_,[],[(Text, HWType)]
_,[],[LetBinding]
binders,Just Id
result) -> do
          let binders1 :: [LetBinding]
binders1 = [LetBinding] -> [LetBinding]
forall a. [a] -> [a]
tail [LetBinding]
binders [LetBinding] -> [LetBinding] -> [LetBinding]
forall a. [a] -> [a] -> [a]
++ [(LetBinding -> Id
forall a b. (a, b) -> a
fst ([LetBinding] -> LetBinding
forall a. [a] -> a
head [LetBinding]
binders), Id -> Term
C.Var Id
result)]
          [Declaration]
ds1 <- [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[Declaration]] -> [Declaration])
-> NetlistMonad [[Declaration]] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (LetBinding -> NetlistMonad [Declaration])
-> [LetBinding] -> NetlistMonad [[Declaration]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Id -> Term -> NetlistMonad [Declaration])
-> LetBinding -> NetlistMonad [Declaration]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (HasCallStack =>
DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
mkDeclarations' DeclarationType
Sequential)) [LetBinding]
binders1
          [Declaration]
netDecls <- ([Maybe Declaration] -> [Declaration])
-> NetlistMonad [Maybe Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe Declaration] -> [Declaration]
forall a. [Maybe a] -> [a]
catMaybes ((LetBinding -> NetlistMonad (Maybe Declaration))
-> [LetBinding] -> NetlistMonad [Maybe Declaration]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LetBinding -> NetlistMonad (Maybe Declaration)
mkNetDecl [LetBinding]
binders)
          [Declaration] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Declaration]
netDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
ds1)
        ([Bool], [(Text, HWType)], [Declaration], [(Text, HWType)],
 [Declaration], [LetBinding], Maybe Id)
_ -> String -> NetlistMonad [Declaration]
forall a. HasCallStack => String -> a
error String
"internal error"
    Either String ([Id], [LetBinding], Id)
_ -> do
      [Declaration]
netDecls <- ([Maybe Declaration] -> [Declaration])
-> NetlistMonad [Maybe Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe Declaration] -> [Declaration]
forall a. [Maybe a] -> [a]
catMaybes ((LetBinding -> NetlistMonad (Maybe Declaration))
-> [LetBinding] -> NetlistMonad [Maybe Declaration]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LetBinding -> NetlistMonad (Maybe Declaration)
mkNetDecl [(Id
x,Term
m)])
      [Declaration]
ds1 <- HasCallStack =>
DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
DeclarationType -> Id -> Term -> NetlistMonad [Declaration]
mkDeclarations' DeclarationType
Sequential Id
x Term
m
      [Declaration] -> NetlistMonad [Declaration]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Declaration]
netDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
ds1)

collectBindIO 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
_),([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts -> (Term
fun0:Term
arg0:[Term]
_))) -> do
    TyConMap
tcm <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
    let argN :: [Either Term b]
argN = (Term -> Either Term b) -> [Term] -> [Either Term b]
forall a b. (a -> b) -> [a] -> [b]
map (Term -> Either Term b
forall a b. a -> Either a b
Left (Term -> Either Term b) -> (Term -> Term) -> Term -> Either Term b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyConMap -> Term -> Term
unSimIO TyConMap
tcm) (Term
arg0Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
:Term
arg1Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
:[Term]
rest)
    HasCallStack =>
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> DeclarationType
-> NetlistId
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False DeclarationType
Sequential NetlistId
dst (Term -> [Either Term Type] -> Term
mkApps Term
fun0 [Either Term Type]
forall b. [Either Term b]
argN)
  (Prim (PrimInfo Text
"Clash.Explicit.SimIO.apSimIO#" Type
_ WorkInfo
_),([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
termType 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 -> PrimInfo
PrimInfo Text
"Clash.Explicit.SimIO.unSimIO#" (Type -> Type -> Type
mkFunTy Type
argTy Type
tcArg) WorkInfo
WorkNever))
                 [Term -> Either Term Type
forall a b. a -> Either a b
Left Term
arg]
        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
  => Id
  -- ^ Identifier binding the encompassing primitive/blackbox application
  -> Term
  -- ^ The function argument term
  -> NetlistMonad
      ((Either BlackBox (Identifier,[Declaration])
       ,WireOrReg
       ,[BlackBoxTemplate]
       ,[BlackBoxTemplate]
       ,[((TextS.Text,TextS.Text),BlackBox)]
       ,BlackBoxContext)
      ,[Declaration])
mkFunInput :: Id
-> Term
-> NetlistMonad
     ((Either BlackBox (Text, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext),
      [Declaration])
mkFunInput 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 (Text, [Declaration]), WireOrReg,
           [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
           BlackBoxContext),
          [Declaration]))
-> NetlistMonad
     ((Either BlackBox (Text, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext),
      [Declaration])
forall a.
[TickInfo] -> ([Declaration] -> NetlistMonad a) -> NetlistMonad a
withTicks [TickInfo]
ticks (([Declaration]
  -> NetlistMonad
       ((Either BlackBox (Text, [Declaration]), WireOrReg,
         [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
         BlackBoxContext),
        [Declaration]))
 -> NetlistMonad
      ((Either BlackBox (Text, [Declaration]), WireOrReg,
        [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
        BlackBoxContext),
       [Declaration]))
-> ([Declaration]
    -> NetlistMonad
         ((Either BlackBox (Text, [Declaration]), WireOrReg,
           [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
           BlackBoxContext),
          [Declaration]))
-> NetlistMonad
     ((Either BlackBox (Text, [Declaration]), WireOrReg,
       [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
       BlackBoxContext),
      [Declaration])
forall a b. (a -> b) -> a -> b
$ \[Declaration]
tickDecls -> do
  TyConMap
tcm <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
  -- TODO: Rewrite this function to use blackbox functions. Right now it
  -- TODO: generates strings that are later parsed/interpreted again. Silly!
  Either
  (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Text, [Declaration]), WireOrReg)
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)]
Maybe BlackBox
()
Text
BlackBox
WorkInfo
TemplateKind
RenderVoid
resultInit :: forall a b c d. Primitive a b c d -> Maybe b
resultName :: forall a b c d. Primitive a b c d -> Maybe b
functionPlurality :: forall a b c d. Primitive a b c d -> [(Int, Int)]
outputReg :: forall a b c d. Primitive a b c d -> Bool
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
resultInit :: Maybe BlackBox
resultName :: Maybe BlackBox
includes :: [((Text, Text), BlackBox)]
functionPlurality :: [(Int, Int)]
imports :: [BlackBoxTemplate]
libraries :: [BlackBoxTemplate]
outputReg :: Bool
warning :: ()
kind :: TemplateKind
renderVoid :: RenderVoid
workInfo :: WorkInfo
name :: Text
renderVoid :: forall a b c d. Primitive a b c d -> RenderVoid
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]
name :: forall a b c d. Primitive a b c d -> Text
template :: forall a b c d. Primitive a b c d -> b
kind :: forall a b c d. Primitive a b c d -> TemplateKind
..} ->
                  Either
  (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Text, [Declaration]), WireOrReg)
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
 [((Text, Text), BlackBox)], Text, BlackBox)
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
forall a b. a -> Either a b
Left (TemplateKind
kind,Bool
outputReg,[BlackBoxTemplate]
libraries,[BlackBoxTemplate]
imports,[((Text, Text), BlackBox)]
includes,PrimInfo -> Text
primName PrimInfo
p,BlackBox
template))
                P.Primitive Text
pn WorkInfo
_ Text
pt ->
                  String
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad
      (Either
         (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Text, [Declaration]), WireOrReg)))
-> String
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall a b. (a -> b) -> a -> b
$ $(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 Text
pName WorkInfo
_workInfo UsedArguments
_usedArgs BlackBoxFunctionName
fName (Int
_, BlackBoxFunction
func) -> do
                  -- Determine result type of this blackbox. If it's not a
                  -- function, simply use its term type.
                  let
                    resTy0 :: Type
resTy0 = TyConMap -> Term -> Type
termType TyConMap
tcm Term
e
                    resTy1 :: Type
resTy1 =
                      case TyConMap -> Type -> Maybe (Type, Type)
splitFunTy TyConMap
tcm Type
resTy0 of
                        Just (Type
_, Type
t) -> Type
t
                        Maybe (Type, Type)
Nothing -> Type
resTy0

                  Either String (BlackBoxMeta, BlackBox)
bbhRes <- BlackBoxFunction
func Bool
True Text
pName [Either Term Type]
args Type
resTy1
                  case Either String (BlackBoxMeta, BlackBox)
bbhRes of
                    Left String
err ->
                      String
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad
      (Either
         (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Text, [Declaration]), WireOrReg)))
-> String
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall a b. (a -> b) -> a -> b
$ $(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{Bool
[BlackBoxTemplate]
[(Int, Int)]
[((Text, Text), BlackBox)]
TemplateKind
RenderVoid
bbRenderVoid :: RenderVoid
bbIncludes :: [((Text, Text), BlackBox)]
bbFunctionPlurality :: [(Int, Int)]
bbImports :: [BlackBoxTemplate]
bbLibrary :: [BlackBoxTemplate]
bbKind :: TemplateKind
bbOutputReg :: Bool
bbRenderVoid :: BlackBoxMeta -> RenderVoid
bbIncludes :: BlackBoxMeta -> [((Text, Text), BlackBox)]
bbFunctionPlurality :: BlackBoxMeta -> [(Int, Int)]
bbImports :: BlackBoxMeta -> [BlackBoxTemplate]
bbLibrary :: BlackBoxMeta -> [BlackBoxTemplate]
bbKind :: BlackBoxMeta -> TemplateKind
bbOutputReg :: BlackBoxMeta -> Bool
..}, BlackBox
template) ->
                      Either
  (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Text, [Declaration]), WireOrReg)
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either
   (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
    [((Text, Text), BlackBox)], Text, BlackBox)
   ((Text, [Declaration]), WireOrReg)
 -> NetlistMonad
      (Either
         (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Text, [Declaration]), WireOrReg)))
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall a b. (a -> b) -> a -> b
$
                        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
 [((Text, Text), BlackBox)], Text, BlackBox)
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
forall a b. a -> Either a b
Left ( TemplateKind
bbKind, Bool
bbOutputReg, [BlackBoxTemplate]
bbLibrary, [BlackBoxTemplate]
bbImports
                             , [((Text, Text), BlackBox)]
bbIncludes, Text
pName, BlackBox
template)
            Data DataCon
dc -> do
              let eTy :: Type
eTy = TyConMap -> Term -> Type
termType 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]] -> [Bool]
forall a. [a] -> a
head [[Bool]]
areVoids))
                  let arg :: Text
arg = [Text] -> Text
TextS.concat [Text
"~ARG[", Int -> Text
forall a. TextShow a => a -> Text
showt Int
nonVoidArgI, Text
"]"]
                  let assign :: Declaration
assign = Text -> Expr -> Declaration
Assignment Text
"~RESULT" (Text -> Maybe Modifier -> Expr
Identifier Text
arg Maybe Modifier
forall a. Maybe a
Nothing)
                  Either
  (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Text, [Declaration]), WireOrReg)
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Text, [Declaration]), WireOrReg)
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
forall a b. b -> Either a b
Right ((Text
"", [Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
assign]), WireOrReg
Wire))

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

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

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

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

                -- Sum types OR a Sum type after filtering empty types:
                Just (resHTy :: HWType
resHTy@(Sum 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 = Text -> Expr -> Declaration
Assignment Text
"~RESULT" Expr
dcApp
                  Either
  (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Text, [Declaration]), WireOrReg)
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Text, [Declaration]), WireOrReg)
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
forall a b. b -> Either a b
Right ((Text
"",[Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
dcAss]),WireOrReg
Wire))

                -- Same as Sum, but with user defined bit level representation
                Just (resHTy :: HWType
resHTy@(CustomSum {}), [[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 = Text -> Expr -> Declaration
Assignment Text
"~RESULT" Expr
dcApp
                  Either
  (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Text, [Declaration]), WireOrReg)
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Text, [Declaration]), WireOrReg)
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
forall a b. b -> Either a b
Right ((Text
"",[Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
dcAss]),WireOrReg
Wire))

                Just (Void {}, [[Bool]]
_areVoids) ->
                  Either
  (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
   [((Text, Text), BlackBox)], Text, BlackBox)
  ((Text, [Declaration]), WireOrReg)
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (String
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
forall a. HasCallStack => String -> a
error (String
 -> Either
      (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
       [((Text, Text), BlackBox)], Text, BlackBox)
      ((Text, [Declaration]), WireOrReg))
-> String
-> Either
     (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
      [((Text, Text), BlackBox)], Text, BlackBox)
     ((Text, [Declaration]), WireOrReg)
forall a b. (a -> b) -> a -> b
$ $(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, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad
      (Either
         (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Text, [Declaration]), WireOrReg)))
-> String
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall a b. (a -> b) -> a -> b
$ $(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, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad
      (Either
         (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
          [((Text, Text), BlackBox)], Text, BlackBox)
         ((Text, [Declaration]), WireOrReg)))
-> String
-> NetlistMonad
     (Either
        (TemplateKind, Bool, [BlackBoxTemplate], [BlackBoxTemplate],
         [((Text, Text), BlackBox)], Text, BlackBox)
        ((Text, [Declaration]), WireOrReg))
forall a b. (a -> b) -> a -> b
$ $(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
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
fun BindingMap
normalized of
                    Just Binding
_ -> do
                      ([Bool]
wereVoids,SrcSpan
_,HashMap Text Word
_,N.Component Text
compName [(Text, HWType)]
compInps [(WireOrReg
_,(Text, HWType)
compOutp,Maybe Expr
_)] [Declaration]
_) <-
                        NetlistMonad ([Bool], SrcSpan, HashMap Text Word, Component)
-> NetlistMonad ([Bool], SrcSpan, HashMap Text Word, Component)
forall a. NetlistMonad a -> NetlistMonad a
preserveVarEnv (NetlistMonad ([Bool], SrcSpan, HashMap Text Word, Component)
 -> NetlistMonad ([Bool], SrcSpan, HashMap Text Word, Component))
-> NetlistMonad ([Bool], SrcSpan, HashMap Text Word, Component)
-> NetlistMonad ([Bool], SrcSpan, HashMap Text Word, Component)
forall a b. (a -> b) -> a -> b
$ HasCallStack =>
Id -> NetlistMonad ([Bool], SrcSpan, HashMap Text Word, Component)
Id -> NetlistMonad ([Bool], SrcSpan, HashMap Text Word, Component)
genComponent Id
fun

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

    go :: InScopeSet
-> Int
-> Term
-> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
go 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 ((Name Term -> Name Term) -> Id -> Id
forall a. (Name a -> Name a) -> Var a -> Var a
modifyVarName (\Name Term
v -> Name Term
v {nameOcc :: Text
nameOcc = Text
nm}) Id
id_)
          subst :: Subst
subst = Subst -> Id -> Term -> Subst
extendIdSubst (InScopeSet -> Subst
mkSubst InScopeSet
is0) Id
id_ (Id -> Term
C.Var Id
v')
          e'' :: Term
e''   = HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm 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 ((Text, [Declaration]), WireOrReg))
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 = Text -> Expr -> Declaration
Assignment Text
"~RESULT" (Text -> Maybe Modifier -> Expr
Identifier (Name Term -> Text
forall a. Name a -> Text
nameOcc (Id -> Name Term
forall a. Var a -> Name a
varName Id
v)) Maybe Modifier
forall a. Maybe a
Nothing)
      Either a ((Text, [Declaration]), WireOrReg)
-> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Text, [Declaration]), WireOrReg)
-> Either a ((Text, [Declaration]), WireOrReg)
forall a b. b -> Either a b
Right ((Text
"",[Declaration
assn]),WireOrReg
Wire))

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

    go InScopeSet
_ Int
_ (Case Term
scrut Type
ty alts :: [Alt]
alts@(Alt
_:Alt
_:[Alt]
_)) = do
      -- TODO: check that it's okay to use `mkUnsafeSystemName`
      let resId' :: Var a
resId'  = Id
resId {varName :: Name a
varName = Text -> Int -> Name a
forall a. Text -> Int -> Name a
mkUnsafeSystemName Text
"~RESULT" Int
0}
      [Declaration]
selectionDecls <- DeclarationType
-> NetlistId
-> Term
-> Type
-> [Alt]
-> [Declaration]
-> NetlistMonad [Declaration]
mkSelection DeclarationType
Concurrent (Id -> NetlistId
CoreId Id
forall a. Var a
resId') Term
scrut Type
ty [Alt]
alts []
      Text
nm <- IdType -> Text -> NetlistMonad Text
mkUniqueIdentifier IdType
Basic Text
"selection"
      TyConMap
tcm <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
      let scrutTy :: Type
scrutTy = TyConMap -> Term -> Type
termType TyConMap
tcm Term
scrut
      HWType
scrutHTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(String
curLoc) Type
scrutTy
      Bool
ite <- Getting Bool NetlistState Bool -> NetlistMonad Bool
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting Bool NetlistState Bool
Lens' NetlistState Bool
backEndITE
      let wr :: WireOrReg
wr = case HWType -> [Alt] -> Maybe (Term, Term)
iteAlts HWType
scrutHTy [Alt]
alts of
                 Just (Term, Term)
_ | Bool
ite -> WireOrReg
Wire
                 Maybe (Term, Term)
_ -> WireOrReg
Reg
      Either a ((Text, [Declaration]), WireOrReg)
-> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Text, [Declaration]), WireOrReg)
-> Either a ((Text, [Declaration]), WireOrReg)
forall a b. b -> Either a b
Right ((Text
nm,[Declaration]
selectionDecls),WireOrReg
wr))

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

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

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

    go InScopeSet
_ Int
_ e' :: Term
e'@(Case Term
_ Type
_ []) =
      String
-> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg)))
-> String
-> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
forall a b. (a -> b) -> a -> b
$ $(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 ((Text, [Declaration]), WireOrReg))
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg)))
-> String
-> NetlistMonad (Either a ((Text, [Declaration]), WireOrReg))
forall a b. (a -> b) -> a -> b
$ $(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'