{-|
  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 TupleSections     #-}
{-# LANGUAGE ViewPatterns      #-}

module Clash.Netlist.BlackBox where

import           Control.Exception             (throw)
import           Control.Lens                  ((<<%=),(%=))
import qualified Control.Lens                  as Lens
import           Control.Monad                 (when)
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)
import           Data.Maybe                    (catMaybes, fromJust)
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 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))
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
  (Term (..), collectArgs, collectArgsTicks)
import           Clash.Core.Type               as C (Type (..), ConstTy (..),
                                                splitFunTys, splitFunTy)
import           Clash.Core.TyCon              as C (tyConDataCons)
import           Clash.Core.Util               (isFun, termType)
import           Clash.Core.Var                as V
  (Id, Var (..), mkLocalId, modifyVarName)
import           Clash.Core.VarEnv
  (extendInScopeSet, mkInScopeSet, lookupVarEnv, uniqAway, unitVarSet)
import {-# SOURCE #-} Clash.Netlist
  (genComponent, mkDcApplication, mkDeclarations, mkExpr, mkNetDecl,
   mkProjection, mkSelection, mkFunApp)
import qualified Clash.Backend                 as Backend
import           Clash.Driver.Types
  (opt_primWarn, opt_color, ClashOpts)
import           Clash.Netlist.BlackBox.Types  as B
import           Clash.Netlist.BlackBox.Util   as B
import           Clash.Netlist.Id              (IdType (..))
import           Clash.Netlist.Types           as N
import           Clash.Netlist.Util            as N
import           Clash.Primitives.Types        as P
import           Clash.Unique                  (lookupUniqMap')
import           Clash.Util

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

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

-- | Generate the context for a BlackBox instantiation.
mkBlackBoxContext
  :: TextS.Text
  -- ^ Blackbox function name
  -> Id
  -- ^ Identifier binding the primitive/blackbox application
  -> [Term]
  -- ^ Arguments of the primitive/blackbox application
  -> NetlistMonad (BlackBoxContext,[Declaration])
mkBlackBoxContext :: Text
-> Id -> [Term] -> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext bbName :: Text
bbName resId :: Id
resId args :: [Term]
args = do
    -- Make context inputs
    TyConMap
tcm             <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
    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)
    (imps :: [(Expr, HWType, Bool)]
imps,impDecls :: [[Declaration]]
impDecls) <- [((Expr, HWType, Bool), [Declaration])]
-> ([(Expr, HWType, Bool)], [[Declaration]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([((Expr, HWType, Bool), [Declaration])]
 -> ([(Expr, HWType, Bool)], [[Declaration]]))
-> NetlistMonad [((Expr, HWType, Bool), [Declaration])]
-> NetlistMonad ([(Expr, HWType, Bool)], [[Declaration]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Term -> NetlistMonad ((Expr, HWType, Bool), [Declaration]))
-> [Term] -> NetlistMonad [((Expr, HWType, Bool), [Declaration])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Text -> Term -> NetlistMonad ((Expr, HWType, Bool), [Declaration])
mkArgument Text
resNm) [Term]
args
    (funs :: IntMap
  (Either BlackBox (Text, [Declaration]), WireOrReg,
   [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
   BlackBoxContext)
funs,funDecls :: [[Declaration]]
funDecls) <- (IntMap
   (Either BlackBox (Text, [Declaration]), WireOrReg,
    [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
    BlackBoxContext)
 -> (Term, Key)
 -> 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, Key)]
-> NetlistMonad
     (IntMap
        (Either BlackBox (Text, [Declaration]), WireOrReg,
         [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
         BlackBoxContext),
      [[Declaration]])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM (TyConMap
-> IntMap
     (Either BlackBox (Text, [Declaration]), WireOrReg,
      [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
      BlackBoxContext)
-> (Term, Key)
-> NetlistMonad
     (IntMap
        (Either BlackBox (Text, [Declaration]), WireOrReg,
         [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
         BlackBoxContext),
      [Declaration])
addFunction TyConMap
tcm) IntMap
  (Either BlackBox (Text, [Declaration]), WireOrReg,
   [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
   BlackBoxContext)
forall a. IntMap a
IntMap.empty ([Term] -> [Key] -> [(Term, Key)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Term]
args [0..])

    -- Make context result
    let res :: Expr
res = Text -> Maybe Modifier -> Expr
Identifier Text
resNm Maybe Modifier
forall a. Maybe a
Nothing
    HWType
resTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(curLoc) (Id -> Type
forall a. Var a -> Type
V.varType Id
resId)

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

    (BlackBoxContext, [Declaration])
-> NetlistMonad (BlackBoxContext, [Declaration])
forall (m :: * -> *) 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]
-> Key
-> 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 [] Key
lvl Text
nm
           , [[Declaration]] -> [Declaration]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
impDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
funDecls
           )
  where
    addFunction :: TyConMap
-> IntMap
     (Either BlackBox (Text, [Declaration]), WireOrReg,
      [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
      BlackBoxContext)
-> (Term, Key)
-> NetlistMonad
     (IntMap
        (Either BlackBox (Text, [Declaration]), WireOrReg,
         [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
         BlackBoxContext),
      [Declaration])
addFunction tcm :: TyConMap
tcm im :: IntMap
  (Either BlackBox (Text, [Declaration]), WireOrReg,
   [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
   BlackBoxContext)
im (arg :: Term
arg,i :: Key
i) = if TyConMap -> Term -> Bool
isFun TyConMap
tcm Term
arg
      then do (Key -> Identity Key) -> NetlistState -> Identity NetlistState
Lens' NetlistState Key
curBBlvl ((Key -> Identity Key) -> NetlistState -> Identity NetlistState)
-> Key -> NetlistMonad ()
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
Lens.+= 1
              (f :: (Either BlackBox (Text, [Declaration]), WireOrReg,
 [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
 BlackBoxContext)
f,d :: [Declaration]
d) <- 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
              (Key -> Identity Key) -> NetlistState -> Identity NetlistState
Lens' NetlistState Key
curBBlvl ((Key -> Identity Key) -> NetlistState -> Identity NetlistState)
-> Key -> NetlistMonad ()
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
Lens.-= 1
              let im' :: IntMap
  (Either BlackBox (Text, [Declaration]), WireOrReg,
   [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
   BlackBoxContext)
im' = Key
-> (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. Key -> a -> IntMap a -> IntMap a
IntMap.insert Key
i (Either BlackBox (Text, [Declaration]), WireOrReg,
 [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
 BlackBoxContext)
f 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 :: * -> *) a. Monad m => a -> m a
return (IntMap
  (Either BlackBox (Text, [Declaration]), WireOrReg,
   [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
   BlackBoxContext)
im',[Declaration]
d)
      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 :: * -> *) a. Monad m => a -> m a
return (IntMap
  (Either BlackBox (Text, [Declaration]), WireOrReg,
   [BlackBoxTemplate], [BlackBoxTemplate], [((Text, Text), BlackBox)],
   BlackBoxContext)
im,[])

prepareBlackBox
  :: TextS.Text
  -> BlackBox
  -> BlackBoxContext
  -> NetlistMonad (BlackBox,[Declaration])
prepareBlackBox :: Text
-> BlackBox
-> BlackBoxContext
-> NetlistMonad (BlackBox, [Declaration])
prepareBlackBox pNm :: Text
pNm templ :: BlackBox
templ bbCtx :: BlackBoxContext
bbCtx =
  if BlackBoxContext -> BlackBox -> Bool
verifyBlackBoxContext BlackBoxContext
bbCtx BlackBox
templ
     then do
        (t2 :: BlackBox
t2,decls :: [Declaration]
decls) <-
          (BlackBoxTemplate -> NetlistMonad (BlackBox, [Declaration]))
-> (String
    -> Key
    -> TemplateFunction
    -> NetlistMonad (BlackBox, [Declaration]))
-> BlackBox
-> NetlistMonad (BlackBox, [Declaration])
forall r.
(BlackBoxTemplate -> r)
-> (String -> Key -> TemplateFunction -> r) -> BlackBox -> r
onBlackBox
            (((BlackBoxTemplate, [Declaration]) -> (BlackBox, [Declaration]))
-> NetlistMonad (BlackBoxTemplate, [Declaration])
-> NetlistMonad (BlackBox, [Declaration])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((BlackBoxTemplate -> BlackBox)
-> (BlackBoxTemplate, [Declaration]) -> (BlackBox, [Declaration])
forall (a :: * -> * -> *) 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 :: * -> *).
Monad m =>
(IdType -> Text -> m Text)
-> BlackBoxContext
-> BlackBoxTemplate
-> m (BlackBoxTemplate, [Declaration])
setSym IdType -> Text -> NetlistMonad Text
mkUniqueIdentifier BlackBoxContext
bbCtx)
            (\bbName :: String
bbName bbHash :: Key
bbHash bbFunc :: TemplateFunction
bbFunc -> (BlackBox, [Declaration]) -> NetlistMonad (BlackBox, [Declaration])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Key -> TemplateFunction -> BlackBox
BBFunction String
bbName Key
bbHash TemplateFunction
bbFunc, []))
            BlackBox
templ
        (BlackBox, [Declaration]) -> NetlistMonad (BlackBox, [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return (BlackBox
t2,[Declaration]
decls)
     else do
       (_,sp :: SrcSpan
sp) <- Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
-> NetlistMonad (Text, SrcSpan)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
Lens.use Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
Lens' NetlistState (Text, SrcSpan)
curCompNm
       Text
templ' <- (BlackBoxTemplate -> NetlistMonad Text)
-> (String -> Key -> TemplateFunction -> NetlistMonad Text)
-> BlackBox
-> NetlistMonad Text
forall r.
(BlackBoxTemplate -> r)
-> (String -> Key -> TemplateFunction -> r) -> BlackBox -> r
onBlackBox (Mon NetlistMonad Text -> NetlistMonad Text
forall (f :: * -> *) m. Mon f m -> f m
getMon (Mon NetlistMonad Text -> NetlistMonad Text)
-> (BlackBoxTemplate -> Mon NetlistMonad Text)
-> BlackBoxTemplate
-> NetlistMonad Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlackBoxTemplate -> Mon NetlistMonad Text
forall (m :: * -> *). Monad m => BlackBoxTemplate -> Mon m Text
prettyBlackBox)
                            (\n :: String
n h :: Key
h f :: TemplateFunction
f -> Text -> NetlistMonad Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> NetlistMonad Text) -> Text -> NetlistMonad Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ BlackBox -> String
forall a. Show a => a -> String
show (String -> Key -> TemplateFunction -> BlackBox
BBFunction String
n Key
h TemplateFunction
f))
                            BlackBox
templ
       let msg :: String
msg = $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Can't match template for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
pNm String -> String -> String
forall a. [a] -> [a] -> [a]
++ " :\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
templ' String -> String -> String
forall a. [a] -> [a] -> [a]
++
                "\n\nwith context:\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ BlackBoxContext -> String
forall a. Show a => a -> String
show BlackBoxContext
bbCtx
       ClashException -> NetlistMonad (BlackBox, [Declaration])
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)

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

mkArgument
  :: Identifier
  -- ^ LHS of the original let-binder
  -> Term
  -> NetlistMonad ( (Expr,HWType,Bool)
                  , [Declaration]
                  )
mkArgument :: Text -> Term -> NetlistMonad ((Expr, HWType, Bool), [Declaration])
mkArgument bndr :: Text
bndr e :: Term
e = do
    TyConMap
tcm   <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: * -> *) 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
    Key
iw    <- Getting Key NetlistState Key -> NetlistMonad Key
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
Lens.use Getting Key NetlistState Key
Lens' NetlistState Key
intWidth
    Maybe HWType
hwTyM <- (FilteredHWType -> HWType) -> Maybe FilteredHWType -> Maybe HWType
forall (f :: * -> *) 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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> NetlistMonad (Maybe FilteredHWType)
N.termHWTypeM Term
e
    let eTyMsg :: String
eTyMsg = "(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ " :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall p. PrettyPrec p => p -> String
showPpr Type
ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
    ((e' :: Expr
e',t :: HWType
t,l :: Bool
l),d :: [Declaration]
d) <- case Maybe HWType
hwTyM of
      Nothing
        | (Prim nm :: Text
nm _,_) <- Term -> (Term, [Either Term Type])
collectArgs Term
e
        , Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Transformations.removedArg"
        -> ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Text -> Maybe Modifier -> Expr
Identifier Text
nm 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 :: * -> *) a. Monad m => a -> m a
return ((String -> Expr
forall a. HasCallStack => String -> a
error ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Forced to evaluate untranslatable type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
eTyMsg), Maybe HWType -> HWType
Void Maybe HWType
forall a. Maybe a
Nothing, Bool
False), [])
      Just hwTy :: HWType
hwTy -> case Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks Term
e of
        (C.Var v :: Id
v,[],_) -> ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Text -> Maybe Modifier -> Expr
Identifier (Name Term -> Text
forall a. Name a -> Text
nameOcc (Id -> Name Term
forall a. Var a -> Name a
varName Id
v)) Maybe Modifier
forall a. Maybe a
Nothing,HWType
hwTy,Bool
False),[])
        (C.Literal (IntegerLiteral i :: Integer
i),[],_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe (HWType, Key) -> Literal -> Expr
N.Literal ((HWType, Key) -> Maybe (HWType, Key)
forall a. a -> Maybe a
Just (Key -> HWType
Signed Key
iw,Key
iw)) (Integer -> Literal
N.NumLit Integer
i),HWType
hwTy,Bool
True),[])
        (C.Literal (IntLiteral i :: Integer
i), [],_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe (HWType, Key) -> Literal -> Expr
N.Literal ((HWType, Key) -> Maybe (HWType, Key)
forall a. a -> Maybe a
Just (Key -> HWType
Signed Key
iw,Key
iw)) (Integer -> Literal
N.NumLit Integer
i),HWType
hwTy,Bool
True),[])
        (C.Literal (WordLiteral w :: Integer
w), [],_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe (HWType, Key) -> Literal -> Expr
N.Literal ((HWType, Key) -> Maybe (HWType, Key)
forall a. a -> Maybe a
Just (Key -> HWType
Unsigned Key
iw,Key
iw)) (Integer -> Literal
N.NumLit Integer
w),HWType
hwTy,Bool
True),[])
        (C.Literal (CharLiteral c :: Char
c), [],_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe (HWType, Key) -> Literal -> Expr
N.Literal ((HWType, Key) -> Maybe (HWType, Key)
forall a. a -> Maybe a
Just (Key -> HWType
Unsigned 21,21)) (Integer -> Literal
N.NumLit (Integer -> Literal) -> (Key -> Integer) -> Key -> Literal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Integer
forall a. Integral a => a -> Integer
toInteger (Key -> Literal) -> Key -> Literal
forall a b. (a -> b) -> a -> b
$ Char -> Key
ord Char
c),HWType
hwTy,Bool
True),[])
        (C.Literal (StringLiteral s :: String
s),[],_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe (HWType, Key) -> Literal -> Expr
N.Literal Maybe (HWType, Key)
forall a. Maybe a
Nothing (String -> Literal
N.StringLit String
s),HWType
hwTy,Bool
True),[])
        (C.Literal (Int64Literal i :: Integer
i), [],_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe (HWType, Key) -> Literal -> Expr
N.Literal ((HWType, Key) -> Maybe (HWType, Key)
forall a. a -> Maybe a
Just (Key -> HWType
Signed 64,64)) (Integer -> Literal
N.NumLit Integer
i),HWType
hwTy,Bool
True),[])
        (C.Literal (Word64Literal i :: Integer
i), [],_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe (HWType, Key) -> Literal -> Expr
N.Literal ((HWType, Key) -> Maybe (HWType, Key)
forall a. a -> Maybe a
Just (Key -> HWType
Unsigned 64,64)) (Integer -> Literal
N.NumLit Integer
i),HWType
hwTy,Bool
True),[])
        (C.Literal (NaturalLiteral n :: Integer
n), [],_) ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe (HWType, Key) -> Literal -> Expr
N.Literal ((HWType, Key) -> Maybe (HWType, Key)
forall a. a -> Maybe a
Just (Key -> HWType
Unsigned Key
iw,Key
iw)) (Integer -> Literal
N.NumLit Integer
n),HWType
hwTy,Bool
True),[])
        (Prim f :: Text
f _,args :: [Either Term Type]
args,ticks :: [TickInfo]
ticks) -> [TickInfo]
-> ([Declaration]
    -> NetlistMonad ((Expr, HWType, Bool), [Declaration]))
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall a.
[TickInfo] -> ([Declaration] -> NetlistMonad a) -> NetlistMonad a
withTicks [TickInfo]
ticks (([Declaration]
  -> NetlistMonad ((Expr, HWType, Bool), [Declaration]))
 -> NetlistMonad ((Expr, HWType, Bool), [Declaration]))
