{-|
  Copyright   :  (C) 2020 QBayLogic
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>

  Blackbox implementations for functions in "Clash.Sized.Vector".
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

module Clash.Primitives.Sized.Vector where

import           Control.Monad                      (replicateM)
import           Control.Monad.State                (State, zipWithM)
import qualified Control.Lens                       as Lens
import           Data.Either                        (rights)
import qualified Data.IntMap                        as IntMap
import           Data.List.Extra                    (iterateNM)
import           Data.Maybe                         (fromMaybe)
import           Data.Semigroup.Monad               (getMon)
import           Data.Text.Lazy                     (pack)
import           Data.Text.Prettyprint.Doc.Extra
  (Doc, string, renderLazy, layoutPretty, LayoutOptions(..),
   PageWidth(AvailablePerLine))
import           Text.Trifecta.Result               (Result(Success))
import qualified Data.String.Interpolate            as I
import qualified Data.String.Interpolate.Util       as I
import           TextShow                           (showt)

import           Clash.Backend
  (Backend, hdlTypeErrValue, expr, blockDecl)
import           Clash.Core.Type
  (Type(LitTy), LitTy(NumTy), coreView)
import           Clash.Netlist.BlackBox             (isLiteral)
import           Clash.Netlist.BlackBox.Util        (renderElem)
import           Clash.Netlist.BlackBox.Parser      (runParse)
import           Clash.Netlist.BlackBox.Types
  (BlackBoxFunction, BlackBoxMeta(..), TemplateKind(TExpr, TDecl),
   Element(Component, Typ, TypElem, Text), Decl(Decl), emptyBlackBoxMeta)
import           Clash.Netlist.Types
  (Identifier, TemplateFunction, BlackBoxContext, HWType(Vector),
   Declaration(..), Expr(BlackBoxE, Literal, Identifier), Literal(NumLit),
   BlackBox(BBTemplate, BBFunction), TemplateFunction(..), WireOrReg(Wire),
   Modifier(Indexed, Nested), bbInputs, bbResults, emptyBBContext, tcCache,
   bbFunctions)
import qualified Clash.Netlist.Id                   as Id
import           Clash.Netlist.Util                 (typeSize)
import qualified Clash.Primitives.DSL               as Prim
import           Clash.Primitives.DSL
  (declarationReturn, instHO, tInputs, tExprToInteger)

import           Clash.Util                         (HasCallStack, curLoc)

-- | Blackbox function for 'Clash.Sized.Vector.iterateI'
iterateBBF :: HasCallStack => BlackBoxFunction
iterateBBF :: BlackBoxFunction
iterateBBF Bool
_isD Text
_primName [Either Term Type]
args [Type]
_resTy = do
  TyConMap
tcm <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
  Either String (BlackBoxMeta, BlackBox)
-> NetlistMonad (Either String (BlackBoxMeta, BlackBox))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((BlackBoxMeta, BlackBox) -> Either String (BlackBoxMeta, BlackBox)
forall a b. b -> Either a b
Right (TyConMap -> BlackBoxMeta
meta TyConMap
tcm, BlackBox
bb))
 where
  bb :: BlackBox
bb = String -> BBHash -> TemplateFunction -> BlackBox
BBFunction String
"Clash.Primitives.Sized.Vector.iterateBBF" BBHash
0 TemplateFunction
iterateTF
  vecLength :: TyConMap -> p
vecLength TyConMap
tcm =
    case TyConMap -> Type -> Type
coreView TyConMap
tcm ([Type] -> Type
forall a. [a] -> a
head ([Either Term Type] -> [Type]
forall a b. [Either a b] -> [b]
rights [Either Term Type]
args)) of
      (LitTy (NumTy Integer
0)) -> String -> p
forall a. HasCallStack => String -> a
error String
"Unexpected empty vector in 'iterateBBF'"
      (LitTy (NumTy Integer
n)) -> Integer -> p
forall a. Num a => Integer -> a
fromInteger (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)
      Type
vl -> String -> p
forall a. HasCallStack => String -> a
error (String -> p) -> String -> p
forall a b. (a -> b) -> a -> b
$ String
"Unexpected vector length: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
vl
  meta :: TyConMap -> BlackBoxMeta
meta TyConMap
tcm = BlackBoxMeta
emptyBlackBoxMeta {
      bbKind :: TemplateKind
bbKind=TemplateKind
TDecl
    , bbFunctionPlurality :: [(BBHash, BBHash)]
bbFunctionPlurality=[(BBHash
1, TyConMap -> BBHash
forall p. Num p => TyConMap -> p
vecLength TyConMap
tcm)]
    }

-- | Type signature of function we're generating netlist for:
--
--   iterateI :: KnownNat n => (a -> a) -> a -> Vec n a
--
iterateTF :: TemplateFunction
iterateTF :: TemplateFunction
iterateTF = [BBHash]
-> (BlackBoxContext -> Bool)
-> (forall s. Backend s => BlackBoxContext -> State s Doc)
-> TemplateFunction
TemplateFunction [] (Bool -> BlackBoxContext -> Bool
forall a b. a -> b -> a
const Bool
True) forall s.
(HasCallStack, Backend s) =>
BlackBoxContext -> State s Doc
forall s. Backend s => BlackBoxContext -> State s Doc
iterateTF'

iterateTF'
  :: forall s
   . (HasCallStack, Backend s)
  => BlackBoxContext
  -> State s Doc
iterateTF' :: BlackBoxContext -> State s Doc
iterateTF' BlackBoxContext
bbCtx
  | [ (Integer -> Maybe Integer -> Integer
forall a. a -> Maybe a -> a
fromMaybe (String -> Integer
forall a. HasCallStack => String -> a
error String
"n") (Maybe Integer -> Integer)
-> (TExpr -> Maybe Integer) -> TExpr -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TExpr -> Maybe Integer
tExprToInteger -> Integer
n, HWType
_)
    , (TExpr, HWType)
_hoFunction
    , (TExpr
a, HWType
aType)
    ] <- BlackBoxContext -> [(TExpr, HWType)]
tInputs BlackBoxContext
bbCtx
  , let aTemplateType :: [Element]
aTemplateType = [Element -> Element
TypElem (Maybe BBHash -> Element
Typ (BBHash -> Maybe BBHash
forall a. a -> Maybe a
Just BBHash
2))]
  , let inst :: TExpr -> State (BlockState backend) TExpr
inst TExpr
arg = BlackBoxContext
-> BBHash
-> (HWType, [Element])
-> [(TExpr, [Element])]
-> State (BlockState backend) TExpr
forall backend.
Backend backend =>
BlackBoxContext
-> BBHash
-> (HWType, [Element])
-> [(TExpr, [Element])]
-> State (BlockState backend) TExpr
instHO BlackBoxContext
bbCtx BBHash
1 (HWType
aType, [Element]
aTemplateType) [(TExpr
arg, [Element]
aTemplateType)]
  = BlackBoxContext
-> Text -> State (BlockState s) [TExpr] -> State s Doc
forall backend.
Backend backend =>
BlackBoxContext
-> Text -> State (BlockState backend) [TExpr] -> State backend Doc
declarationReturn BlackBoxContext
bbCtx Text
"iterateI" ((TExpr -> [TExpr])
-> StateT (BlockState s) Identity TExpr
-> State (BlockState s) [TExpr]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap TExpr -> [TExpr]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (StateT (BlockState s) Identity TExpr
 -> State (BlockState s) [TExpr])
-> ([TExpr] -> StateT (BlockState s) Identity TExpr)
-> [TExpr]
-> State (BlockState s) [TExpr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TExpr] -> StateT (BlockState s) Identity TExpr
forall backend.
(HasCallStack, Backend backend) =>
[TExpr] -> State (BlockState backend) TExpr
Prim.vec ([TExpr] -> State (BlockState s) [TExpr])
-> State (BlockState s) [TExpr] -> State (BlockState s) [TExpr]
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Word
-> (TExpr -> StateT (BlockState s) Identity TExpr)
-> TExpr
-> State (BlockState s) [TExpr]
forall (m :: Type -> Type) a.
Monad m =>
Word -> (a -> m a) -> a -> m [a]
iterateNM (Integer -> Word
forall a. Num a => Integer -> a
fromInteger Integer
n) TExpr -> StateT (BlockState s) Identity TExpr
forall backend.
Backend backend =>
TExpr -> State (BlockState backend) TExpr
inst TExpr
a)
  | Bool
otherwise
  =  String -> State s Doc
forall a. HasCallStack => String -> a
error (String -> State s Doc) -> String -> State s Doc
forall a b. (a -> b) -> a -> b
$ String
"Unexpected number of arguments: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ BBHash -> String
forall a. Show a => a -> String
show ([(Expr, HWType, Bool)] -> BBHash
forall (t :: Type -> Type) a. Foldable t => t a -> BBHash
length (BlackBoxContext -> [(Expr, HWType, Bool)]
bbInputs BlackBoxContext
bbCtx))

data FCall =
  FCall
    Identifier -- left
    Identifier -- right
    Identifier -- result

-- | Calculates the number of function calls needed for an evaluation of
-- 'Clash.Sized.Vector.fold', given the length of the vector given to fold.
foldFunctionPlurality :: HasCallStack => Int -> Int
foldFunctionPlurality :: BBHash -> BBHash
foldFunctionPlurality BBHash
1 = BBHash
0
foldFunctionPlurality BBHash
2 = BBHash
1
foldFunctionPlurality BBHash
n
  | BBHash
n BBHash -> BBHash -> Bool
forall a. Ord a => a -> a -> Bool
<= BBHash
0 = String -> BBHash
forall a. HasCallStack => String -> a
error (String -> BBHash) -> String -> BBHash
forall a b. (a -> b) -> a -> b
$ String
"functionPlurality: unexpected n: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ BBHash -> String
forall a. Show a => a -> String
show BBHash
n
  | Bool
otherwise =
      let (BBHash
d, BBHash
r) = BBHash
n BBHash -> BBHash -> (BBHash, BBHash)
forall a. Integral a => a -> a -> (a, a)
`divMod` BBHash
2 in
      BBHash
1 BBHash -> BBHash -> BBHash
forall a. Num a => a -> a -> a
+ HasCallStack => BBHash -> BBHash
BBHash -> BBHash
foldFunctionPlurality BBHash
d BBHash -> BBHash -> BBHash
forall a. Num a => a -> a -> a
+ HasCallStack => BBHash -> BBHash
BBHash -> BBHash
foldFunctionPlurality (BBHash
dBBHash -> BBHash -> BBHash
forall a. Num a => a -> a -> a
+BBHash
r)

-- | Blackbox function for 'Clash.Sized.Vector.fold'
foldBBF :: HasCallStack => BlackBoxFunction
foldBBF :: BlackBoxFunction
foldBBF Bool
_isD Text
_primName [Either Term Type]
args [Type]
_resTy = do
  TyConMap
tcm <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
  Either String (BlackBoxMeta, BlackBox)
-> NetlistMonad (Either String (BlackBoxMeta, BlackBox))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((BlackBoxMeta, BlackBox) -> Either String (BlackBoxMeta, BlackBox)
forall a b. b -> Either a b
Right (TyConMap -> BlackBoxMeta
meta TyConMap
tcm, BlackBox
bb))
 where
  bb :: BlackBox
bb = String -> BBHash -> TemplateFunction -> BlackBox
BBFunction String
"Clash.Primitives.Sized.Vector.foldTF" BBHash
0 TemplateFunction
foldTF
  [Type
vecLengthMinusOne, Type
_] = [Either Term Type] -> [Type]
forall a b. [Either a b] -> [b]
rights [Either Term Type]
args
  vecLength :: TyConMap -> Integer
vecLength TyConMap
tcm =
    case TyConMap -> Type -> Type
coreView TyConMap
tcm Type
vecLengthMinusOne of
      (LitTy (NumTy Integer
n)) -> Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1
      Type
vl -> String -> Integer
forall a. HasCallStack => String -> a
error (String -> Integer) -> String -> Integer
forall a b. (a -> b) -> a -> b
$ String
"Unexpected vector length: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
vl
  funcPlural :: TyConMap -> BBHash
funcPlural TyConMap
tcm = HasCallStack => BBHash -> BBHash
BBHash -> BBHash
foldFunctionPlurality (Integer -> BBHash
forall a. Num a => Integer -> a
fromInteger (TyConMap -> Integer
vecLength TyConMap
tcm))
  meta :: TyConMap -> BlackBoxMeta
meta TyConMap
tcm = BlackBoxMeta
emptyBlackBoxMeta {bbKind :: TemplateKind
bbKind=TemplateKind
TDecl, bbFunctionPlurality :: [(BBHash, BBHash)]
bbFunctionPlurality=[(BBHash
0, TyConMap -> BBHash
funcPlural TyConMap
tcm)]}

-- | Type signature of function we're generating netlist for:
--
--   fold :: (a -> a -> a) -> Vec (n + 1) a -> a
--
-- The implementation promises to create a (balanced) tree structure.
foldTF :: TemplateFunction
foldTF :: TemplateFunction
foldTF = [BBHash]
-> (BlackBoxContext -> Bool)
-> (forall s. Backend s => BlackBoxContext -> State s Doc)
-> TemplateFunction
TemplateFunction [] (Bool -> BlackBoxContext -> Bool
forall a b. a -> b -> a
const Bool
True) forall s.
(HasCallStack, Backend s) =>
BlackBoxContext -> State s Doc
forall s. Backend s => BlackBoxContext -> State s Doc
foldTF'

foldTF' :: forall s . (HasCallStack, Backend s) => BlackBoxContext -> State s Doc
foldTF' :: BlackBoxContext -> State s Doc
foldTF' bbCtx :: BlackBoxContext
bbCtx@(BlackBoxContext -> [(Expr, HWType, Bool)]
bbInputs -> [(Expr, HWType, Bool)
_f, (Expr
vec, vecType :: HWType
vecType@(Vector BBHash
n HWType
aTy), Bool
_isLiteral)]) = do
  -- Create an id for every element in the vector
  Identifier
baseId <- Text -> StateT s Identity Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.make Text
"acc_0"
  [Identifier]
vecIds <- BBHash
-> StateT s Identity Identifier -> StateT s Identity [Identifier]
forall (m :: Type -> Type) a.
Applicative m =>
BBHash -> m a -> m [a]
replicateM BBHash
n (Identifier -> StateT s Identity Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Identifier -> m Identifier
Id.next Identifier
baseId)

  Identifier
vecId <- Text -> StateT s Identity Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.make Text
"vec"
  let vecDecl :: Declaration
vecDecl = HWType -> WireOrReg -> Identifier -> Declaration
sigDecl HWType
vecType WireOrReg
Wire Identifier
vecId
      vecAssign :: Declaration
vecAssign = Identifier -> Expr -> Declaration
Assignment Identifier
vecId Expr
vec
      elemAssigns :: [Declaration]
elemAssigns = (Identifier -> Expr -> Declaration)
-> [Identifier] -> [Expr] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Identifier -> Expr -> Declaration
Assignment [Identifier]
vecIds ((BBHash -> Expr) -> [BBHash] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier -> BBHash -> Expr
iIndex Identifier
vecId) [BBHash
0..])
      resultId :: Identifier
