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

= Efficient bundling of initial RAM content with the compiled code

Leveraging Template Haskell, the initial content for the blockRAM components in
this module is stored alongside the compiled Haskell code. It covers use cases
where passing the initial content as a 'Clash.Sized.Vector.Vec' turns out to be
problematically slow.

The data is stored efficiently, with very little overhead (worst-case 7%, often
no overhead at all).

Unlike "Clash.Explicit.BlockRam.File", "Clash.Explicit.BlockRam.Blob"
generates practically the same HDL as "Clash.Explicit.BlockRam" and is
compatible with all tools consuming the generated HDL.
-}

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeApplications #-}

{-# OPTIONS_HADDOCK show-extensions #-}

module Clash.Explicit.BlockRam.Blob
  ( -- * BlockRAMs initialized with a 'MemBlob'
    blockRamBlob
  , blockRamBlobPow2
    -- * Creating and inspecting 'MemBlob'
  , MemBlob
  , createMemBlob
  , memBlobTH
  , unpackMemBlob
    -- * Internal
  , blockRamBlob#
  ) where

import Control.Exception (catch, throw)
import Control.Monad (forM_)
import Control.Monad.ST (ST, runST)
import Control.Monad.ST.Unsafe (unsafeInterleaveST, unsafeIOToST, unsafeSTToIO)
import Data.Array.MArray (newListArray)
import qualified Data.ByteString.Lazy as L
import Data.Maybe (isJust)
import GHC.Arr (STArray, unsafeReadSTArray, unsafeWriteSTArray)
import GHC.Stack (withFrozenCallStack)
import GHC.TypeLits (KnownNat, type (^))
import Language.Haskell.TH
  (DecsQ, ExpQ, integerL, litE, litT, mkName, normalB, numTyLit, sigD,
   stringPrimL, valD, varP)

import Clash.Annotations.Primitive (hasBlackBox)
import Clash.Class.BitPack.Internal (BitPack, BitSize)
import Clash.Explicit.BlockRam.Internal
  (MemBlob(..), packBVs, unpackMemBlob, unpackMemBlob0)
import Clash.Explicit.Signal (KnownDomain, Enable, fromEnable)
import Clash.Promoted.Nat (natToInteger, natToNum)
import Clash.Signal.Bundle (unbundle)
import Clash.Signal.Internal (Clock, Signal(..), (.&&.))
import Clash.Sized.Internal.BitVector (Bit(..), BitVector(..))
import Clash.Sized.Internal.Unsigned (Unsigned)
import Clash.XException
  (maybeIsX, deepErrorX, defaultSeqX, fromJustX, XException (..), seqX)

-- $setup
-- >>> :set -XTemplateHaskell
-- >>> :set -fplugin GHC.TypeLits.Normalise
-- >>> :set -fplugin GHC.TypeLits.KnownNat.Solver
-- >>> :m -Prelude
-- >>> import Clash.Explicit.Prelude

-- | Create a blockRAM with space for @n@ elements
--
-- * __NB__: Read value is delayed by 1 cycle
-- * __NB__: Initial output value is /undefined/, reading it will throw an
-- 'Clash.XException.XException'
--
--
-- Additional helpful information:
--
-- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a
-- Block RAM.
-- * Use the adapter 'Clash.Explicit.BlockRam.readNew' for obtaining
-- write-before-read semantics like this: @'Clash.Explicit.BlockRam.readNew'
-- clk rst en ('blockRamBlob' clk en content) rd wrM@.
blockRamBlob
  :: forall dom addr m n
   . ( KnownDomain dom
     , Enum addr
     )
  => Clock dom
  -- ^ 'Clock' to synchronize to
  -> Enable dom
  -- ^ 'Enable' line
  -> MemBlob n m
  -- ^ Initial content of the RAM, also determines the size, @n@, of the RAM
  --
  -- __NB__: __MUST__ be a constant
  -> Signal dom addr
  -- ^ Read address @r@
  -> Signal dom (Maybe (addr, BitVector m))
  -- ^ (write address @w@, value to write)
  -> Signal dom (BitVector m)
  -- ^ Value of the blockRAM at address @r@ from the previous clock cycle
blockRamBlob :: Clock dom
-> Enable dom
-> MemBlob n m
-> Signal dom addr
-> Signal dom (Maybe (addr, BitVector m))
-> Signal dom (BitVector m)
blockRamBlob = \Clock dom
clk Enable dom
gen MemBlob n m
content Signal dom addr
rd Signal dom (Maybe (addr, BitVector m))
wrM ->
  let en :: Signal dom Bool
en       = Maybe (addr, BitVector m) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (addr, BitVector m) -> Bool)
-> Signal dom (Maybe (addr, BitVector m)) -> Signal dom Bool
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom (Maybe (addr, BitVector m))
wrM
      (Signal dom addr
wr,Signal dom (BitVector m)
din) = Signal dom (addr, BitVector m) -> Unbundled dom (addr, BitVector m)
forall a (dom :: Domain).
Bundle a =>
Signal dom a -> Unbundled dom a
unbundle (Maybe (addr, BitVector m) -> (addr, BitVector m)
forall a. HasCallStack => Maybe a -> a
fromJustX (Maybe (addr, BitVector m) -> (addr, BitVector m))
-> Signal dom (Maybe (addr, BitVector m))
-> Signal dom (addr, BitVector m)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom (Maybe (addr, BitVector m))
wrM)
  in Clock dom