-> ([Declaration]
    -> NetlistMonad ((Expr, HWType, Bool), [Declaration]))
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall a b. (a -> b) -> a -> b
$ \tickDecls :: [Declaration]
tickDecls -> do
          (e' :: Expr
e',d :: [Declaration]
d) <- Bool
-> Bool
-> Either Text Id
-> Text
-> [Either Term Type]
-> Type
-> [Declaration]
-> NetlistMonad (Expr, [Declaration])
mkPrimitive Bool
True Bool
False (Text -> Either Text Id
forall a b. a -> Either a b
Left Text
bndr) Text
f [Either Term Type]
args Type
ty [Declaration]
tickDecls
          case Expr
e' of
            (Identifier _ _) -> ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Expr
e',HWType
hwTy,Bool
False), [Declaration]
d)
            _                -> ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Expr
e',HWType
hwTy,Term -> Bool
isLiteral Term
e), [Declaration]
d)
        (Data dc :: DataCon
dc, args :: [Either Term Type]
args,_) -> do
          (exprN :: Expr
exprN,dcDecls :: [Declaration]
dcDecls) <- HasCallStack =>
HWType
-> Either Text Id
-> DataCon
-> [Term]
-> NetlistMonad (Expr, [Declaration])
HWType
-> Either Text Id
-> DataCon
-> [Term]
-> NetlistMonad (Expr, [Declaration])
mkDcApplication HWType
hwTy (Text -> Either Text Id
forall a b. a -> Either a b
Left Text
bndr) 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 :: * -> *) a. Monad m => a -> m a
return ((Expr
exprN,HWType
hwTy,Term -> Bool
isLiteral Term
e),[Declaration]
dcDecls)
        (Case scrut :: Term
scrut ty' :: Type
ty' [alt :: Alt
alt],[],_) -> do
          (projection :: Expr
projection,decls :: [Declaration]
decls) <- Bool
-> Either Text Id
-> Term
-> Type
-> Alt
-> NetlistMonad (Expr, [Declaration])
mkProjection Bool
False (Text -> Either Text Id
forall a b. a -> Either a b
Left Text
bndr) Term
scrut Type
ty' Alt
alt
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Expr
projection,HWType
hwTy,Bool
False),[Declaration]
decls)
        _ ->
          ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Text -> Maybe Modifier -> Expr