resultId =
        case BlackBoxContext -> [(Expr, HWType)]
bbResults BlackBoxContext
bbCtx of
          [(Identifier Identifier
t Maybe Modifier
_, HWType
_)] -> Identifier
t
          [(Expr, HWType)]
_ -> String -> Identifier
forall a. HasCallStack => String -> a
error String
"Unexpected result identifier"

  -- Create a list of function calls to be made (creates identifiers for
  -- intermediate result signals)
  ([[FCall]] -> [FCall]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat -> [FCall]
fCalls, Identifier
result) <- BBHash -> [Identifier] -> State s ([[FCall]], Identifier)
mkTree BBHash
1 [Identifier]
vecIds

  let intermediateResultIds :: [Identifier]
intermediateResultIds = (FCall -> [Identifier]) -> [FCall] -> [Identifier]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (\(FCall Identifier
l Identifier
r Identifier
_) -> [Identifier
l, Identifier
r]) [FCall]
fCalls
      wr :: WireOrReg
wr = case BBHash
-> IntMap
     [(Either BlackBox (Identifier, [Declaration]), WireOrReg,
       [[Element]], [[Element]], [((Text, Text), BlackBox)],
       BlackBoxContext)]
-> Maybe
     [(Either BlackBox (Identifier, [Declaration]), WireOrReg,
       [[Element]], [[Element]], [((Text, Text), BlackBox)],
       BlackBoxContext)]