-> Enable dom
-> MemBlob n m
-> Signal dom Int
-> Signal dom Bool
-> Signal dom Int
-> Signal dom (BitVector m)
-> Signal dom (BitVector m)
forall (dom :: Domain) (m :: Nat) (n :: Nat).
KnownDomain dom =>
Clock dom
-> Enable dom
-> MemBlob n m
-> Signal dom Int
-> Signal dom Bool
-> Signal dom Int
-> Signal dom (BitVector m)
-> Signal dom (BitVector m)
blockRamBlob# Clock dom
clk Enable dom
gen MemBlob n m
content (addr -> Int
forall a. Enum a => a -> Int
fromEnum (addr -> Int) -> Signal dom addr -> Signal dom Int
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom addr
rd) Signal dom Bool
en (addr -> Int
forall a. Enum a => a -> Int
fromEnum (addr -> Int) -> Signal dom addr -> Signal dom Int
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom addr
wr) Signal dom (BitVector m)
din
{-# INLINE blockRamBlob #-}

-- | Create a blockRAM with space for 2^@n@ elements
--
-- * __NB__: Read value is delayed by 1 cycle
-- * __NB__: Initial output value is /undefined/, reading it will throw an
-- 'XException'
--
-- Additional helpful information:
--
-- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a
-- Block RAM.
-- * Use the adapter 'Clash.Explicit.BlockRam.readNew' for obtaining
-- write-before-read semantics like this: @'Clash.Explicit.BlockRam.readNew'
-- clk rst en ('blockRamBlobPow2' clk en content) rd wrM@.
blockRamBlobPow2
  :: forall dom m n
   . ( KnownDomain dom
     , KnownNat n
     )
  => Clock dom
  -- ^ 'Clock' to synchronize to
  -> Enable dom
  -- ^ 'Enable' line
  -> MemBlob (2^n) m
  -- ^ Initial content of the RAM, also determines the size, 2^@n@, of the RAM
  --
  -- __NB__: __MUST__ be a constant
  -> Signal dom (Unsigned n)
  -- ^ Read address @r@
  -> Signal dom (Maybe (Unsigned n, BitVector m))
  -- ^ (write address @w@, value to write)
  -> Signal dom (BitVector m)
  -- ^ Value of the blockRAM at address @r@ from the previous clock cycle
blockRamBlobPow2 :: Clock dom
-> Enable dom
-> MemBlob (2 ^ n) m
-> Signal dom (Unsigned n)
-> Signal dom (Maybe (Unsigned n, BitVector m))
-> Signal dom (BitVector m)
blockRamBlobPow2 = Clock dom
-> Enable dom
-> MemBlob (2 ^ n) m
-> Signal dom (Unsigned n)
-> Signal dom (Maybe (Unsigned n, BitVector m))
-> Signal dom (BitVector m)
forall (dom :: Domain) addr (m :: Nat) (n :: Nat).
(KnownDomain dom, Enum addr) =>
Clock dom
-> Enable dom
-> MemBlob n m
-> Signal dom addr
-> Signal dom (Maybe (addr, BitVector m))
-> Signal dom (BitVector m)
blockRamBlob
{-# INLINE blockRamBlobPow2 #-}

-- | BlockRAM primitive
blockRamBlob#
  :: forall dom m n
   . KnownDomain dom
  => Clock dom
  -- ^ 'Clock' to synchronize to
  -> Enable dom
  -- ^ 'Enable' line
  -> MemBlob n m
  -- ^ Initial content of the RAM, also determines the size, @n@, of the RAM
  --
  -- __NB__: __MUST__ be a constant
  -> Signal dom Int
  -- ^ Read address @r@
  -> Signal dom Bool
  -- ^ Write enable
  -> Signal dom Int
  -- ^ Write address @w@
  -> Signal dom (BitVector m)
  -- ^ Value to write (at address @w@)
  -> Signal dom (BitVector m)
  -- ^ Value of the blockRAM at address @r@ from the previous clock cycle
blockRamBlob# :: Clock dom
-> Enable dom
-> MemBlob n m
-> Signal dom Int
-> Signal dom Bool
-> Signal dom Int
-> Signal dom (BitVector m)
-> Signal dom (BitVector m)
blockRamBlob# !Clock dom
_ Enable dom
gen content :: MemBlob n m
content@MemBlob{} = \Signal dom Int
rd Signal dom Bool
wen Signal dom Int
waS Signal dom (BitVector m)
wd -> (forall s. ST s (Signal dom (BitVector m)))
-> Signal dom (BitVector m)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Signal dom (BitVector m)))
 -> Signal dom (BitVector m))