Identifier (String -> Text
forall a. HasCallStack => String -> a
error ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Forced to evaluate unexpected function argument: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
eTyMsg)) Maybe Modifier
forall a. Maybe a
Nothing
                  ,HWType
hwTy,Bool
False),[])
    ((Expr, HWType, Bool), [Declaration])
-> NetlistMonad ((Expr, HWType, Bool), [Declaration])
forall (m :: * -> *) 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
  :: TextS.Text
  -- ^ Name of primitive
  -> NetlistMonad CompiledPrimitive
extractPrimWarnOrFail :: Text -> NetlistMonad CompiledPrimitive
extractPrimWarnOrFail nm :: Text
nm = do
  Maybe GuardedCompiledPrimitive
prim <- Text
-> HashMap Text GuardedCompiledPrimitive
-> Maybe GuardedCompiledPrimitive
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
nm (HashMap Text GuardedCompiledPrimitive
 -> Maybe GuardedCompiledPrimitive)
-> NetlistMonad (HashMap Text GuardedCompiledPrimitive)
-> NetlistMonad (Maybe GuardedCompiledPrimitive)
forall (f :: * -> *) 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 :: * -> *) a. MonadState s m => Getting a s a -> m a
Lens.use Getting
  (HashMap Text GuardedCompiledPrimitive)
  NetlistState
  (HashMap Text GuardedCompiledPrimitive)