forall a. BBHash -> IntMap a -> Maybe a
IntMap.lookup BBHash
0 (BlackBoxContext
-> IntMap
     [(Either BlackBox (Identifier, [Declaration]), WireOrReg,
       [[Element]], [[Element]], [((Text, Text), BlackBox)],
       BlackBoxContext)]
bbFunctions BlackBoxContext
bbCtx) of
             Just ((Either BlackBox (Identifier, [Declaration])
_,WireOrReg
rw,[[Element]]
_,[[Element]]
_,[((Text, Text), BlackBox)]
_,BlackBoxContext
_):[(Either BlackBox (Identifier, [Declaration]), WireOrReg,
  [[Element]], [[Element]], [((Text, Text), BlackBox)],
  BlackBoxContext)]
_) -> WireOrReg
rw
             Maybe
  [(Either BlackBox (Identifier, [Declaration]), WireOrReg,
    [[Element]], [[Element]], [((Text, Text), BlackBox)],
    BlackBoxContext)]
_ -> String -> WireOrReg
forall a. HasCallStack => String -> a
error String
"internal error"
      sigDecls :: [Declaration]
sigDecls = (WireOrReg -> Identifier -> Declaration)
-> [WireOrReg] -> [Identifier] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (HWType -> WireOrReg -> Identifier -> Declaration
sigDecl HWType
aTy) (WireOrReg
wrWireOrReg -> [WireOrReg] -> [WireOrReg]
forall a. a -> [a] -> [a]
:BBHash -> WireOrReg -> [WireOrReg]
forall a. BBHash -> a -> [a]
replicate BBHash
n WireOrReg
Wire [WireOrReg] -> [WireOrReg] -> [WireOrReg]
forall a. [a] -> [a] -> [a]
++ WireOrReg -> [WireOrReg]
forall a. a -> [a]
repeat WireOrReg
wr)
                                       (Identifier
result Identifier -> [Identifier] -> [Identifier]
forall a. a -> [a] -> [a]
: [Identifier]
intermediateResultIds)
      resultAssign :: Declaration