-> (forall s. ST s (Signal dom (BitVector m)))
-> Signal dom (BitVector m)
forall a b. (a -> b) -> a -> b
$ do
  [BitVector m]
bvList <- IO [BitVector m] -> ST s [BitVector m]
forall a s. IO a -> ST s a
unsafeIOToST (MemBlob n m -> IO [BitVector m]
forall (n :: Nat) (m :: Nat). MemBlob n m -> IO [BitVector m]
unpackMemBlob0 MemBlob n m
content)
  STArray s Int (BitVector m)
ramStart <- (Int, Int) -> [BitVector m] -> ST s (STArray s Int (BitVector m))
forall (a :: Type -> Type -> Type) e (m :: Type -> Type) i.
(MArray a e m, Ix i) =>
(i, i) -> [e] -> m (a i e)
newListArray (Int
0,Int
szIInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [BitVector m]
bvList
  STArray s Int (BitVector m)
-> BitVector m
-> Signal dom Bool
-> Signal dom Int
-> Signal dom Bool
-> Signal dom Int
-> Signal dom (BitVector m)
-> ST s (Signal dom (BitVector m))
forall s.
STArray s Int (BitVector m)
-> BitVector m
-> Signal dom Bool
-> Signal dom Int
-> Signal dom Bool
-> Signal dom Int
-> Signal dom (BitVector m)
-> ST s (Signal dom (BitVector m))
go
    STArray s Int (BitVector m)
ramStart
    ((HasCallStack => BitVector m) -> BitVector m
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (String -> BitVector m
forall a. (NFDataX a, HasCallStack) => String -> a
deepErrorX String
"blockRamBlob: intial value undefined"))
    (Enable dom -> Signal dom Bool
forall (dom :: Domain). Enable dom -> Signal dom Bool
fromEnable Enable dom
gen)
    Signal dom Int
rd
    (Enable dom -> Signal dom Bool
forall (dom :: Domain). Enable dom -> Signal dom Bool
fromEnable Enable dom
gen Signal dom Bool -> Signal dom Bool -> Signal dom Bool
forall (f :: Type -> Type).
Applicative f =>
f Bool -> f Bool -> f Bool
.&&. Signal dom Bool
wen)
    Signal dom Int
waS
    Signal dom (BitVector m)
wd
 where
  szI :: Int
szI = (Num Int, KnownNat n) => Int
forall (n :: Nat) a. (Num a, KnownNat n) => a
natToNum @n @Int

  go :: STArray s Int (BitVector m) -> BitVector m -> Signal dom Bool
     -> Signal dom Int -> Signal dom Bool -> Signal dom Int
     -> Signal dom (BitVector m) -> ST s (Signal dom (BitVector m))
  go :: STArray s Int (BitVector m)
-> BitVector m
-> Signal dom Bool
-> Signal dom Int
-> Signal dom Bool
-> Signal dom Int
-> Signal dom (BitVector m)
-> ST s (Signal dom (BitVector m))
go !STArray s Int (BitVector m)
ram BitVector m
o ret :: Signal dom Bool
ret@(~(Bool
re :- Signal dom Bool
res)) rt :: Signal dom Int
rt@(~(Int
r :- Signal dom Int
rs)) et :: Signal dom Bool
et@(~(Bool
e :- Signal dom Bool
en)) wt :: Signal dom Int
wt@(~(Int
w :- Signal dom Int
wr))
     dt :: Signal dom (BitVector m)
dt@(~(BitVector m
d :- Signal dom (BitVector m)
din)) = do
    BitVector m
o BitVector m
-> ST s (Signal dom (BitVector m))
-> ST s (Signal dom (BitVector m))
forall a b. a -> b -> b
`seqX` (BitVector m
o BitVector m -> Signal dom (BitVector m) -> Signal dom (BitVector m)
forall (dom :: Domain) a. a -> Signal dom a -> Signal dom a
:-) (Signal dom (BitVector m) -> Signal dom (BitVector m))
-> ST s (Signal dom (BitVector m))
-> ST s (Signal dom (BitVector m))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Signal dom Bool
ret Signal dom Bool
-> ST s (Signal dom (BitVector m))
-> ST s (Signal dom (BitVector m))
`seq` Signal dom Int
rt Signal dom Int
-> ST s (Signal dom (BitVector m))
-> ST s (Signal dom (BitVector m))
`seq` Signal dom Bool
et Signal dom Bool
-> ST s (Signal dom (BitVector m))
-> ST s (Signal dom (BitVector m))
`seq` Signal dom Int
wt Signal dom Int
-> ST s (Signal dom (BitVector m))
-> ST s (Signal dom (BitVector m))
`seq` Signal dom (BitVector m)
dt Signal dom (BitVector m)
-> ST s (Signal dom (BitVector m))
-> ST s (Signal dom (BitVector m))
`seq`
      ST s (Signal dom (BitVector m)) -> ST s (Signal dom (BitVector m))
forall s a. ST s a -> ST s a
unsafeInterleaveST
        (do BitVector m
o' <- IO (BitVector m) -> ST s (BitVector m)
forall a s. IO a -> ST s a
unsafeIOToST
                    (IO (BitVector m)
-> (XException -> IO (BitVector m)) -> IO (BitVector m)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (if Bool
re then ST s (BitVector m) -> IO (BitVector m)
forall s a. ST s a -> IO a
unsafeSTToIO (STArray s Int (BitVector m)
ram STArray s Int (BitVector m) -> Int -> ST s (BitVector m)
forall s. STArray s Int (BitVector m) -> Int -> ST s (BitVector m)
`safeAt` Int
r) else BitVector m -> IO (BitVector m)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure BitVector m
o)
                    (\err :: XException
err@XException {} -> BitVector m -> IO (BitVector m)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (XException -> BitVector m
forall a e. Exception e => e -> a
throw XException
err)))
            BitVector m
d BitVector m -> ST s () -> ST s ()
forall a b. NFDataX a => a -> b -> b
`defaultSeqX` STArray s Int (BitVector m)
-> Bool -> Int -> BitVector m -> ST s ()
forall s.
STArray s Int (BitVector m)
-> Bool -> Int -> BitVector m -> ST s ()
upd STArray s Int (BitVector m)
ram Bool
e Int
w BitVector m
d
            STArray s Int (BitVector m)
-> BitVector m
-> Signal dom Bool
-> Signal dom Int
-> Signal dom Bool
-> Signal dom Int
-> Signal dom (BitVector m)
-> ST s (Signal dom (BitVector m))
forall s.
STArray s Int (BitVector m)
-> BitVector m
-> Signal dom Bool
-> Signal dom Int
-> Signal dom Bool
-> Signal dom Int
-> Signal dom (BitVector m)
-> ST s (Signal dom (BitVector m))
go STArray s Int (BitVector m)
ram BitVector m
o' Signal dom Bool
res Signal dom Int
rs Signal dom Bool
en Signal dom Int
wr Signal dom (BitVector m)
din))

  upd :: STArray s Int (BitVector m) -> Bool -> Int -> BitVector m -> ST s ()
  upd :: STArray s Int (BitVector m)