Lens' NetlistState (HashMap Text GuardedCompiledPrimitive)
primitives
  case Maybe GuardedCompiledPrimitive
prim of
    Just guardedPrim :: GuardedCompiledPrimitive
guardedPrim ->
      -- See if we need to warn the user, or error because we encountered
      -- a primitive the user explicitly requested not to translate
      GuardedCompiledPrimitive -> NetlistMonad CompiledPrimitive
go GuardedCompiledPrimitive
guardedPrim
    Nothing -> do
      -- Blackbox requested, but no blackbox found at all!
      (_,sp :: SrcSpan
sp) <- Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
-> NetlistMonad (Text, SrcSpan)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
Lens.use Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
Lens' NetlistState (Text, SrcSpan)
curCompNm
      let msg :: String
msg = $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "No blackbox found for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
unpack Text
nm
             String -> String -> String
forall a. [a] -> [a] -> [a]
++ ". Did you forget to include directories containing "
             String -> String -> String
forall a. [a] -> [a] -> [a]
++ "primitives? You can use '-i/my/prim/dir' to achieve this."
      ClashException -> NetlistMonad CompiledPrimitive
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp String
msg Maybe String
forall a. Maybe a
Nothing)
 where
  go
    :: GuardedCompiledPrimitive
    -> NetlistMonad CompiledPrimitive
  go :: GuardedCompiledPrimitive -> NetlistMonad CompiledPrimitive
go (HasBlackBox cp :: CompiledPrimitive
cp) =
    CompiledPrimitive -> NetlistMonad CompiledPrimitive
forall (m :: * -> *) a. Monad m => a -> m a
return CompiledPrimitive
cp

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

  go (WarnAlways warning :: String
warning cp :: CompiledPrimitive
cp) = do
    Bool