resultAssign = Identifier -> Expr -> Declaration
Assignment Identifier
resultId (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
result Maybe Modifier
forall a. Maybe a
Nothing)

  [Declaration]
callDecls <- (BBHash -> FCall -> StateT s Identity Declaration)
-> [BBHash] -> [FCall] -> StateT s Identity [Declaration]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM BBHash -> FCall -> StateT s Identity Declaration
callDecl [BBHash
0..] [FCall]
fCalls
  Identifier
foldNm <- Text -> StateT s Identity Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.make Text
"fold"

  Mon (State s) Doc -> State s Doc
forall (f :: Type -> Type) m. Mon f m -> f m
getMon (Mon (State s) Doc -> State s Doc)
-> Mon (State s) Doc -> State s Doc
forall a b. (a -> b) -> a -> b
$ Identifier -> [Declaration] -> Mon (State s) Doc
forall state.
Backend state =>
Identifier -> [Declaration] -> Mon (State state) Doc
blockDecl Identifier
foldNm ([Declaration] -> Mon (State s) Doc)
-> [Declaration] -> Mon (State s) Doc
forall a b. (a -> b) -> a -> b
$
    Declaration
resultAssign Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:
    Declaration
vecAssign Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:
    Declaration
vecDecl Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:
    [Declaration]
elemAssigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++
    [Declaration]
sigDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++
    [Declaration]
callDecls

 where
  callDecl :: Int -> FCall -> State s Declaration
  callDecl :: BBHash -> FCall -> StateT s Identity Declaration
callDecl BBHash
fSubPos (FCall Identifier
a Identifier
b Identifier
r) = do
    Doc
rendered0 <- Text -> State s Doc
forall (f :: Type -> Type). Applicative f => Text -> f Doc
string (Text -> State s Doc) -> StateT s Identity Text -> State s Doc
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< (BlackBoxContext -> Element -> State s (BBHash -> Text)
forall backend.
(HasCallStack, Backend backend) =>
BlackBoxContext -> Element -> State backend (BBHash -> Text)
renderElem BlackBoxContext
bbCtx Element
call State s (BBHash -> Text)
-> StateT s Identity BBHash -> StateT s Identity Text
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> BBHash -> StateT s Identity BBHash
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure BBHash
0)
    let layout :: LayoutOptions
layout = PageWidth -> LayoutOptions
LayoutOptions (BBHash -> Double -> PageWidth
AvailablePerLine BBHash
120 Double
0.4)
        rendered1 :: Text
rendered1 = SimpleDocStream () -> Text
forall ann. SimpleDocStream ann -> Text
renderLazy (LayoutOptions -> Doc -> SimpleDocStream ()
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
layout Doc
rendered0)
    Declaration -> StateT s Identity Declaration
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (
      Text
-> [[Element]]
-> [[Element]]
-> [((Text, Text), BlackBox)]
-> BlackBox
-> BlackBoxContext
-> Declaration
BlackBoxD
        Text
"__FOLD_BB_INTERNAL__"
        [] [] []
        ([Element] -> BlackBox
BBTemplate [Text -> Element
Text Text
rendered1])
        (Text -> BlackBoxContext
emptyBBContext Text
"__FOLD_BB_INTERNAL__")
        )
   where
    call :: Element