-> Bool -> Int -> BitVector m -> ST s ()
upd STArray s Int (BitVector m)
ram Bool
we Int
waddr BitVector m
d = case Bool -> Maybe Bool
forall a. a -> Maybe a
maybeIsX Bool
we of
    Maybe Bool
Nothing -> case Int -> Maybe Int
forall a. a -> Maybe a
maybeIsX Int
waddr of
      Maybe Int
Nothing -> -- Put the XException from `waddr` as the value in all
                 -- locations of `ram`.
                 [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..(Int
szIInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)] (\Int
i -> STArray s Int (BitVector m) -> Int -> BitVector m -> ST s ()
forall s i e. STArray s i e -> Int -> e -> ST s ()
unsafeWriteSTArray STArray s Int (BitVector m)
ram Int
i (Int -> BitVector m -> BitVector m
seq Int
waddr BitVector m
d))
      Just Int
wa -> -- Put the XException from `we` as the value at address
                 -- `waddr`.
                 Int -> BitVector m -> STArray s Int (BitVector m) -> ST s ()
forall s.
Int -> BitVector m -> STArray s Int (BitVector m) -> ST s ()
safeUpdate Int
wa (Bool -> BitVector m -> BitVector m
seq Bool
we BitVector m
d) STArray s Int (BitVector m)
ram
    Just Bool