primWarn <- ClashOpts -> Bool
opt_primWarn (ClashOpts -> Bool) -> NetlistMonad ClashOpts -> NetlistMonad Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting ClashOpts NetlistState ClashOpts -> NetlistMonad ClashOpts
forall s (m :: * -> *) 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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Set Text) NetlistState (Set Text)
-> NetlistMonad (Set Text)
forall s (m :: * -> *) 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 :: * -> *) 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 :: * -> *). 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 :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      (IO () -> NetlistMonad ()) -> IO () -> NetlistMonad ()
forall a b. (a -> b) -> a -> b
$ ClashOpts -> String -> IO ()
warn ClashOpts
opts
      (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Dubious primitive instantiation for "
     String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
unpack Text
nm
     String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": "
     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
warning
     String -> String -> String
forall a. [a] -> [a] -> [a]
++ " (disable with -fclash-no-prim-warn)"

    (Set Text -> Identity (Set Text))
-> NetlistState -> Identity NetlistState
Lens' NetlistState (Set Text)
seenPrimitives ((Set Text -> Identity (Set Text))
 -> NetlistState -> Identity NetlistState)
-> (Set Text -> Set Text) -> NetlistMonad ()
forall s (m :: * -> *) 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 :: * -> *) a. Monad m => a -> m a
return CompiledPrimitive
cp

  go (WarnNonSynthesizable warning :: String
warning cp :: CompiledPrimitive
cp) = do
    Bool
isTB <- Getting Bool NetlistState Bool -> NetlistMonad Bool
forall s (m :: * -> *) 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 :: * -> *) 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
  -> Either Identifier Id
  -- ^ Id to assign the result to
  -> TextS.Text
  -- ^ Name of primitive
  -> [Either Term Type]
  -- ^ Arguments
  -> Type
  -- ^ Result type
  -> [Declaration]
  -- ^ Tick declarations
  -> NetlistMonad (Expr,[Declaration])
mkPrimitive :: Bool
-> Bool
-> Either Text Id
-> Text
-> [Either Term Type]
-> Type
-> [Declaration]
-> NetlistMonad (Expr, [Declaration])
mkPrimitive bbEParen :: Bool
bbEParen bbEasD :: Bool
bbEasD dst :: Either Text Id
dst nm :: Text
nm args :: [Either Term Type]
args ty :: Type
ty tickDecls :: [Declaration]
tickDecls =
  CompiledPrimitive -> NetlistMonad (Expr, [Declaration])
go (CompiledPrimitive -> NetlistMonad (Expr, [Declaration]))
-> NetlistMonad CompiledPrimitive
-> NetlistMonad (Expr, [Declaration])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> NetlistMonad CompiledPrimitive
extractPrimWarnOrFail Text
nm
  where
    go
      :: CompiledPrimitive
      -> NetlistMonad (Expr, [Declaration])
    go :: CompiledPrimitive -> NetlistMonad (Expr, [Declaration])
go =
      \case
        P.BlackBoxHaskell bbName :: Text
bbName wf :: WorkInfo
wf funcName :: BlackBoxFunctionName
funcName (_fHash :: Key
_fHash, func :: BlackBoxFunction
func) -> do
          Either String (BlackBoxMeta, BlackBox)
bbFunRes <- BlackBoxFunction
func Bool
bbEasD Text
nm [Either Term Type]
args Type
ty
          case Either String (BlackBoxMeta, BlackBox)
bbFunRes of
            Left err :: String
err -> do
              -- Blackbox template function returned an error:
              let err' :: String
err' = [String] -> String
unwords [ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Could not create blackbox"
                                 , "template using", BlackBoxFunctionName -> String
forall a. Show a => a -> String
show BlackBoxFunctionName
funcName, "for"
                                 , Text -> String
forall a. Show a => a -> String
show Text
bbName String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".", "Function reported: \n\n"
                                 , String
err ]
              (_,sp :: SrcSpan
sp) <- Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
-> NetlistMonad (Text, SrcSpan)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
Lens.use Getting (Text, SrcSpan) NetlistState (Text, SrcSpan)
Lens' NetlistState (Text, SrcSpan)
curCompNm
              ClashException -> NetlistMonad (Expr, [Declaration])
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp String
err' Maybe String
forall a. Maybe a
Nothing)
            Right (BlackBoxMeta {..}, bbTemplate :: BlackBox
bbTemplate) ->
              -- Blackbox template generation succesful. Rerun 'go', but this time
              -- around with a 'normal' @BlackBox@
              CompiledPrimitive -> NetlistMonad (Expr, [Declaration])
go (Text
-> WorkInfo
-> TemplateKind
-> ()
-> Bool
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> CompiledPrimitive
forall a b c d.
Text
-> WorkInfo
-> TemplateKind
-> c
-> Bool
-> [a]
-> [a]
-> [((Text, Text), b)]
-> b
-> Primitive a b c d
P.BlackBox Text
bbName WorkInfo
wf TemplateKind
bbKind () Bool
bbOutputReg [BlackBoxTemplate]
bbLibrary [BlackBoxTemplate]
bbImports [((Text, Text), BlackBox)]
bbIncludes BlackBox
bbTemplate)
        p :: CompiledPrimitive
p@P.BlackBox {outputReg :: forall a b c d. Primitive a b c d -> Bool
outputReg = Bool
wr} ->
          case CompiledPrimitive -> TemplateKind
forall a b c d. Primitive a b c d -> TemplateKind
kind CompiledPrimitive
p of
            TDecl -> do
              let tempD :: BlackBox
tempD = CompiledPrimitive -> BlackBox
forall a b c d. Primitive a b c d -> b
template CompiledPrimitive
p
                  pNm :: Text