call  = Decl -> Element
Component (BBHash -> BBHash -> [([Element], [Element])] -> Decl
Decl BBHash
fPos BBHash
fSubPos (([Element], [Element])
resEl([Element], [Element])
-> [([Element], [Element])] -> [([Element], [Element])]
forall a. a -> [a] -> [a]
:([Element], [Element])
aEl([Element], [Element])
-> [([Element], [Element])] -> [([Element], [Element])]
forall a. a -> [a] -> [a]
:[([Element], [Element])
bEl]))
    elTyp :: [Element]
elTyp = [Element -> Element
TypElem (Maybe BBHash -> Element
Typ (BBHash -> Maybe BBHash
forall a. a -> Maybe a
Just BBHash
vecPos))]
    resEl :: ([Element], [Element])
resEl = ([Text -> Element
Text (Identifier -> Text
Id.toLazyText Identifier
r)], [Element]
elTyp)
    aEl :: ([Element], [Element])
aEl   = ([Text -> Element
Text (Identifier -> Text
Id.toLazyText Identifier
a)], [Element]
elTyp)
    bEl :: ([Element], [Element])
bEl   = ([Text -> Element
Text (Identifier -> Text
Id.toLazyText Identifier
b)], [Element]
elTyp)

  -- Argument no. of function
  fPos :: BBHash
fPos = BBHash
0

  -- Argument no. of vector
  vecPos :: BBHash
vecPos = BBHash
1

  -- Create the whole tree
  mkTree
    :: Int
    -- ^ Current level
    -> [Identifier]
    -- ^ Elements left to process
    -> State s ( [[FCall]]    -- function calls to be rendered
               , Identifier -- result signal
               )
  mkTree :: BBHash -> [Identifier] -> State s ([[FCall]], Identifier)
mkTree BBHash
_lvl []  = String -> State s ([[FCall]], Identifier)
forall a. HasCallStack => String -> a
error String
"Unreachable?"
  mkTree BBHash
_lvl [Identifier
res] = ([[FCall]], Identifier) -> State s ([[FCall]], Identifier)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([], Identifier
res)
  mkTree BBHash
lvl [Identifier]
results0  = do
    ([FCall]
calls0, [Identifier]
results1) <- (BBHash, BBHash) -> [Identifier] -> State s ([FCall], [Identifier])
mkLevel (BBHash
lvl, BBHash
0) [Identifier]
results0
    ([[FCall]]
calls1, Identifier
result) <- BBHash -> [Identifier] -> State s ([[FCall]], Identifier)
mkTree (BBHash
lvlBBHash -> BBHash -> BBHash
forall a. Num a => a -> a -> a
+BBHash
1) [Identifier]
results1
    ([[FCall]], Identifier) -> State s ([[FCall]], Identifier)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([FCall]
calls0 [FCall] -> [[FCall]] -> [[FCall]]
forall a. a -> [a] -> [a]
: [[FCall]]
calls1, Identifier
result)

  -- Create a single layer of a tree
  mkLevel
    :: (Int, Int)
    -- ^ (level, offset)
    -> [Identifier]
    -> State s ([FCall], [Identifier])
  mkLevel :: (BBHash, BBHash) -> [Identifier] -> State s ([FCall], [Identifier])
mkLevel (!BBHash
lvl, !BBHash
offset) (Identifier
a:Identifier
b:[Identifier]
rest) = do
    Identifier
c <- Text -> StateT s Identity Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic (Text
"acc_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BBHash -> Text
forall a. TextShow a => a -> Text
showt BBHash
lvl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BBHash -> Text
forall a. TextShow a => a -> Text
showt BBHash
offset)
    ([FCall]
calls, [Identifier]
results) <- (BBHash, BBHash) -> [Identifier] -> State s ([FCall], [Identifier])
mkLevel (BBHash
lvl, BBHash
offsetBBHash -> BBHash -> BBHash
forall a. Num a => a -> a -> a
+BBHash
1) [Identifier]
rest
    ([FCall], [Identifier]) -> State s ([FCall], [Identifier])
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Identifier -> Identifier -> Identifier -> FCall
FCall Identifier
a Identifier
b Identifier
cFCall -> [FCall] -> [FCall]
forall a. a -> [a] -> [a]
:[FCall]
calls, Identifier
cIdentifier -> [Identifier] -> [Identifier]
forall a. a -> [a] -> [a]
:[Identifier]
results)
  mkLevel (BBHash, BBHash)