True -> case Int -> Maybe Int
forall a. a -> Maybe a
maybeIsX Int
waddr of
      Maybe Int
Nothing -> -- Put the XException from `waddr` as the value in all
                 -- locations of `ram`.
                 [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..(Int
szIInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)] (\Int
i -> STArray s Int (BitVector m) -> Int -> BitVector m -> ST s ()
forall s i e. STArray s i e -> Int -> e -> ST s ()
unsafeWriteSTArray STArray s Int (BitVector m)
ram Int
i (Int -> BitVector m -> BitVector m
seq Int
waddr BitVector m
d))
      Just Int
wa -> Int -> BitVector m -> STArray s Int (BitVector m) -> ST s ()
forall s.
Int -> BitVector m -> STArray s Int (BitVector m) -> ST s ()
safeUpdate Int
wa BitVector m
d STArray s Int (BitVector m)
ram
    Maybe Bool
_ -> () -> ST s ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

  safeAt :: STArray s Int (BitVector m) -> Int -> ST s (BitVector m)
  safeAt :: STArray s Int (BitVector m) -> Int -> ST s (BitVector m)
safeAt STArray s Int (BitVector m)
s Int
i =
    if (Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i) Bool -> Bool -> Bool
&& (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
szI) then
      STArray s Int (BitVector m) -> Int -> ST s (BitVector m)
forall s i e. STArray s i e -> Int -> ST s e
unsafeReadSTArray STArray s Int (BitVector m)
s Int
i
    else BitVector m -> ST s (BitVector m)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (BitVector m -> ST s (BitVector m))
