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

= Efficient bundling of ROM content with the compiled code

Leveraging Template Haskell, the content for the ROM 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.ROM.File", "Clash.Explicit.ROM.Blob" generates
practically the same HDL as "Clash.Explicit.ROM" and is compatible with all
tools consuming the generated HDL.
-}

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE Trustworthy #-}

{-# OPTIONS_HADDOCK show-extensions #-}

module Clash.Explicit.ROM.Blob
  ( -- * ROMs defined by a 'MemBlob'
    romBlob
  , romBlobPow2
    -- * Creating and inspecting 'MemBlob'
  , MemBlob
  , createMemBlob
  , memBlobTH
  , unpackMemBlob
    -- * Internal
  , romBlob#
  ) where

import Data.Array (listArray)
import Data.Array.Base (unsafeAt)
import GHC.Stack (withFrozenCallStack)
import GHC.TypeLits (KnownNat, type (^))

import Clash.Annotations.Primitive (hasBlackBox)
import Clash.Explicit.BlockRam.Blob (createMemBlob, memBlobTH)
import Clash.Explicit.BlockRam.Internal (MemBlob(..), unpackMemBlob)
import Clash.Promoted.Nat (natToNum)
import Clash.Signal.Internal
  (Clock (..), KnownDomain, Signal (..), Enable, fromEnable)
import Clash.Sized.Internal.BitVector (BitVector)
import Clash.Sized.Internal.Unsigned (Unsigned)
import Clash.XException (deepErrorX, seqX)

-- | A ROM with a synchronous read port, 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.Sized.Fixed#creatingdatafiles" and
-- "Clash.Explicit.BlockRam#usingrams" for ideas on how to use ROMs and RAMs
romBlob
  :: forall dom addr m n
   . ( KnownDomain dom
     , Enum addr
     )
  => Clock dom
  -- ^ 'Clock' to synchronize to
  -> Enable dom
  -- ^ 'Enable' line
  -> MemBlob n m
  -- ^ ROM content, also determines the size, @n@, of the ROM
  --
  -- __NB__: __MUST__ be a constant
  -> Signal dom addr
  -- ^ Read address @r@
  -> Signal dom (BitVector m)
  -- ^ The value of the ROM at address @r@ from the previous clock cycle
romBlob :: Clock dom
-> Enable dom
-> MemBlob n m
-> Signal dom addr
-> Signal dom (BitVector m)
romBlob = \Clock dom
clk Enable dom
en MemBlob n m
content Signal dom addr
rd -> Clock dom
-> Enable dom
-> MemBlob n m
-> Signal dom Int
-> 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 (BitVector m)
romBlob# Clock dom
clk Enable dom
en 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)
{-# INLINE romBlob #-}

-- | A ROM with a synchronous read port, 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
-- 'Clash.XException.XException'
--
-- Additional helpful information:
--
-- * See "Clash.Sized.Fixed#creatingdatafiles" and
-- "Clash.Explicit.BlockRam#usingrams" for ideas on how to use ROMs and RAMs
romBlobPow2
  :: forall dom m n
   . ( KnownDomain dom
     , KnownNat n
     )
  => Clock dom
  -- ^ 'Clock' to synchronize to
  -> Enable dom
  -- ^ 'Enable' line
  -> MemBlob (2^n) m
  -- ^ ROM content, also determines the size, 2^@n@, of the ROM
  --
  -- __NB__: __MUST__ be a constant
  -> Signal dom (Unsigned n)
  -- ^ Read address @r@
  -> Signal dom (BitVector m)
  -- ^ The value of the ROM at address @r@ from the previous clock cycle
romBlobPow2 :: Clock dom
-> Enable dom
-> MemBlob (2 ^ n) m
-> Signal dom (Unsigned n)
-> Signal dom (BitVector m)
romBlobPow2 = Clock dom
-> Enable dom
-> MemBlob (2 ^ n) m
-> Signal dom (Unsigned n)
-> 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 (BitVector m)
romBlob
{-# INLINE romBlobPow2 #-}

-- | ROM primitive
romBlob#
  :: forall dom m n
   . KnownDomain dom
  => Clock dom
  -- ^ 'Clock' to synchronize to
  -> Enable dom
  -- ^ 'Enable' line
  -> MemBlob n m
  -- ^ ROM content, also determines the size, @n@, of the ROM
  --
  -- __NB__: __MUST__ be a constant
  -> Signal dom Int
  -- ^ Read address @r@
  -> Signal dom (BitVector m)
  -- ^ The value of the ROM at address @r@ from the previous clock cycle
romBlob# :: Clock dom
-> Enable dom
-> MemBlob n m
-> Signal dom Int
-> Signal dom (BitVector m)
romBlob# !Clock dom
_ Enable dom
en content :: MemBlob n m
content@MemBlob{} =
  BitVector m
-> Signal dom Bool -> Signal dom Int -> Signal dom (BitVector m)
forall (dom :: Domain) (dom :: Domain) (dom :: Domain).
BitVector m
-> Signal dom Bool -> Signal dom Int -> Signal dom (BitVector m)
go
    ((HasCallStack => BitVector m) -> BitVector m
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (String -> BitVector m
forall a. (NFDataX a, HasCallStack) => String -> a
deepErrorX String
"romBlob: initial value undefined"))
    (Enable dom -> Signal dom Bool
forall (dom :: Domain). Enable dom -> Signal dom Bool
fromEnable Enable dom
en)
 where
  szI :: Int
szI = (Num Int, KnownNat n) => Int
forall (n :: Nat) a. (Num a, KnownNat n) => a
natToNum @n @Int
  arr :: Array Int (BitVector m)
arr = (Int, Int) -> [BitVector m] -> Array Int (BitVector m)
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
szIInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) ([BitVector m] -> Array Int (BitVector m))
-> [BitVector m] -> Array Int (BitVector m)
forall a b. (a -> b) -> a -> b
$ MemBlob n m -> [BitVector m]
forall (n :: Nat) (m :: Nat). MemBlob n m -> [BitVector m]
unpackMemBlob MemBlob n m
content

  go :: BitVector m
-> Signal dom Bool -> Signal dom Int -> Signal dom (BitVector m)
go BitVector m
o (Bool
e :- Signal dom Bool
es) rd :: Signal dom Int
rd@(~(Int
r :- Signal dom Int
rs)) =
    let o1 :: BitVector m
o1 = if Bool
e then Int -> BitVector m
safeAt Int
r else BitVector m
o
    -- See [Note: register strictness annotations]
    in  BitVector m
o BitVector m -> Signal dom (BitVector m) -> 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 Int
rd Signal dom Int
-> Signal dom (BitVector m) -> Signal dom (BitVector m)
`seq` BitVector m
-> Signal dom Bool -> Signal dom Int -> Signal dom (BitVector m)
go BitVector m
o1 Signal dom Bool
es Signal dom Int
rs)

  safeAt :: Int -> BitVector m
  safeAt :: Int -> BitVector m
safeAt 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
      Array Int (BitVector m) -> Int -> BitVector m
forall (a :: Type -> Type -> Type) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
unsafeAt Array Int (BitVector m)
arr Int
i
    else
      (HasCallStack => BitVector m) -> BitVector m
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack
        (String -> BitVector m
forall a. (NFDataX a, HasCallStack) => String -> a
deepErrorX (String
"romBlob: address " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++
                     String
" not in range [0.." String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
szI String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"))
  {-# INLINE safeAt #-}
{-# NOINLINE romBlob# #-}
{-# ANN romBlob# hasBlackBox #-}