_lvl [Identifier]
rest =
    ([FCall], [Identifier]) -> State s ([FCall], [Identifier])
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([], [Identifier]
rest)

  -- Simple wire without comment
  sigDecl :: HWType -> WireOrReg -> Identifier -> Declaration
  sigDecl :: HWType -> WireOrReg -> Identifier -> Declaration
sigDecl HWType
typ WireOrReg
rw Identifier
nm = Maybe Text
-> WireOrReg
-> Identifier
-> Either Text HWType
-> Maybe Expr
-> Declaration
NetDecl' Maybe Text
forall a. Maybe a
Nothing WireOrReg
rw Identifier
nm (HWType -> Either Text HWType
forall a b. b -> Either a b
Right HWType
typ) Maybe Expr
forall a. Maybe a
Nothing

  -- Index the intermediate vector. This uses a hack in Clash: the 10th
  -- constructor of Vec doesn't exist; using it will be interpreted by the
  -- HDL backends as vector indexing.
  iIndex :: Identifier -> Int -> Expr
  iIndex :: Identifier -> BBHash -> Expr
iIndex Identifier
vecId BBHash
i = Identifier -> Maybe Modifier -> Expr
Identifier Identifier
vecId (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, BBHash, BBHash) -> Modifier
Indexed (HWType
vecType, BBHash
10, BBHash
i)))

foldTF' BlackBoxContext
args =
  String -> State s Doc
forall a. HasCallStack => String -> a
error (String -> State s Doc) -> String -> State s Doc
forall a b. (a -> b) -> a -> b
$ String
"Unexpected number of arguments: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ BBHash -> String
forall a. Show a => a -> String
show ([(Expr, HWType, Bool)] -> BBHash
forall (t :: Type -> Type) a. Foldable t => t a -> BBHash
length (BlackBoxContext -> [(Expr, HWType, Bool)]
bbInputs BlackBoxContext
args))

indexIntVerilog ::  BlackBoxFunction
indexIntVerilog :: BlackBoxFunction
indexIntVerilog Bool
_isD Text
_primName [Either Term Type]
args [Type]
_ty = Either String (BlackBoxMeta, BlackBox)
-> NetlistMonad (Either String (BlackBoxMeta, BlackBox))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((BlackBoxMeta
meta,) (BlackBox -> (BlackBoxMeta, BlackBox))
-> Either String BlackBox -> Either String (BlackBoxMeta, BlackBox)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Either String BlackBox
bb)
 where
  meta :: BlackBoxMeta
meta = BlackBoxMeta
emptyBlackBoxMeta{bbKind :: TemplateKind
bbKind=TemplateKind
bbKi}

  bbKi :: TemplateKind
bbKi = case [Either Term Type]
args of
    [Either Term Type
_nTy,Either Term Type
_aTy,Either Term Type
_kn,Either Term Type
_v,Left Term
ix]
      | Term -> Bool
isLiteral Term
ix -> TemplateKind
TExpr
    [Either Term Type]
_ -> TemplateKind
TDecl

  bb :: Either String BlackBox
bb = case [Either Term Type]
args of
    [Either Term Type
_nTy,Either Term Type
_aTy,Either Term Type
_kn,Either Term Type
_v,Left Term
ix] | Term -> Bool
isLiteral Term
ix ->
      BlackBox -> Either String BlackBox
forall a b. b -> Either a b
Right (String -> BBHash -> TemplateFunction -> BlackBox
BBFunction String
"Clash.Primitives.Sized.Vector" BBHash
0 TemplateFunction
indexIntVerilogTF)
    [Either Term Type]
_ ->
      [Element] -> BlackBox
BBTemplate ([Element] -> BlackBox)
-> Either String [Element] -> Either String BlackBox
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> case Text -> Result [Element]
runParse (String -> Text
pack (String -> String
I.unindent String
bbText)) of
        Success [Element]
t -> [Element] -> Either String [Element]
forall a b. b -> Either a b
Right [Element]
t
        Result [Element]
_         -> String -> Either String [Element]
forall a b. a -> Either a b
Left String
"internal error: parse fail"

  bbText :: String