pNm = CompiledPrimitive -> Text
forall a b c d. Primitive a b c d -> Text
name CompiledPrimitive
p
                  wr' :: WireOrReg
wr' = if Bool
wr then WireOrReg
Reg else WireOrReg
Wire
              Maybe (Id, Text, [Declaration])
resM <- Bool
-> WireOrReg
-> Either Text Id
-> NetlistMonad (Maybe (Id, Text, [Declaration]))
resBndr Bool
True WireOrReg
wr' Either Text Id
dst
              case Maybe (Id, Text, [Declaration])
resM of
                Just (dst' :: Id
dst',dstNm :: Text
dstNm,dstDecl :: [Declaration]
dstDecl) -> do
                  (bbCtx :: BlackBoxContext
bbCtx,ctxDcls :: [Declaration]
ctxDcls)   <- Text
-> Id -> [Term] -> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext Text
nm Id
dst' ([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args)
                  (templ :: BlackBox
templ,templDecl :: [Declaration]
templDecl) <- Text
-> BlackBox
-> BlackBoxContext
-> NetlistMonad (BlackBox, [Declaration])
prepareBlackBox Text
pNm BlackBox
tempD BlackBoxContext
bbCtx
                  let bbDecl :: Declaration
bbDecl = Text
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> BlackBoxContext
-> Declaration
N.BlackBoxD Text
pNm (CompiledPrimitive -> [BlackBoxTemplate]
forall a b c d. Primitive a b c d -> [a]
libraries CompiledPrimitive
p) (CompiledPrimitive -> [BlackBoxTemplate]
forall a b c d. Primitive a b c d -> [a]
imports CompiledPrimitive
p)
                                           (CompiledPrimitive -> [((Text, Text), BlackBox)]
forall a b c d. Primitive a b c d -> [((Text, Text), b)]
includes CompiledPrimitive
p) BlackBox
templ BlackBoxContext
bbCtx
                  (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: * -> *) 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])
                Nothing -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Maybe Modifier -> Expr
Identifier "__VOID__" Maybe Modifier
forall a. Maybe a
Nothing,[])
            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 <- Bool
-> WireOrReg
-> Either Text Id
-> NetlistMonad (Maybe (Id, Text, [Declaration]))
resBndr Bool
True WireOrReg
Wire Either Text Id
dst
                  case Maybe (Id, Text, [Declaration])
resM of
                    Just (dst' :: Id
dst',dstNm :: Text
dstNm,dstDecl :: [Declaration]
dstDecl) -> do
                      (bbCtx :: BlackBoxContext
bbCtx,ctxDcls :: [Declaration]
ctxDcls)     <- Text
-> Id -> [Term] -> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext Text
nm Id
dst' ([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args)
                      (bbTempl :: BlackBox
bbTempl,templDecl :: [Declaration]
templDecl) <- Text
-> BlackBox
-> BlackBoxContext
-> NetlistMonad (BlackBox, [Declaration])
prepareBlackBox Text
pNm BlackBox
tempE BlackBoxContext
bbCtx
                      let tmpAssgn :: Declaration
tmpAssgn = Text -> Expr -> Declaration
Assignment Text
dstNm
                                        (Text
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> BlackBoxContext
-> Bool
-> Expr
BlackBoxE Text
pNm (CompiledPrimitive -> [BlackBoxTemplate]
forall a b c d. Primitive a b c d -> [a]
libraries CompiledPrimitive
p) (CompiledPrimitive -> [BlackBoxTemplate]
forall a b c d. Primitive a b c d -> [a]
imports CompiledPrimitive
p)
                                                   (CompiledPrimitive -> [((Text, Text), BlackBox)]
forall a b c d. Primitive a b c d -> [((Text, Text), b)]
includes CompiledPrimitive
p) BlackBox
bbTempl BlackBoxContext
bbCtx
                                                   Bool
bbEParen)
                      (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: * -> *) 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])
                    Nothing -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Maybe Modifier -> Expr
Identifier "__VOID__" Maybe Modifier
forall a. Maybe a
Nothing,[])
                else do
                  Maybe (Id, Text, [Declaration])
resM <- Bool
-> WireOrReg
-> Either Text Id
-> NetlistMonad (Maybe (Id, Text, [Declaration]))
resBndr Bool
False WireOrReg
Wire Either Text Id
dst
                  case Maybe (Id, Text, [Declaration])
resM of
                    Just (dst' :: Id
dst',_,_) -> do
                      (bbCtx :: BlackBoxContext
bbCtx,ctxDcls :: [Declaration]
ctxDcls)      <- Text
-> Id -> [Term] -> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext Text
nm Id
dst' ([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args)
                      (bbTempl :: BlackBox
bbTempl,templDecl0 :: [Declaration]
templDecl0) <- Text
-> BlackBox
-> BlackBoxContext
-> NetlistMonad (BlackBox, [Declaration])
prepareBlackBox Text
pNm BlackBox
tempE BlackBoxContext
bbCtx
                      let templDecl1 :: [Declaration]
templDecl1 = case Text
nm of
                            "Clash.Sized.Internal.BitVector.fromInteger#"
                              | [N.Literal _ (NumLit _), N.Literal _ _, N.Literal _ _] <- BlackBoxContext -> [Expr]
extractLiterals BlackBoxContext
bbCtx -> []
                            "Clash.Sized.Internal.BitVector.fromInteger##"
                              | [N.Literal _ _, N.Literal _ _] <- BlackBoxContext -> [Expr]
extractLiterals BlackBoxContext
bbCtx -> []
                            "Clash.Sized.Internal.Index.fromInteger#"
                              | [N.Literal _ (NumLit _), N.Literal _ _] <- BlackBoxContext -> [Expr]
extractLiterals BlackBoxContext
bbCtx -> []
                            "Clash.Sized.Internal.Signed.fromInteger#"
                              | [N.Literal _ (NumLit _), N.Literal _ _] <- BlackBoxContext -> [Expr]
extractLiterals BlackBoxContext
bbCtx -> []
                            "Clash.Sized.Internal.Unsigned.fromInteger#"
                              | [N.Literal _ (NumLit _), N.Literal _ _] <- BlackBoxContext -> [Expr]
extractLiterals BlackBoxContext
bbCtx -> []
                            _ -> [Declaration]
templDecl0
                      (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: * -> *) 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)
                    Nothing -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Maybe Modifier -> Expr