-> BitVector m -> ST s (BitVector m)
forall a b. (a -> b) -> a -> b
$
      (HasCallStack => BitVector m) -> BitVector m
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack
        (String -> BitVector m
forall a. (NFDataX a, HasCallStack) => String -> a
deepErrorX (String
"blockRamBlob: read address " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
                     String
" not in range [0.." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
szI String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"))
  {-# INLINE safeAt #-}

  safeUpdate :: Int -> BitVector m -> STArray s Int (BitVector m) -> ST s ()
  safeUpdate :: Int -> BitVector m -> STArray s Int (BitVector m) -> ST s ()
safeUpdate Int
i BitVector m
a STArray s Int (BitVector m)
s =
    if (Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i) Bool -> Bool -> Bool
&& (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
szI) then
      STArray s Int (BitVector m) -> Int -> BitVector m -> ST s ()
forall s i e. STArray s i e -> Int -> e -> ST s ()
unsafeWriteSTArray STArray s Int (BitVector m)
s Int
i BitVector m
a
    else
      let d :: BitVector m
d = (HasCallStack => BitVector m) -> BitVector m
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack
                (String -> BitVector m
forall a. (NFDataX a, HasCallStack) => String -> a
deepErrorX (String
"blockRam: write address " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
                             String
" not in range [0.." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
szI String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"))
       in [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..(Int
szIInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)] (\Int
j -> STArray s Int (BitVector m) -> Int -> BitVector m -> ST s ()
forall s i e. STArray s i e -> Int -> e -> ST s ()
unsafeWriteSTArray STArray s Int (BitVector m)
s Int
j BitVector m
d)
  {-# INLINE safeUpdate #-}
{-# ANN blockRamBlob# hasBlackBox #-}
{-# NOINLINE blockRamBlob# #-}

-- | Create a 'MemBlob' binding from a list of values
--
-- Since this uses Template Haskell, nothing in the arguments given to
-- 'createMemBlob' can refer to something defined in the same module.
--
-- === __Example__
--
-- @
-- 'createMemBlob' "content" 'Nothing' [15 :: Unsigned 8 .. 17]
--
-- ram clk en = 'blockRamBlob' clk en content
-- @
--
-- The 'Data.Maybe.Maybe' datatype has don't care bits, where the actual value
-- does not matter. But the bits need a defined value in the memory. Either 0 or
-- 1 can be used, and both are valid representations of the data.
--
-- >>> import qualified Prelude as P
-- >>> let es = [ Nothing, Just (7 :: Unsigned 8), Just 8 ]
-- >>> :{
-- createMemBlob "content0" (Just 0) es
-- createMemBlob "content1" (Just 1) es
-- x = 1
-- :}
--
-- >>> let pr = mapM_ (putStrLn . show)
-- >>> pr $ P.map pack es
-- 0b0_...._....
-- 0b1_0000_0111
-- 0b1_0000_1000
-- >>> pr $ unpackMemBlob content0
-- 0b0_0000_0000
-- 0b1_0000_0111
-- 0b1_0000_1000
-- >>> pr $ unpackMemBlob content1
-- 0b0_1111_1111
-- 0b1_0000_0111
-- 0b1_0000_1000
-- >>> :{
-- createMemBlob "contentN" Nothing es
-- x = 1
-- :}
-- <BLANKLINE>
-- <interactive>:...: error:
--     packBVs: cannot convert don't care values. Please specify a mapping to a definite value.
--
-- Note how we hinted to @clashi@ that our multi-line command was a list of
-- declarations by including a dummy declaration @x = 1@. Without this trick,
-- @clashi@ would expect an expression and the Template Haskell would not work.
createMemBlob
  :: forall a f
   . ( Foldable f
     , BitPack a
     )
  => String
  -- ^ Name of the binding to generate
  -> Maybe Bit
  -- ^ Value to map don't care bits to. 'Nothing' means throwing an error on
  -- don't care bits.
  -> f a
  -- ^ The content for the 'MemBlob'
  -> DecsQ
createMemBlob :: String -> Maybe Bit -> f a -> DecsQ
createMemBlob String
name Maybe Bit
care f a
es =
  case Either String (Int, ByteString, ByteString)
packed of
    Left String
err -> String -> DecsQ
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
err
    Right (Int, ByteString, ByteString)
_ -> [Q Dec] -> DecsQ
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
      [ Name -> TypeQ -> Q Dec
sigD Name
name0 [t| MemBlob $(n) $(m) |]
      , PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
name0) (ExpQ -> BodyQ
normalB [| MemBlob { memBlobRunsLen = $(runsLen)
                                              , memBlobRuns = $(runs)
                                              , memBlobEndsLen = $(endsLen)
                                              , memBlobEnds = $(ends)
                                              } |]) []
      ]
 where
  name0 :: Name
name0 = String -> Name
mkName String
name
  n :: TypeQ
n = TyLitQ -> TypeQ
litT (TyLitQ -> TypeQ) -> (Int -> TyLitQ) -> Int -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> TyLitQ
numTyLit (Integer -> TyLitQ) -> (Int -> Integer) -> Int -> TyLitQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> TypeQ) -> Int -> TypeQ
forall a b. (a -> b) -> a -> b
$ Int
len
  m :: TypeQ
m = TyLitQ -> TypeQ
litT (TyLitQ -> TypeQ) -> (Integer -> TyLitQ) -> Integer -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> TyLitQ
numTyLit (Integer -> TypeQ) -> Integer -> TypeQ
forall a b. (a -> b) -> a -> b
$ KnownNat (BitSize a) => Integer
forall (n :: Nat). KnownNat n => Integer
natToInteger @(BitSize a)
  runsLen :: ExpQ
runsLen = Lit -> ExpQ
litE (Lit -> ExpQ) -> (Int64 -> Lit) -> Int64 -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
integerL (Integer -> Lit) -> (Int64 -> Integer) -> Int64 -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64 -> ExpQ) -> Int64 -> ExpQ
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
L.length ByteString
runsB
  runs :: ExpQ
runs = Lit -> ExpQ
litE (Lit -> ExpQ) -> ([Word8] -> Lit) -> [Word8] -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> Lit
stringPrimL ([Word8] -> ExpQ) -> [Word8] -> ExpQ
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
L.unpack ByteString
runsB
  endsLen :: ExpQ
endsLen = Lit -> ExpQ
litE (Lit -> ExpQ) -> (Int64 -> Lit) -> Int64 -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
integerL (Integer -> Lit) -> (Int64 -> Integer) -> Int64 -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64 -> ExpQ) -> Int64 -> ExpQ
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
L.length ByteString
endsB
  ends :: ExpQ
ends = Lit -> ExpQ
litE (Lit -> ExpQ) -> ([Word8] -> Lit) -> [Word8] -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> Lit
stringPrimL ([Word8] -> ExpQ) -> [Word8] -> ExpQ
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
L.unpack ByteString
endsB
  Right (Int
len, ByteString
runsB, ByteString
endsB) = Either String (Int, ByteString, ByteString)
packed
  packed :: Either String (Int, ByteString, ByteString)
packed = Maybe Bit -> f a -> Either String (Int, ByteString, ByteString)
forall a (f :: Type -> Type).
(Foldable f, BitPack a) =>
Maybe Bit -> f a -> Either String (Int, ByteString, ByteString)
packBVs Maybe Bit
care f a
es

-- | Create a 'MemBlob' from a list of values
--
-- Since this uses Template Haskell, nothing in the arguments given to
-- 'memBlobTH' can refer to something defined in the same module.
--
-- === __Example__
--
-- @
-- ram clk en = 'blockRamBlob' clk en $(memBlobTH Nothing [15 :: Unsigned 8 .. 17])
-- @
--
-- The 'Data.Maybe.Maybe' datatype has don't care bits, where the actual value
-- does not matter. But the bits need a defined value in the memory. Either 0 or
-- 1 can be used, and both are valid representations of the data.
--
-- >>> import qualified Prelude as P
-- >>> let es = [ Nothing, Just (7 :: Unsigned 8), Just 8 ]
-- >>> content0 = $(memBlobTH (Just 0) es)
-- >>> content1 = $(memBlobTH (Just 1) es)
-- >>> let pr = mapM_ (putStrLn . show)
-- >>> pr $ P.map pack es
-- 0b0_...._....
-- 0b1_0000_0111
-- 0b1_0000_1000
-- >>> pr $ unpackMemBlob content0
-- 0b0_0000_0000
-- 0b1_0000_0111
-- 0b1_0000_1000
-- >>> pr $ unpackMemBlob content1
-- 0b0_1111_1111
-- 0b1_0000_0111
-- 0b1_0000_1000
-- >>> $(memBlobTH Nothing es)
-- <BLANKLINE>
-- <interactive>:...: error:
--     • packBVs: cannot convert don't care values. Please specify a mapping to a definite value.
--     • In the untyped splice: $(memBlobTH Nothing es)
memBlobTH
  :: forall a f
   . ( Foldable f
     , BitPack a
     )
  => Maybe Bit
  -- ^ Value to map don't care bits to. 'Nothing' means throwing an error on
  -- don't care bits.
  -> f a
  -- ^ The content for the 'MemBlob'
  -> ExpQ
memBlobTH :: Maybe Bit -> f a -> ExpQ
memBlobTH Maybe Bit
care f a
es =
  case Either String (Int, ByteString, ByteString)
packed of
    Left String
err -> String -> ExpQ
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
err
    Right (Int, ByteString, ByteString)
_ -> [| MemBlob { memBlobRunsLen = $(runsLen)
                          , memBlobRuns = $(runs)
                          , memBlobEndsLen = $(endsLen)
                          , memBlobEnds = $(ends)
                          }
                    :: MemBlob $(n) $(m) |]
 where
  n :: TypeQ
n = TyLitQ -> TypeQ
litT (TyLitQ -> TypeQ) -> (Int -> TyLitQ) -> Int -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> TyLitQ
numTyLit (Integer -> TyLitQ) -> (Int -> Integer) -> Int -> TyLitQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> TypeQ) -> Int -> TypeQ
forall a b. (a -> b) -> a -> b
$ Int
len
  m :: TypeQ
m = TyLitQ -> TypeQ
litT (TyLitQ -> TypeQ) -> (Integer -> TyLitQ) -> Integer -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> TyLitQ
numTyLit (Integer -> TypeQ) -> Integer -> TypeQ
forall a b. (a -> b) -> a -> b
$ KnownNat (BitSize a) => Integer
forall (n :: Nat). KnownNat n => Integer
natToInteger @(BitSize a)
  runsLen :: ExpQ
runsLen = Lit -> ExpQ
litE (Lit -> ExpQ) -> (Int64 -> Lit) -> Int64 -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
integerL (Integer -> Lit) -> (Int64 -> Integer) -> Int64 -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64 -> ExpQ) -> Int64 -> ExpQ
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
L.length ByteString
runsB
  runs :: ExpQ
runs = Lit -> ExpQ
litE (Lit -> ExpQ) -> ([Word8] -> Lit) -> [Word8] -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> Lit
stringPrimL ([Word8] -> ExpQ) -> [Word8] -> ExpQ
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
L.unpack ByteString
runsB
  endsLen :: ExpQ
endsLen = Lit -> ExpQ
litE (Lit -> ExpQ) -> (Int64 -> Lit) -> Int64 -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
integerL (Integer -> Lit) -> (Int64 -> Integer) -> Int64 -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64 -> ExpQ) -> Int64 -> ExpQ
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
L.length ByteString
endsB
  ends :: ExpQ
ends = Lit -> ExpQ
litE (Lit -> ExpQ) -> ([Word8] -> Lit) -> [Word8] -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> Lit
stringPrimL ([Word8] -> ExpQ) -> [Word8] -> ExpQ
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
L.unpack ByteString
endsB
  Right (Int
len, ByteString
runsB, ByteString
endsB) = Either String (Int, ByteString, ByteString)
packed
  packed :: Either String (Int, ByteString, ByteString)
packed = Maybe Bit -> f a -> Either String (Int, ByteString, ByteString)
forall a (f :: Type -> Type).
(Foldable f, BitPack a) =>
Maybe Bit -> f a -> Either String (Int, ByteString, ByteString)
packBVs Maybe Bit
care f a
es