bbText = [I.i|
    // index begin
    ~IF~SIZE[~TYP[1]]~THENwire ~TYPO ~GENSYM[vecArray][0] [0:~LIT[0]-1];
    genvar ~GENSYM[i][2];
    ~GENERATE
    for (~SYM[2]=0; ~SYM[2] < ~LIT[0]; ~SYM[2]=~SYM[2]+1) begin : ~GENSYM[mk_array][3]
      assign ~SYM[0][(~LIT[0]-1)-~SYM[2]] = ~VAR[vecFlat][1][~SYM[2]*~SIZE[~TYPO]+:~SIZE[~TYPO]];
    end
    ~ENDGENERATE
    assign ~RESULT = ~SYM[0][~ARG[2]];~ELSEassign ~RESULT = ~ERRORO;~FI
    // index end|]

indexIntVerilogTF :: TemplateFunction
indexIntVerilogTF :: TemplateFunction
indexIntVerilogTF = [BBHash]
-> (BlackBoxContext -> Bool)
-> (forall s. Backend s => BlackBoxContext -> State s Doc)
-> TemplateFunction
TemplateFunction [BBHash]
used BlackBoxContext -> Bool
forall b. b -> Bool
valid forall s. Backend s => BlackBoxContext -> State s Doc
indexIntVerilogTemplate
 where
  used :: [BBHash]
used  = [BBHash
1,BBHash
2]
  valid :: b -> Bool
valid = Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
True

indexIntVerilogTemplate
  :: Backend s
  => BlackBoxContext
  -> State s Doc
indexIntVerilogTemplate :: BlackBoxContext -> State s Doc
indexIntVerilogTemplate BlackBoxContext
bbCtx = Mon (State s) Doc -> State s Doc
forall (f :: Type -> Type) m. Mon f m -> f m
getMon (Mon (State s) Doc -> State s Doc)
-> Mon (State s) Doc -> State s Doc
forall a b. (a -> b) -> a -> b
$ case HWType -> BBHash
typeSize HWType
vTy of
  BBHash
0 -> HWType -> Mon (State s) Doc
forall state. Backend state => HWType -> Mon (State state) Doc
hdlTypeErrValue HWType
rTy
  BBHash
_ -> case Expr
vec of
    Identifier Identifier
i Maybe Modifier
mM -> case Maybe Modifier
mM of
      Just Modifier
m ->
           Bool -> Expr -> Mon (State s) Doc
forall state.
Backend state =>
Bool -> Expr -> Mon (State state) Doc
expr Bool
False (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
i (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just (Modifier -> Modifier -> Modifier
Nested Modifier
m ((HWType, BBHash, BBHash) -> Modifier
Indexed (HWType
vTy,BBHash
10,Expr -> BBHash
ixI Expr
ix)))))
      Maybe Modifier
_ -> Bool -> Expr -> Mon (State s) Doc
forall state.
Backend state =>
Bool -> Expr -> Mon (State state) Doc
expr Bool
False (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
i (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, BBHash, BBHash) -> Modifier
Indexed (HWType
vTy,BBHash
10,Expr -> BBHash
ixI Expr
ix))))
    Expr
_ -> String -> Mon (State s) Doc
forall a. HasCallStack => String -> a
error ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Expected Identifier: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
vec)
 where
  [  (Expr, HWType, Bool)
_kn
   , (Expr
vec, HWType
vTy, Bool
_)
   , (Expr
ix, HWType
_, Bool
_)
   ] = BlackBoxContext -> [(Expr, HWType, Bool)]
bbInputs BlackBoxContext
bbCtx

  [(Expr
_,HWType
rTy)] = BlackBoxContext -> [(Expr, HWType)]
bbResults BlackBoxContext
bbCtx

  ixI :: Expr ->  Int
  ixI :: Expr -> BBHash
ixI Expr
ix0 = case Expr
ix0 of
    Literal Maybe (HWType, BBHash)
_ (NumLit Integer
i) ->
      Integer -> BBHash
forall a. Num a => Integer -> a
fromInteger Integer
i
    BlackBoxE Text
"GHC.Types.I#" [[Element]]
_ [[Element]]
_ [((Text, Text), BlackBox)]
_ BlackBox
_ BlackBoxContext
ixCtx Bool
_ ->
      let (Expr
ix1,HWType
_,Bool
_) = [(Expr, HWType, Bool)] -> (Expr, HWType, Bool)
forall a. [a] -> a
head (BlackBoxContext -> [(Expr, HWType, Bool)]
bbInputs BlackBoxContext
ixCtx)
      in  Expr -> BBHash
ixI Expr
ix1
    Expr
_ ->
      String -> BBHash
forall a. HasCallStack => String -> a
error ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Unexpected literal: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
ix)