Identifier "__VOID__" Maybe Modifier
forall a. Maybe a
Nothing,[])
        P.Primitive pNm :: Text
pNm _ _
          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "GHC.Prim.tagToEnum#" -> do
              HWType
hwTy <- String -> Type -> NetlistMonad HWType
N.unsafeCoreTypeToHWTypeM' $(curLoc) Type
ty
              case [Either Term Type]
args of
                [Right (ConstTy (TyCon tcN :: TyConName
tcN)), Left (C.Literal (IntLiteral i :: Integer
i))] -> do
                  TyConMap
tcm <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: * -> *) 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] -> Key -> DataCon
forall a. [a] -> Key -> a
!! Integer -> Key
forall a. Num a => Integer -> a
fromInteger Integer
i
                  (exprN :: Expr
exprN,dcDecls :: [Declaration]
dcDecls) <- HasCallStack =>
HWType
-> Either Text Id
-> DataCon
-> [Term]
-> NetlistMonad (Expr, [Declaration])
HWType
-> Either Text Id
-> DataCon
-> [Term]
-> NetlistMonad (Expr, [Declaration])
mkDcApplication HWType
hwTy Either Text Id
dst DataCon
dc []
                  (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr
exprN,[Declaration]
dcDecls)
                [Right _, Left scrut :: Term
scrut] -> do
                  TyConMap
tcm     <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
                  let scrutTy :: Type
scrutTy = TyConMap -> Term -> Type
termType TyConMap
tcm Term
scrut
                  (scrutExpr :: Expr
scrutExpr,scrutDecls :: [Declaration]
scrutDecls) <- HasCallStack =>
Bool
-> Either Text Id
-> Type
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> Either Text Id
-> Type
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False (Text -> Either Text Id
forall a b. a -> Either a b
Left "c$tte_rhs") Type
scrutTy Term
scrut
                  case Expr
scrutExpr of
                    Identifier id_ :: Text
id_ Nothing -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return (HWType -> Either Text Text -> Expr
DataTag HWType
hwTy (Text -> Either Text Text
forall a b. a -> Either a b
Left Text
id_),[Declaration]
scrutDecls)
                    _ -> do
                      HWType
scrutHTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(curLoc) Type
scrutTy
                      Text
tmpRhs <- IdType -> Text -> NetlistMonad Text
mkUniqueIdentifier IdType
Extended "c$tte_rhs"
                      let netDeclRhs :: Declaration
netDeclRhs   = Maybe Text -> Text -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Text
tmpRhs HWType
scrutHTy
                          netAssignRhs :: Declaration
netAssignRhs = Text -> Expr -> Declaration
Assignment Text
tmpRhs Expr
scrutExpr
                      (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return (HWType -> Either Text Text -> Expr
DataTag HWType
hwTy (Text -> Either Text Text
forall a b. a -> Either a b
Left Text
tmpRhs),[Declaration
netDeclRhs,Declaration
netAssignRhs] [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
scrutDecls)
                _ -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error (String -> NetlistMonad (Expr, [Declaration]))
-> String -> NetlistMonad (Expr, [Declaration])
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "tagToEnum: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show ((Either Term Type -> String) -> [Either Term Type] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> String) -> (Type -> String) -> Either Term Type -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Term -> String
forall p. PrettyPrec p => p -> String
showPpr Type -> String
forall p. PrettyPrec p => p -> String
showPpr) [Either Term Type]
args)
          | Text
pNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "GHC.Prim.dataToTag#" -> case [Either Term Type]
args of
              [Right _,Left (Data dc :: DataCon
dc)] -> do
                Key
iw <- Getting Key NetlistState Key -> NetlistMonad Key
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
Lens.use Getting Key NetlistState Key
Lens' NetlistState Key
intWidth
                (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (HWType, Key) -> Literal -> Expr
N.Literal ((HWType, Key) -> Maybe (HWType, Key)
forall a. a -> Maybe a
Just (Key -> HWType
Signed Key
iw,Key
iw)) (Integer -> Literal
NumLit (Integer -> Literal) -> Integer -> Literal
forall a b. (a -> b) -> a -> b
$ Key -> Integer
forall a. Integral a => a -> Integer
toInteger (Key -> Integer) -> Key -> Integer
forall a b. (a -> b) -> a -> b
$ DataCon -> Key
dcTag DataCon
dc Key -> Key -> Key
forall a. Num a => a -> a -> a
- 1),[])
              [Right _,Left scrut :: Term
scrut] -> do
                TyConMap
tcm      <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
                let scrutTy :: Type
scrutTy = TyConMap -> Term -> Type
termType TyConMap
tcm Term
scrut
                HWType
scrutHTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(curLoc) Type
scrutTy
                (scrutExpr :: Expr
scrutExpr,scrutDecls :: [Declaration]
scrutDecls) <- HasCallStack =>
Bool
-> Either Text Id
-> Type
-> Term
-> NetlistMonad (Expr, [Declaration])
Bool
-> Either Text Id
-> Type
-> Term
-> NetlistMonad (Expr, [Declaration])
mkExpr Bool
False (Text -> Either Text Id
forall a b. a -> Either a b
Left "c$dtt_rhs") Type
scrutTy Term
scrut
                case Expr
scrutExpr of
                  Identifier id_ :: Text
id_ Nothing -> (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return (HWType -> Either Text Text -> Expr
DataTag HWType
scrutHTy (Text -> Either Text Text
forall a b. b -> Either a b
Right Text
id_),[Declaration]
scrutDecls)
                  _ -> do
                    Text
tmpRhs  <- IdType -> Text -> NetlistMonad Text
mkUniqueIdentifier IdType
Extended "c$dtt_rhs"
                    let netDeclRhs :: Declaration
netDeclRhs   = Maybe Text -> Text -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Text
tmpRhs HWType
scrutHTy
                        netAssignRhs :: Declaration
netAssignRhs = Text -> Expr -> Declaration
Assignment Text
tmpRhs Expr
scrutExpr
                    (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return (HWType -> Either Text Text -> Expr
DataTag HWType
scrutHTy (Text -> Either Text Text
forall a b. b -> Either a b
Right Text
tmpRhs),[Declaration
netDeclRhs,Declaration
netAssignRhs] [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
scrutDecls)
              _ -> String -> NetlistMonad (Expr, [Declaration])
forall a. HasCallStack => String -> a
error (String -> NetlistMonad (Expr, [Declaration]))
-> String -> NetlistMonad (Expr, [Declaration])
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "dataToTag: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show ((Either Term Type -> String) -> [Either Term Type] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> String) -> (Type -> String) -> Either Term Type -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Term -> String
forall p. PrettyPrec p => p -> String
showPpr Type -> String
forall p. PrettyPrec p => p -> String
showPpr) [Either Term Type]
args)
          | Bool
otherwise ->
              (Expr, [Declaration]) -> NetlistMonad (Expr, [Declaration])
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> BlackBoxContext
-> Bool
-> Expr
BlackBoxE "" [] [] []
                        (BlackBoxTemplate -> BlackBox
BBTemplate [Text -> Element
Text (Text -> Element) -> Text -> Element
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ["NO_TRANSLATION_FOR:",Text -> Text
fromStrict Text
pNm]])
                        (Text -> BlackBoxContext
emptyBBContext Text
pNm) Bool
False,[])

    resBndr
      :: Bool
      -> WireOrReg
      -> (Either Identifier Id)
      -> NetlistMonad (Maybe (Id,Identifier,[Declaration]))
      -- Nothing when the binder would have type `Void`
    resBndr :: Bool
-> WireOrReg
-> Either Text Id
-> NetlistMonad (Maybe (Id, Text, [Declaration]))
resBndr mkDec :: Bool
mkDec wr :: WireOrReg
wr dst' :: Either Text Id
dst' = case Either Text Id
dst' of
      Left dstL :: Text
dstL -> case Bool
mkDec of
        False -> do
          -- TODO: check that it's okay to use `mkUnsafeSystemName`
          let nm' :: Name a
nm' = Text -> Key -> Name a
forall a. Text -> Key -> Name a
mkUnsafeSystemName Text
dstL 0
              id_ :: Id
id_ = Type -> Name Term -> Id
mkLocalId Type
ty Name Term
forall a. Name a
nm'
          Maybe (Id, Text, [Declaration])
-> NetlistMonad (Maybe (Id, Text, [Declaration]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Id, Text, [Declaration]) -> Maybe (Id, Text, [Declaration])
forall a. a -> Maybe a
Just (Id
id_,Text
dstL,[]))
        True -> do
          Text
nm'  <- IdType -> Text -> Text -> NetlistMonad Text
extendIdentifier IdType
Extended Text
dstL "_res"
          Text
nm'' <- IdType -> Text -> NetlistMonad Text
mkUniqueIdentifier IdType
Extended Text
nm'
          -- TODO: check that it's okay to use `mkUnsafeInternalName`
          let nm3 :: Name a
nm3 = Text -> Key -> Name a
forall a. Text -> Key -> Name a
mkUnsafeSystemName Text
nm'' 0
          HWType
hwTy <- String -> Type -> NetlistMonad HWType
N.unsafeCoreTypeToHWTypeM' $(curLoc) Type
ty
          let id_ :: Id
id_    = Type -> Name Term -> Id
mkLocalId Type
ty Name Term
forall a. Name a
nm3
              idDecl :: Declaration
idDecl = Maybe Text
-> WireOrReg -> Text -> Either Text HWType -> Declaration
NetDecl' Maybe Text
forall a. Maybe a
Nothing WireOrReg
wr Text
nm'' (HWType -> Either Text HWType
forall a b. b -> Either a b
Right HWType
hwTy)
          case HWType
hwTy of
            Void {} -> Maybe (Id, Text, [Declaration])
-> NetlistMonad (Maybe (Id, Text, [Declaration]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Id, Text, [Declaration])
forall a. Maybe a
Nothing
            _       -> Maybe (Id, Text, [Declaration])
-> NetlistMonad (Maybe (Id, Text, [Declaration]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Id, Text, [Declaration]) -> Maybe (Id, Text, [Declaration])
forall a. a -> Maybe a
Just (Id
id_,Text
nm'',[Declaration
idDecl]))
      Right dstR :: Id
dstR -> Maybe (Id, Text, [Declaration])
-> NetlistMonad (Maybe (Id, Text, [Declaration]))
forall (m :: * -> *) 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,[]))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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