{- |
Copyright  :  (C) 2018, Google Inc.
                  2019, Myrtle Software Ltd
                  2022-2026, QBayLogic B.V.
License    :  BSD2 (see the file LICENSE)
Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>

Utilities for tracing signals and dumping them in various ways. Example usage:

@
import Clash.Prelude hiding (writeFile)
import Data.Text.IO  (writeFile)
import Clash.Shockwaves
import qualified Clash.Shockwaves.Trace as T

-- | Count and wrap around
subCounter :: SystemClockResetEnable => Signal System (Index 3)
subCounter = T.traceSignal1 "sub" counter
  where
    counter =
      register 0 (fmap succ' counter)

    succ' c
      | c == maxBound = 0
      | otherwise     = c + 1

-- | Count, but only when my subcounter is wrapping around
mainCounter :: SystemClockResetEnable => Signal System (Signed 64)
mainCounter = T.traceSignal1 "main" counter
  where
    counter =
      register 0 (fmap succ' $ bundle (subCounter,counter))

    succ' (sc, c)
      | sc == maxBound = c + 1
      | otherwise      = c

-- | Collect traces, and dump them to a VCD file.
main :: IO ()
main = do
  let cntrOut = exposeClockResetEnable mainCounter systemClockGen systemResetGen enableGen
  vcd <- T.dumpVCD (0, 100) cntrOut ["main", "sub"]
  case vcd of
    Left msg ->
      error msg
    Right (contents,meta) -> do
      writeFile     "mainCounter.vcd"  contents
      writeFileJSON "mainCounter.json" meta
@
-}

-- adapted from Clash.Signal.Trace

{- FOURMOLU_DISABLE -}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MagicHash #-}

{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise       #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

module Clash.Shockwaves.Trace
  (
  -- * Tracing functions
  -- ** Simple
    traceSignal1
  , traceVecSignal1
  -- ** Tracing in a multi-clock environment
  , traceSignal
  , traceVecSignal

  -- * VCD dump functions
  , dumpVCD

  -- * Replay functions
  , dumpReplayable
  , replay

  -- * Internal
  -- ** Types
  , Period
  , Changed
  , Value
  , Width
  , Maps
  , TraceMap
  , TypeRepBS
  , JSON
  , AddValue
  -- ** Functions
  , traceSignal#
  , traceVecSignal#
  , dumpVCD#
  , dumpVCD##
  , waitForTraces#
  , maps#
  ) where

import           Prelude

-- Clash:
import           Clash.Magic           (clashSimulation)
import           Clash.Signal.Internal (fromList)
import           Clash.Signal
  (KnownDomain(..), SDomainConfiguration(..), Signal, bundle, unbundle)
import           Clash.Sized.Vector    (Vec, iterateI)
import qualified Clash.Sized.Vector    as Vector
import           Clash.Class.BitPack   (BitPack, BitSize, pack, unpack)
import           Clash.Promoted.Nat    (snatToNum, SNat(..))
import           Clash.Signal.Internal (Signal ((:-)), sample)
import           Clash.XException      (deepseqX, NFDataX)
import           Clash.Sized.Internal.BitVector
  (BitVector(BV))

-- Haskell / GHC:
import           Control.Monad         (foldM)
import           Data.Bits             (testBit)
import           Data.Binary           (encode, decodeOrFail)
import           Data.ByteString.Lazy  (ByteString)
import qualified Data.ByteString.Lazy  as ByteStringLazy
import           Data.Char             (ord, chr)
import           Data.IORef
  (IORef, atomicModifyIORef', atomicWriteIORef, newIORef, readIORef)
#if !MIN_VERSION_base(4,20,0)
import           Data.List             (foldl')
#endif
import           Data.List             (foldl1', unzip5, transpose, uncons)
import qualified Data.Map              as M
import qualified Data.Map.Strict       as Map
import           Data.Maybe            (fromMaybe, catMaybes)
import qualified Data.Text             as Text
import           Data.Default          (Default(..))
import           Data.Time.Clock       (UTCTime, getCurrentTime)
import           Data.Time.Format      (formatTime, defaultTimeLocale)
import           GHC.Natural           (Natural)
import           GHC.Stack             (HasCallStack)
import           GHC.TypeLits          (KnownNat, type (+))
import           GHC.Generics          (Generic)
import           System.IO.Unsafe      (unsafePerformIO)
import           Type.Reflection       (Typeable, TypeRep, typeRep)
import qualified Data.Aeson as Json
import           Data.Aeson            ((.=))

import           GHC.Conc              (pseq)

-- Shockwaves
import           Clash.Shockwaves.Internal.Types hiding (Value)
import           Clash.Shockwaves.Internal.Translator (getStaticLuts)
import           Clash.Shockwaves.Internal.Waveform hiding (width)

#ifdef CABAL
import           Data.Version          (showVersion)
import qualified Paths_clash_shockwaves
#endif

-- | A clock period in _ns_.
type Period   = Int
type Changed  = Bool
type Value    = (Natural, Natural) -- (Mask, Value)
type Width    = Int

-- | Serialized TypeRep we need to store for dumpReplayable / replay
type TypeRepBS = ByteString

-- | A function that adds one or more values to a 'LUTMap'.
type AddValue = LUTMap -> LUTMap
-- | A map of traces.
type TraceMap = Map.Map String (TypeRepBS, Period, Width, [AddValue], [Value])
-- | A map of all traces and Shockwaves tables.
data Maps     = Maps{Maps -> SignalMap
signalMap::SignalMap,Maps -> TypeMap
typeMap::TypeMap,Maps -> TraceMap
traceMap::TraceMap}
  deriving ((forall x. Maps -> Rep Maps x)
-> (forall x. Rep Maps x -> Maps) -> Generic Maps
forall x. Rep Maps x -> Maps
forall x. Maps -> Rep Maps x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Maps -> Rep Maps x
from :: forall x. Maps -> Rep Maps x
$cto :: forall x. Rep Maps x -> Maps
to :: forall x. Rep Maps x -> Maps
Generic,Maps
Maps -> Default Maps
forall a. a -> Default a
$cdef :: Maps
def :: Maps
Default)

-- | An alias for JSON data.
type JSON = Json.Value

-- | Run function on signal only in simulation
simOnly :: (s->s) -> s -> s
simOnly :: forall s. (s -> s) -> s -> s
simOnly s -> s
f s
sig = if Bool
clashSimulation then
    s -> s
f s
sig
  else s
sig


-- | Check if a signal name already occurs in the trace map.
checkUniqueTrace :: SignalName -> Maps -> Maps
checkUniqueTrace :: [Char] -> Maps -> Maps
checkUniqueTrace [Char]
name m :: Maps
m@Maps{TraceMap
traceMap :: Maps -> TraceMap
traceMap :: TraceMap
traceMap} =
  if [Char] -> TraceMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member [Char]
name TraceMap
traceMap then
    [Char] -> Maps
forall a. HasCallStack => [Char] -> a
error ([Char] -> Maps) -> [Char] -> Maps
forall a b. (a -> b) -> a -> b
$ [Char]
"Already tracing a signal with the name: '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'."
  else
    Maps
m

-- | Add a signal's type to the signal map, and the type's translator to the type map.
addSignal :: forall a. Waveform a => SignalName -> Maps -> Maps
addSignal :: forall a. Waveform a => [Char] -> Maps -> Maps
addSignal [Char]
name m :: Maps
m@Maps{SignalMap
signalMap :: Maps -> SignalMap
signalMap :: SignalMap
signalMap,TypeMap
typeMap :: Maps -> TypeMap
typeMap :: TypeMap
typeMap} =
  if [Char] -> SignalMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member [Char]
name SignalMap
signalMap then
    [Char] -> Maps
forall a. HasCallStack => [Char] -> a
error ([Char] -> Maps) -> [Char] -> Maps
forall a b. (a -> b) -> a -> b
$ [Char]
"Already tracing a signal with the name: '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'."
  else
    Maps
m{signalMap = Map.insert name (typeName @a) signalMap
    , typeMap = addTypes @a typeMap }


-- | Map of traces used by the non-internal trace and dumpvcd functions.
maps# :: IORef Maps
maps# :: IORef Maps
maps# = IO (IORef Maps) -> IORef Maps
forall a. IO a -> a
unsafePerformIO (IO (IORef Maps) -> IORef Maps) -> IO (IORef Maps) -> IORef Maps
forall a b. (a -> b) -> a -> b
$ Maps -> IO (IORef Maps)
forall a. a -> IO (IORef a)
newIORef Maps
forall a. Default a => a
def
-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# OPAQUE maps# #-}

mkTrace
  :: HasCallStack
  => BitPack a
  => NFDataX a
  => Signal dom a
  -> [Value]
mkTrace :: forall a (dom :: Symbol).
(HasCallStack, BitPack a, NFDataX a) =>
Signal dom a -> [Value]
mkTrace Signal dom a
signal = Signal dom Value -> [Value]
forall (f :: Type -> Type) a. (Foldable f, NFDataX a) => f a -> [a]
sample (BitVector (BitSize a) -> Value
forall {n :: Natural}. BitVector n -> Value
unsafeToTup (BitVector (BitSize a) -> Value)
-> (a -> BitVector (BitSize a)) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> BitVector (BitSize a)
forall a. BitPack a => a -> BitVector (BitSize a)
pack (a -> Value) -> Signal dom a -> Signal dom Value
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom a
signal)
 where
  unsafeToTup :: BitVector n -> Value
unsafeToTup (BV Natural
mask Natural
value) = (Natural
mask, Natural
value)

-- | Trace a single signal. Will emit an error if a signal with the same name
-- was previously registered.
traceSignal#
  :: forall dom a
   . ( BitPack a
     , NFDataX a
     , Typeable a
     , Waveform a )
  => IORef Maps
  -- ^ Map to store the trace
  -> Int
  -- ^ The associated clock period for the trace
  -> String
  -- ^ Name of signal in the VCD output
  -> Signal dom a
  -- ^ Signal to trace
  -> IO (Signal dom a)
traceSignal# :: forall (dom :: Symbol) a.
(BitPack a, NFDataX a, Typeable a, Waveform a) =>
IORef Maps -> Int -> [Char] -> Signal dom a -> IO (Signal dom a)
traceSignal# IORef Maps
maps Int
period [Char]
traceName Signal dom a
signal =
  IORef Maps -> (Maps -> (Maps, Signal dom a)) -> IO (Signal dom a)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Maps
maps (\Maps
m ->
    let
      path :: [Char]
path = [Char]
"logic." [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
traceName
      width :: Int
width = SNat (BitSize a) -> Int
forall a (n :: Natural). Num a => SNat n -> a
snatToNum (forall (n :: Natural). KnownNat n => SNat n
SNat @(BitSize a))
      addTrace :: Maps -> Maps
addTrace m' :: Maps
m'@Maps{TraceMap
traceMap :: Maps -> TraceMap
traceMap :: TraceMap
traceMap} = Maps
m'{traceMap = Map.insert
          traceName
          ( encode (typeRep @a)
          , period
          , width
          , if hasGeneratedLut @a then map ((\[AddValue]
f -> AddValue
-> ((AddValue, [AddValue]) -> AddValue)
-> Maybe (AddValue, [AddValue])
-> AddValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe AddValue
forall a. a -> a
id (AddValue -> (AddValue, [AddValue]) -> AddValue
forall a b. a -> b -> a
const (AddValue -> (AddValue, [AddValue]) -> AddValue)
-> AddValue -> (AddValue, [AddValue]) -> AddValue
forall a b. (a -> b) -> a -> b
$ (AddValue -> AddValue -> AddValue) -> [AddValue] -> AddValue
forall a. (a -> a -> a) -> [a] -> a
forall (t :: Type -> Type) a.
Foldable t =>
(a -> a -> a) -> t a -> a
foldl1 AddValue -> AddValue -> AddValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) [AddValue]
f) (Maybe (AddValue, [AddValue]) -> AddValue)
-> Maybe (AddValue, [AddValue]) -> AddValue
forall a b. (a -> b) -> a -> b
$ [AddValue] -> Maybe (AddValue, [AddValue])
forall a. [a] -> Maybe (a, [a])
uncons [AddValue]
f) . addValue) $ sample signal else repeat id
          , mkTrace signal)
          traceMap }
    in
      (   Maps -> Maps
addTrace
        (Maps -> Maps) -> (Maps -> Maps) -> Maps -> Maps
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Waveform a => [Char] -> Maps -> Maps
addSignal @a [Char]
path
        (Maps -> Maps) -> (Maps -> Maps) -> Maps -> Maps
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Maps -> Maps
checkUniqueTrace [Char]
traceName
        (Maps -> Maps) -> Maps -> Maps
forall a b. (a -> b) -> a -> b
$ Maps
m
      , Signal dom a
signal ) )

-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# OPAQUE traceSignal# #-}

-- | Trace a single vector signal: each element in the vector will show up as
-- a different trace. If the trace name already exists, this function will emit
-- an error.
traceVecSignal#
  :: forall dom n a
   . ( KnownNat n
     , BitPack a
     , NFDataX a
     , Typeable a
     , Waveform a )
  => IORef Maps
  -- ^ Map to store the traces
  -> Int
  -- ^ Associated clock period for the trace
  -> String
  -- ^ Name of signal in the VCD output. Will be appended by _0, _1, ..., _n.
  -> Signal dom (Vec (n+1) a)
  -- ^ Signal to trace
  -> IO (Signal dom (Vec (n+1) a))
traceVecSignal# :: forall (dom :: Symbol) (n :: Natural) a.
(KnownNat n, BitPack a, NFDataX a, Typeable a, Waveform a) =>
IORef Maps
-> Int
-> [Char]
-> Signal dom (Vec (n + 1) a)
-> IO (Signal dom (Vec (n + 1) a))
traceVecSignal# IORef Maps
maps Int
period [Char]
vecTraceName (Signal dom (Vec (n + 1) a) -> Unbundled dom (Vec (n + 1) a)
forall a (dom :: Symbol).
Bundle a =>
Signal dom a -> Unbundled dom a
forall (dom :: Symbol).
Signal dom (Vec (n + 1) a) -> Unbundled dom (Vec (n + 1) a)
unbundle -> Unbundled dom (Vec (n + 1) a)
vecSignal) =
  (Vec (n + 1) (Signal dom a) -> Signal dom (Vec (n + 1) a))
-> IO (Vec (n + 1) (Signal dom a))
-> IO (Signal dom (Vec (n + 1) a))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Vec (n + 1) (Signal dom a) -> Signal dom (Vec (n + 1) a)
Unbundled dom (Vec (n + 1) a) -> Signal dom (Vec (n + 1) a)
forall a (dom :: Symbol).
Bundle a =>
Unbundled dom a -> Signal dom a
forall (dom :: Symbol).
Unbundled dom (Vec (n + 1) a) -> Signal dom (Vec (n + 1) a)
bundle (IO (Vec (n + 1) (Signal dom a))
 -> IO (Signal dom (Vec (n + 1) a)))
-> (Vec (n + 1) (IO (Signal dom a))
    -> IO (Vec (n + 1) (Signal dom a)))
-> Vec (n + 1) (IO (Signal dom a))
-> IO (Signal dom (Vec (n + 1) a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vec (n + 1) (IO (Signal dom a)) -> IO (Vec (n + 1) (Signal dom a))
forall (t :: Type -> Type) (f :: Type -> Type) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: Type -> Type) a.
Applicative f =>
Vec (n + 1) (f a) -> f (Vec (n + 1) a)
sequenceA (Vec (n + 1) (IO (Signal dom a))
 -> IO (Signal dom (Vec (n + 1) a)))
-> Vec (n + 1) (IO (Signal dom a))
-> IO (Signal dom (Vec (n + 1) a))
forall a b. (a -> b) -> a -> b
$
    (Int -> Signal dom a -> IO (Signal dom a))
-> Vec (n + 1) Int
-> Vec (n + 1) (Signal dom a)
-> Vec (n + 1) (IO (Signal dom a))
forall a b c (n :: Natural).
(a -> b -> c) -> Vec n a -> Vec n b -> Vec n c
Vector.zipWith Int -> Signal dom a -> IO (Signal dom a)
trace' ((Int -> Int) -> Int -> Vec (n + 1) Int
forall (n :: Natural) a. KnownNat n => (a -> a) -> a -> Vec n a
iterateI Int -> Int
forall a. Enum a => a -> a
succ (Int
0 :: Int)) Vec (n + 1) (Signal dom a)
Unbundled dom (Vec (n + 1) a)
vecSignal
 where
  trace' :: Int -> Signal dom a -> IO (Signal dom a)
trace' Int
i Signal dom a
s = IORef Maps -> Int -> [Char] -> Signal dom a -> IO (Signal dom a)
forall (dom :: Symbol) a.
(BitPack a, NFDataX a, Typeable a, Waveform a) =>
IORef Maps -> Int -> [Char] -> Signal dom a -> IO (Signal dom a)
traceSignal# IORef Maps
maps Int
period (Int -> [Char]
name' Int
i) Signal dom a
s
  name' :: Int -> [Char]
name' Int
i    = [Char]
vecTraceName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i
-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# OPAQUE traceVecSignal# #-}

-- | Trace a single signal. Will emit an error if a signal with the same name
-- was previously registered.
--
-- __NB__: Works correctly when creating VCD files from traced signal in
-- multi-clock circuits. However 'traceSignal1' might be more convenient to
-- use when the domain of your circuit is polymorphic.
traceSignal
  :: forall dom  a
   . ( KnownDomain dom
     , BitPack a
     , NFDataX a
     , Typeable a
     , Waveform a )
  => String
  -- ^ Name of signal in the VCD output
  -> Signal dom a
  -- ^ Signal to trace
  -> Signal dom a
traceSignal :: forall (dom :: Symbol) a.
(KnownDomain dom, BitPack a, NFDataX a, Typeable a, Waveform a) =>
[Char] -> Signal dom a -> Signal dom a
traceSignal [Char]
traceName = (Signal dom a -> Signal dom a) -> Signal dom a -> Signal dom a
forall s. (s -> s) -> s -> s
simOnly ((Signal dom a -> Signal dom a) -> Signal dom a -> Signal dom a)
-> (Signal dom a -> Signal dom a) -> Signal dom a -> Signal dom a
forall a b. (a -> b) -> a -> b
$ \Signal dom a
signal ->
  case forall (dom :: Symbol).
KnownDomain dom =>
SDomainConfiguration dom (KnownConf dom)
knownDomain @dom of
    SDomainConfiguration{SNat period
sPeriod :: SNat period
sPeriod :: forall (period :: Natural) (dom :: Symbol) (edge :: ActiveEdge)
       (reset :: ResetKind) (init :: InitBehavior)
       (polarity :: ResetPolarity).
SDomainConfiguration
  dom ('DomainConfiguration dom period edge reset init polarity)
-> SNat period
sPeriod} ->
      IO (Signal dom a) -> Signal dom a
forall a. IO a -> a
unsafePerformIO (IO (Signal dom a) -> Signal dom a)
-> IO (Signal dom a) -> Signal dom a
forall a b. (a -> b) -> a -> b
$
        IORef Maps -> Int -> [Char] -> Signal dom a -> IO (Signal dom a)
forall (dom :: Symbol) a.
(BitPack a, NFDataX a, Typeable a, Waveform a) =>
IORef Maps -> Int -> [Char] -> Signal dom a -> IO (Signal dom a)
traceSignal# IORef Maps
maps# (SNat period -> Int
forall a (n :: Natural). Num a => SNat n -> a
snatToNum SNat period
sPeriod) [Char]
traceName Signal dom a
signal
-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# OPAQUE traceSignal #-}

-- | Trace a single signal. Will emit an error if a signal with the same name
-- was previously registered.
--
-- __NB__: Associates the traced signal with a clock period of /1/, which
-- results in incorrect VCD files when working with circuits that have
-- multiple clocks. Use 'traceSignal' when working with circuits that have
-- multiple clocks.
traceSignal1
  :: ( BitPack a
     , NFDataX a
     , Typeable a
     , Waveform a )
  => String
  -- ^ Name of signal in the VCD output
  -> Signal dom a
  -- ^ Signal to trace
  -> Signal dom a
traceSignal1 :: forall a (dom :: Symbol).
(BitPack a, NFDataX a, Typeable a, Waveform a) =>
[Char] -> Signal dom a -> Signal dom a
traceSignal1 [Char]
traceName = (Signal dom a -> Signal dom a) -> Signal dom a -> Signal dom a
forall s. (s -> s) -> s -> s
simOnly ((Signal dom a -> Signal dom a) -> Signal dom a -> Signal dom a)
-> (Signal dom a -> Signal dom a) -> Signal dom a -> Signal dom a
forall a b. (a -> b) -> a -> b
$ \Signal dom a
signal ->
  IO (Signal dom a) -> Signal dom a
forall a. IO a -> a
unsafePerformIO (IORef Maps -> Int -> [Char] -> Signal dom a -> IO (Signal dom a)
forall (dom :: Symbol) a.
(BitPack a, NFDataX a, Typeable a, Waveform a) =>
IORef Maps -> Int -> [Char] -> Signal dom a -> IO (Signal dom a)
traceSignal# IORef Maps
maps# Int
1 [Char]
traceName Signal dom a
signal)
-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# OPAQUE traceSignal1 #-}

-- | Trace a single vector signal: each element in the vector will show up as
-- a different trace. If the trace name already exists, this function will emit
-- an error.
--
-- __NB__: Works correctly when creating VCD files from traced signal in
-- multi-clock circuits. However 'traceSignal1' might be more convenient to
-- use when the domain of your circuit is polymorphic.
traceVecSignal
  :: forall dom a  n
   . ( KnownDomain dom
     , KnownNat n
     , BitPack a
     , NFDataX a
     , Typeable a
     , Waveform a )
  => String
  -- ^ Name of signal in debugging output. Will be appended by _0, _1, ..., _n.
  -> Signal dom (Vec (n+1) a)
  -- ^ Signal to trace
  -> Signal dom (Vec (n+1) a)
traceVecSignal :: forall (dom :: Symbol) a (n :: Natural).
(KnownDomain dom, KnownNat n, BitPack a, NFDataX a, Typeable a,
 Waveform a) =>
[Char] -> Signal dom (Vec (n + 1) a) -> Signal dom (Vec (n + 1) a)
traceVecSignal [Char]
traceName = (Signal dom (Vec (n + 1) a) -> Signal dom (Vec (n + 1) a))
-> Signal dom (Vec (n + 1) a) -> Signal dom (Vec (n + 1) a)
forall s. (s -> s) -> s -> s
simOnly ((Signal dom (Vec (n + 1) a) -> Signal dom (Vec (n + 1) a))
 -> Signal dom (Vec (n + 1) a) -> Signal dom (Vec (n + 1) a))
-> (Signal dom (Vec (n + 1) a) -> Signal dom (Vec (n + 1) a))
-> Signal dom (Vec (n + 1) a)
-> Signal dom (Vec (n + 1) a)
forall a b. (a -> b) -> a -> b
$ \Signal dom (Vec (n + 1) a)
signal ->
  case forall (dom :: Symbol).
KnownDomain dom =>
SDomainConfiguration dom (KnownConf dom)
knownDomain @dom of
    SDomainConfiguration{SNat period
sPeriod :: forall (period :: Natural) (dom :: Symbol) (edge :: ActiveEdge)
       (reset :: ResetKind) (init :: InitBehavior)
       (polarity :: ResetPolarity).
SDomainConfiguration
  dom ('DomainConfiguration dom period edge reset init polarity)
-> SNat period
sPeriod :: SNat period
sPeriod} ->
      IO (Signal dom (Vec (n + 1) a)) -> Signal dom (Vec (n + 1) a)
forall a. IO a -> a
unsafePerformIO (IO (Signal dom (Vec (n + 1) a)) -> Signal dom (Vec (n + 1) a))
-> IO (Signal dom (Vec (n + 1) a)) -> Signal dom (Vec (n + 1) a)
forall a b. (a -> b) -> a -> b
$
        IORef Maps
-> Int
-> [Char]
-> Signal dom (Vec (n + 1) a)
-> IO (Signal dom (Vec (n + 1) a))
forall (dom :: Symbol) (n :: Natural) a.
(KnownNat n, BitPack a, NFDataX a, Typeable a, Waveform a) =>
IORef Maps
-> Int
-> [Char]
-> Signal dom (Vec (n + 1) a)
-> IO (Signal dom (Vec (n + 1) a))
traceVecSignal# IORef Maps
maps# (SNat period -> Int
forall a (n :: Natural). Num a => SNat n -> a
snatToNum SNat period
sPeriod) [Char]
traceName Signal dom (Vec (n + 1) a)
signal
-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# OPAQUE traceVecSignal #-}

-- | Trace a single vector signal: each element in the vector will show up as
-- a different trace. If the trace name already exists, this function will emit
-- an error.
--
-- __NB__: Associates the traced signal with a clock period of /1/, which
-- results in incorrect VCD files when working with circuits that have
-- multiple clocks. Use 'traceSignal' when working with circuits that have
-- multiple clocks.
traceVecSignal1
  :: ( KnownNat n
     , BitPack a
     , NFDataX a
     , Typeable a
     , Waveform a )
  => String
  -- ^ Name of signal in debugging output. Will be appended by _0, _1, ..., _n.
  -> Signal dom (Vec (n+1) a)
  -- ^ Signal to trace
  -> Signal dom (Vec (n+1) a)
traceVecSignal1 :: forall (n :: Natural) a (dom :: Symbol).
(KnownNat n, BitPack a, NFDataX a, Typeable a, Waveform a) =>
[Char] -> Signal dom (Vec (n + 1) a) -> Signal dom (Vec (n + 1) a)
traceVecSignal1 [Char]
traceName = (Signal dom (Vec (n + 1) a) -> Signal dom (Vec (n + 1) a))
-> Signal dom (Vec (n + 1) a) -> Signal dom (Vec (n + 1) a)
forall s. (s -> s) -> s -> s
simOnly ((Signal dom (Vec (n + 1) a) -> Signal dom (Vec (n + 1) a))
 -> Signal dom (Vec (n + 1) a) -> Signal dom (Vec (n + 1) a))
-> (Signal dom (Vec (n + 1) a) -> Signal dom (Vec (n + 1) a))
-> Signal dom (Vec (n + 1) a)
-> Signal dom (Vec (n + 1) a)
forall a b. (a -> b) -> a -> b
$ \Signal dom (Vec (n + 1) a)
signal ->
  IO (Signal dom (Vec (n + 1) a)) -> Signal dom (Vec (n + 1) a)
forall a. IO a -> a
unsafePerformIO (IO (Signal dom (Vec (n + 1) a)) -> Signal dom (Vec (n + 1) a))
-> IO (Signal dom (Vec (n + 1) a)) -> Signal dom (Vec (n + 1) a)
forall a b. (a -> b) -> a -> b
$ IORef Maps
-> Int
-> [Char]
-> Signal dom (Vec (n + 1) a)
-> IO (Signal dom (Vec (n + 1) a))
forall (dom :: Symbol) (n :: Natural) a.
(KnownNat n, BitPack a, NFDataX a, Typeable a, Waveform a) =>
IORef Maps
-> Int
-> [Char]
-> Signal dom (Vec (n + 1) a)
-> IO (Signal dom (Vec (n + 1) a))
traceVecSignal# IORef Maps
maps# Int
1 [Char]
traceName Signal dom (Vec (n + 1) a)
signal
-- See: https://github.com/clash-lang/clash-compiler/pull/2511
{-# OPAQUE traceVecSignal1 #-}

iso8601Format :: UTCTime -> String
iso8601Format :: UTCTime -> [Char]
iso8601Format = TimeLocale -> [Char] -> UTCTime -> [Char]
forall t. FormatTime t => TimeLocale -> [Char] -> t -> [Char]
formatTime TimeLocale
defaultTimeLocale [Char]
"%Y-%m-%dT%H:%M:%S"

toPeriodMap :: TraceMap -> Map.Map Period [(String, Width, [AddValue], [Value])]
toPeriodMap :: TraceMap -> Map Int [([Char], Int, [AddValue], [Value])]
toPeriodMap TraceMap
m = (Map Int [([Char], Int, [AddValue], [Value])]
 -> ([Char], (TypeRepBS, Int, Int, [AddValue], [Value]))
 -> Map Int [([Char], Int, [AddValue], [Value])])
-> Map Int [([Char], Int, [AddValue], [Value])]
-> [([Char], (TypeRepBS, Int, Int, [AddValue], [Value]))]
-> Map Int [([Char], Int, [AddValue], [Value])]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map Int [([Char], Int, [AddValue], [Value])]
-> ([Char], (TypeRepBS, Int, Int, [AddValue], [Value]))
-> Map Int [([Char], Int, [AddValue], [Value])]
forall {k} {a} {b} {c} {d} {a}.
Ord k =>
Map k [(a, b, c, d)]
-> (a, (a, k, b, c, d)) -> Map k [(a, b, c, d)]
go Map Int [([Char], Int, [AddValue], [Value])]
forall k a. Map k a
Map.empty (TraceMap -> [([Char], (TypeRepBS, Int, Int, [AddValue], [Value]))]
forall k a. Map k a -> [(k, a)]
Map.assocs TraceMap
m)
  where
    go :: Map k [(a, b, c, d)]
-> (a, (a, k, b, c, d)) -> Map k [(a, b, c, d)]
go Map k [(a, b, c, d)]
periodMap (a
traceName, (a
_rep, k
period, b
width, c
addValues, d
values)) =
      (Maybe [(a, b, c, d)] -> Maybe [(a, b, c, d)])
-> k -> Map k [(a, b, c, d)] -> Map k [(a, b, c, d)]
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter ([(a, b, c, d)] -> Maybe [(a, b, c, d)]
forall a. a -> Maybe a
Just ([(a, b, c, d)] -> Maybe [(a, b, c, d)])
-> (Maybe [(a, b, c, d)] -> [(a, b, c, d)])
-> Maybe [(a, b, c, d)]
-> Maybe [(a, b, c, d)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [(a, b, c, d)] -> [(a, b, c, d)]
go') k
period Map k [(a, b, c, d)]
periodMap
        where
          go' :: Maybe [(a, b, c, d)] -> [(a, b, c, d)]
go' = ((a
traceName, b
width, c
addValues, d
values)(a, b, c, d) -> [(a, b, c, d)] -> [(a, b, c, d)]
forall a. a -> [a] -> [a]
:) ([(a, b, c, d)] -> [(a, b, c, d)])
-> (Maybe [(a, b, c, d)] -> [(a, b, c, d)])
-> Maybe [(a, b, c, d)]
-> [(a, b, c, d)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(a, b, c, d)] -> Maybe [(a, b, c, d)] -> [(a, b, c, d)]
forall a. a -> Maybe a -> a
fromMaybe [])

flattenMap :: Map.Map a [b] -> [(a, b)]
flattenMap :: forall a b. Map a [b] -> [(a, b)]
flattenMap Map a [b]
m = [[(a, b)]] -> [(a, b)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(a
a, b
b) | b
b <- [b]
bs] | (a
a, [b]
bs) <- Map a [b] -> [(a, [b])]
forall k a. Map k a -> [(k, a)]
Map.assocs Map a [b]
m]

printable :: Char -> Bool
printable :: Char -> Bool
printable (Char -> Int
ord -> Int
c) = Int
33 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
c Bool -> Bool -> Bool
&& Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
126

-- | Same as @dumpVCD@, but supplied with a custom tracemap and a custom timestamp
dumpVCD##
  :: (Int, Int)
  -- ^ (offset, number of samples)
  -> Maps
  -> UTCTime
  -> Either String (Text.Text, JSON)
dumpVCD## :: (Int, Int) -> Maps -> UTCTime -> Either [Char] (Text, Value)
dumpVCD## (Int
offset, Int
cycles) Maps{SignalMap
signalMap :: Maps -> SignalMap
signalMap :: SignalMap
signalMap,TypeMap
typeMap :: Maps -> TypeMap
typeMap :: TypeMap
typeMap,TraceMap
traceMap :: Maps -> TraceMap
traceMap :: TraceMap
traceMap} UTCTime
now
  | Int
offset Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 =
      [Char] -> Either [Char] (Text, Value)
forall a. HasCallStack => [Char] -> a
error ([Char] -> Either [Char] (Text, Value))
-> [Char] -> Either [Char] (Text, Value)
forall a b. (a -> b) -> a -> b
$ [Char]
"dumpVCD: offset was " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
offset [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", but cannot be negative."
  | Int
cycles Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 =
      [Char] -> Either [Char] (Text, Value)
forall a. HasCallStack => [Char] -> a
error ([Char] -> Either [Char] (Text, Value))
-> [Char] -> Either [Char] (Text, Value)
forall a b. (a -> b) -> a -> b
$ [Char]
"dumpVCD: cycles was " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
cycles [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", but cannot be negative."
  | TraceMap -> Bool
forall a. Map [Char] a -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null TraceMap
traceMap =
      [Char] -> Either [Char] (Text, Value)
forall a. HasCallStack => [Char] -> a
error ([Char] -> Either [Char] (Text, Value))
-> [Char] -> Either [Char] (Text, Value)
forall a b. (a -> b) -> a -> b
$ [Char]
"dumpVCD: no traces found. Extend the given trace names."
  | ([Char]
nm:[[Char]]
_) <- [[Char]]
offensiveNames =
      [Char] -> Either [Char] (Text, Value)
forall a b. a -> Either a b
Left ([Char] -> Either [Char] (Text, Value))
-> [Char] -> Either [Char] (Text, Value)
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [ [Char]
"Trace '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
nm [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"' contains"
                     , [Char]
"non-printable ASCII characters, which is not"
                     , [Char]
"supported by VCD." ]
  | Bool
otherwise =
      (Text, Value) -> Either [Char] (Text, Value)
forall a b. b -> Either a b
Right ( [Text] -> Text
Text.unlines [ [Text] -> Text
Text.unwords [Text]
headerDate
                           , [Text] -> Text
Text.unwords [Text]
headerVersion
                           , [Text] -> Text
Text.unwords [Text]
headerComment
                           , [Char] -> Text
Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [[Char]]
headerTimescale
                           , Text
"$scope module logic $end"
                           , Text -> [Text] -> Text
Text.intercalate Text
"\n" [Text]
headerWires
                           , Text
"$upscope $end"
                           , Text
"$enddefinitions $end"
                           , Text
"#0"
                           , Text
"$dumpvars"
                           , Text -> [Text] -> Text
Text.intercalate Text
"\n" [Text]
initValues
                           , Text
"$end"
                           , Text -> [Text] -> Text
Text.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Text]
bodyParts
                           ]
            , [Pair] -> Value
Json.object  [ Key
"signals" Key -> SignalMap -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SignalMap
signalMap
                           , Key
"types" Key -> TypeMap -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= TypeMap
typeMap
                           , Key
"luts" Key -> Map [Char] LUT -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map [Char] LUT
lutMap
                           ]
            )
 where
  offensiveNames :: [[Char]]
offensiveNames = ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Char -> Bool) -> [Char] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
printable)) [[Char]]
traceNames

  labels :: [[Char]]
labels = (Int -> [Char]) -> [Int] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Int -> [Char]
go [Int
1..]
   where
    go :: Int -> [Char]
go Int
0 = [Char]
""
    go Int
n = Int -> Char
chr ( Int
33 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
l) Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Int -> [Char]
go (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
l)
    l :: Int
l = Int
126Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
33Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1

  timescale :: Int
timescale = (Int -> Int -> Int) -> [Int] -> Int
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' Int -> Int -> Int
forall a. Integral a => a -> a -> a
gcd (Map Int [([Char], Int, [AddValue], [Value])] -> [Int]
forall k a. Map k a -> [k]
Map.keys Map Int [([Char], Int, [AddValue], [Value])]
periodMap)
  periodMap :: Map Int [([Char], Int, [AddValue], [Value])]
periodMap = TraceMap -> Map Int [([Char], Int, [AddValue], [Value])]
toPeriodMap TraceMap
traceMap

  -- Normalize traces until they have the "same" period. That is, assume
  -- we have two traces; trace A with a period of 20 ps and trace B with
  -- a period of 40 ps:
  --
  --   A: [A1, A2, A3, ...]
  --   B: [B1, B2, B3, ...]
  --
  -- After normalization these look like:
  --
  --   A: [A1, A2, A3, A4, A5, A6, ...]
  --   B: [B1, B1, B2, B2, B3, B3, ...]
  --
  -- ..because B is "twice as slow" as A.
  ([Int]
periods, [[Char]]
traceNames, [Int]
widths, [[AddValue]]
addValuess, [[Value]]
valuess) =
    [(Int, [Char], Int, [AddValue], [Value])]
-> ([Int], [[Char]], [Int], [[AddValue]], [[Value]])
forall a b c d e. [(a, b, c, d, e)] -> ([a], [b], [c], [d], [e])
unzip5 ([(Int, [Char], Int, [AddValue], [Value])]
 -> ([Int], [[Char]], [Int], [[AddValue]], [[Value]]))
-> [(Int, [Char], Int, [AddValue], [Value])]
-> ([Int], [[Char]], [Int], [[AddValue]], [[Value]])
forall a b. (a -> b) -> a -> b
$ ((Int, ([Char], Int, [AddValue], [Value]))
 -> (Int, [Char], Int, [AddValue], [Value]))
-> [(Int, ([Char], Int, [AddValue], [Value]))]
-> [(Int, [Char], Int, [AddValue], [Value])]
forall a b. (a -> b) -> [a] -> [b]
map
      (\(Int
a, ([Char]
b, Int
c, [AddValue]
d, [Value]
e)) -> (Int
a, [Char]
b, Int
c, [AddValue]
d, [Value]
e))
      (Map Int [([Char], Int, [AddValue], [Value])]
-> [(Int, ([Char], Int, [AddValue], [Value]))]
forall a b. Map a [b] -> [(a, b)]
flattenMap Map Int [([Char], Int, [AddValue], [Value])]
periodMap)

  periods' :: [Int]
periods'    = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
timescale) [Int]
periods
  valuess' :: [[Value]]
valuess'    = ([Value] -> [Value]) -> [[Value]] -> [[Value]]
forall a b. (a -> b) -> [a] -> [b]
map [Value] -> [Value]
forall a. [a] -> [a]
slice ([[Value]] -> [[Value]]) -> [[Value]] -> [[Value]]
forall a b. (a -> b) -> a -> b
$ (Int -> [Value] -> [Value]) -> [Int] -> [[Value]] -> [[Value]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> [Value] -> [Value]
forall {a}. Int -> [a] -> [a]
normalize [Int]
periods' [[Value]]
valuess
  addValuess' :: [[AddValue]]
addValuess' = ([AddValue] -> [AddValue]) -> [[AddValue]] -> [[AddValue]]
forall a b. (a -> b) -> [a] -> [b]
map [AddValue] -> [AddValue]
forall a. [a] -> [a]
slice ([[AddValue]] -> [[AddValue]]) -> [[AddValue]] -> [[AddValue]]
forall a b. (a -> b) -> a -> b
$ (Int -> [AddValue] -> [AddValue])
-> [Int] -> [[AddValue]] -> [[AddValue]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> [AddValue] -> [AddValue]
forall {a}. Int -> [a] -> [a]
normalize [Int]
periods' [[AddValue]]
addValuess
  
  normalize :: Int -> [a] -> [a]
normalize  Int
period (a
v:[a]
values)    = a
va -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> [a]) -> [a] -> [a]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (Int -> a -> [a]
forall a. Int -> a -> [a]
replicate Int
period) [a]
values
  normalize  Int
_      []            = []
  slice :: [a] -> [a]
  slice :: forall a. [a] -> [a]
slice [a]
values = Int -> [a] -> [a]
forall {a}. Int -> [a] -> [a]
drop Int
offset ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ Int -> [a] -> [a]
forall {a}. Int -> [a] -> [a]
take Int
cycles [a]
values

  staticLuts :: Map [Char] LUT
staticLuts = [([Char], LUT)] -> Map [Char] LUT
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([([Char], LUT)] -> Map [Char] LUT)
-> [([Char], LUT)] -> Map [Char] LUT
forall a b. (a -> b) -> a -> b
$ (Translator -> [([Char], LUT)]) -> [Translator] -> [([Char], LUT)]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap Translator -> [([Char], LUT)]
getStaticLuts (TypeMap -> [Translator]
forall k a. Map k a -> [a]
M.elems TypeMap
typeMap) -- map over the types, collect all LUTs in a map
  lutMap :: Map [Char] LUT
lutMap = (Map [Char] LUT -> AddValue -> Map [Char] LUT)
-> Map [Char] LUT -> [AddValue] -> Map [Char] LUT
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((AddValue -> AddValue)
-> Map [Char] LUT -> AddValue -> Map [Char] LUT
forall a b c. (a -> b -> c) -> b -> a -> c
flip AddValue -> AddValue
forall a b. (a -> b) -> a -> b
($)) Map [Char] LUT
staticLuts ([AddValue] -> Map [Char] LUT) -> [AddValue] -> Map [Char] LUT
forall a b. (a -> b) -> a -> b
$ [[AddValue]] -> [AddValue]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[AddValue]] -> [AddValue]) -> [[AddValue]] -> [AddValue]
forall a b. (a -> b) -> a -> b
$ [[AddValue]]
addValuess'

  headerDate :: [Text]
headerDate       = [Text
"$date", [Char] -> Text
Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ UTCTime -> [Char]
iso8601Format UTCTime
now, Text
"$end"]

#ifdef CABAL
  clashVer :: [Char]
clashVer         = [Char]
"Clash " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> VERSION_clash_prelude <>
                     [Char]
" / Shockwaves " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Version -> [Char]
showVersion Version
Paths_clash_shockwaves.version
#else
  clashVer         = "development version"
#endif
  headerVersion :: [Text]
headerVersion    = [Text
"$version", Text
"Generated by:", [Char] -> Text
Text.pack [Char]
clashVer , Text
"$end"]
  headerComment :: [Text]
headerComment    = [Text
"$comment", Text
"No comment", Text
"$end"]
  headerTimescale :: [[Char]]
headerTimescale  = [[Char]
"$timescale", (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
timescale) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"ps", [Char]
"$end"]
  headerWires :: [Text]
headerWires      = [ [Text] -> Text
Text.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> [Char] -> [Text]
forall {a}. Show a => a -> [Char] -> [Char] -> [Text]
headerWire Int
w [Char]
l [Char]
n
                     | (Int
w, [Char]
l, [Char]
n) <- ([Int] -> [[Char]] -> [[Char]] -> [(Int, [Char], [Char])]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int]
widths [[Char]]
labels [[Char]]
traceNames)]
  headerWire :: a -> [Char] -> [Char] -> [Text]
headerWire a
w [Char]
l [Char]
n = ([Char] -> Text) -> [[Char]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
Text.pack [[Char]
"$var wire", a -> [Char]
forall a. Show a => a -> [Char]
show a
w, [Char]
l, [Char]
n, [Char]
"$end"]
  initValues :: [Text]
initValues       = ([Char] -> Text) -> [[Char]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
Text.pack ([[Char]] -> [Text]) -> [[Char]] -> [Text]
forall a b. (a -> b) -> a -> b
$ ((Value -> [Char]) -> Value -> [Char])
-> [Value -> [Char]] -> [Value] -> [[Char]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Value -> [Char]) -> Value -> [Char]
forall a b. (a -> b) -> a -> b
($) [Value -> [Char]]
formatters [Value]
inits

  formatters :: [Value -> [Char]]
formatters = (Int -> [Char] -> Value -> [Char])
-> [Int] -> [[Char]] -> [Value -> [Char]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> [Char] -> Value -> [Char]
format [Int]
widths [[Char]]
labels
  inits :: [Value]
inits = ([Value] -> Value) -> [[Value]] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Value
-> ((Value, [Value]) -> Value) -> Maybe (Value, [Value]) -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Value
forall a. HasCallStack => [Char] -> a
error [Char]
"dumpVCD##: empty value") (Value, [Value]) -> Value
forall a b. (a, b) -> a
fst (Maybe (Value, [Value]) -> Value)
-> ([Value] -> Maybe (Value, [Value])) -> [Value] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Maybe (Value, [Value])
forall a. [a] -> Maybe (a, [a])
uncons) [[Value]]
valuess'
  tails :: [[(Bool, Value)]]
tails = ([Value] -> [(Bool, Value)]) -> [[Value]] -> [[(Bool, Value)]]
forall a b. (a -> b) -> [a] -> [b]
map [Value] -> [(Bool, Value)]
changed [[Value]]
valuess'

  -- | Format single value according to VCD spec
  format :: Width -> String -> Value -> String
  format :: Int -> [Char] -> Value -> [Char]
format Int
1 [Char]
label (Natural
0,Natural
0)   = Char
'0'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
label [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\n"
  format Int
1 [Char]
label (Natural
0,Natural
1)   = Char
'1'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
label [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\n"
  format Int
1 [Char]
label (Natural
1,Natural
_)   = Char
'x'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
label [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\n"
  format Int
1 [Char]
label (Natural
mask,Natural
val) =
    [Char] -> [Char]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"Can't format 1 bit wide value for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
label [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": value " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Natural -> [Char]
forall a. Show a => a -> [Char]
show Natural
val [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" and mask " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Natural -> [Char]
forall a. Show a => a -> [Char]
show Natural
mask
  format Int
n [Char]
label (Natural
mask,Natural
val) =
    [Char]
"b" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Int -> Char) -> [Int] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
digit ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
label
    where
      digit :: Int -> Char
digit Int
d = case (Natural -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Natural
mask Int
d, Natural -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Natural
val Int
d) of
        (Bool
False,Bool
False) -> Char
'0'
        (Bool
False,Bool
True)  -> Char
'1'
        (Bool
True,Bool
_)      -> Char
'x'

  -- | Given a list of values, return a list of list of bools indicating
  -- if a value changed. The first value is *not* included in the result.
  changed :: [Value] -> [(Changed, Value)]
  changed :: [Value] -> [(Bool, Value)]
changed (Value
s:[Value]
ss) = [Bool] -> [Value] -> [(Bool, Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Value -> Value -> Bool) -> [Value] -> [Value] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
(/=) (Value
sValue -> [Value] -> [Value]
forall a. a -> [a] -> [a]
:[Value]
ss) [Value]
ss) [Value]
ss
  changed []     = []

  bodyParts :: [Maybe Text.Text]
  bodyParts :: [Maybe Text]
bodyParts = (Int -> Maybe Text -> Maybe Text)
-> [Int] -> [Maybe Text] -> [Maybe Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Maybe Text -> Maybe Text
go [Int
0..] (([(Bool, Value)] -> Maybe Text)
-> [[(Bool, Value)]] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map [(Bool, Value)] -> Maybe Text
bodyPart ([[(Bool, Value)]] -> [[(Bool, Value)]]
forall a. [[a]] -> [[a]]
Data.List.transpose [[(Bool, Value)]]
tails))
    where
      go :: Int -> Maybe Text.Text -> Maybe Text.Text
      go :: Int -> Maybe Text -> Maybe Text
go ([Char] -> Text
Text.pack ([Char] -> Text) -> (Int -> [Char]) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show -> Text
n) Maybe Text
t =
        let pre :: Text
pre = [Text] -> Text
Text.concat [Text
"#", Text
n, Text
"\n"] in
        (Text -> Text) -> Maybe Text -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text -> Text
Text.append Text
pre) Maybe Text
t

  bodyPart :: [(Changed, Value)] -> Maybe Text.Text
  bodyPart :: [(Bool, Value)] -> Maybe Text
bodyPart [(Bool, Value)]
values =
    let formatted :: [(Bool, [Char])]
formatted  = [(Bool
c, Value -> [Char]
f Value
v) | (Value -> [Char]
f, (Bool
c,Value
v)) <- [Value -> [Char]]
-> [(Bool, Value)] -> [(Value -> [Char], (Bool, Value))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Value -> [Char]]
formatters [(Bool, Value)]
values]
        formatted' :: [Text]
formatted' = ((Bool, [Char]) -> Text) -> [(Bool, [Char])] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Text
Text.pack ([Char] -> Text)
-> ((Bool, [Char]) -> [Char]) -> (Bool, [Char]) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, [Char]) -> [Char]
forall a b. (a, b) -> b
snd) ([(Bool, [Char])] -> [Text]) -> [(Bool, [Char])] -> [Text]
forall a b. (a -> b) -> a -> b
$ ((Bool, [Char]) -> Bool) -> [(Bool, [Char])] -> [(Bool, [Char])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool, [Char]) -> Bool
forall a b. (a, b) -> a
fst ([(Bool, [Char])] -> [(Bool, [Char])])
-> [(Bool, [Char])] -> [(Bool, [Char])]
forall a b. (a -> b) -> a -> b
$ [(Bool, [Char])]
formatted in
    if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Text]
formatted' then Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
Text.intercalate Text
"\n" [Text]
formatted'

-- | Same as @dumpVCD@, but supplied with a custom tracemap
dumpVCD#
  :: NFDataX a
  => IORef Maps
  -- ^ Map with collected traces
  -> (Int, Int)
  -- ^ (offset, number of samples)
  -> Signal dom a
  -- ^ (One of) the output(s) the circuit containing the traces
  -> [String]
  -- ^ The names of the traces you definitely want to be dumped to the VCD file
  -> IO (Either String (Text.Text, JSON))
dumpVCD# :: forall a (dom :: Symbol).
NFDataX a =>
IORef Maps
-> (Int, Int)
-> Signal dom a
-> [[Char]]
-> IO (Either [Char] (Text, Value))
dumpVCD# IORef Maps
maps (Int, Int)
slice Signal dom a
signal [[Char]]
traceNames = do
  IORef Maps -> Signal dom a -> [[Char]] -> IO ()
forall a (dom :: Symbol).
NFDataX a =>
IORef Maps -> Signal dom a -> [[Char]] -> IO ()
waitForTraces# IORef Maps
maps Signal dom a
signal [[Char]]
traceNames
  m <- IORef Maps -> IO Maps
forall a. IORef a -> IO a
readIORef IORef Maps
maps
  fmap (dumpVCD## slice m) getCurrentTime

-- | Produce a four-state VCD (Value Change Dump) according to IEEE
-- 1364-{1995,2001}. This function fails if a trace name contains either
-- non-printable or non-VCD characters.
--
-- Due to lazy evaluation, the created VCD files might not contain all the
-- traces you were expecting. You therefore have to provide a list of names
-- you definately want to be dumped in the VCD file.
--
-- For example:
--
-- @
-- vcd <- dumpVCD (0, 100) cntrOut ["main", "sub"]
-- @
--
-- Evaluates /cntrOut/ long enough in order for to guarantee that the @main@,
-- and @sub@ traces end up in the generated VCD file.
dumpVCD
  :: NFDataX a
  => (Int, Int)
  -- ^ (offset, number of samples)
  -> Signal dom a
  -- ^ (One of) the outputs of the circuit containing the traces
  -> [String]
  -- ^ The names of the traces you definitely want to be dumped in the VCD file
  -> IO (Either String (Text.Text, JSON))
dumpVCD :: forall a (dom :: Symbol).
NFDataX a =>
(Int, Int)
-> Signal dom a -> [[Char]] -> IO (Either [Char] (Text, Value))
dumpVCD = IORef Maps
-> (Int, Int)
-> Signal dom a
-> [[Char]]
-> IO (Either [Char] (Text, Value))
forall a (dom :: Symbol).
NFDataX a =>
IORef Maps
-> (Int, Int)
-> Signal dom a
-> [[Char]]
-> IO (Either [Char] (Text, Value))
dumpVCD# IORef Maps
maps#

-- | Dump a number of samples to a replayable bytestring.
dumpReplayable
  :: forall a dom
   . NFDataX a
  => Int
  -- ^ Number of samples
  -> Signal dom a
  -- ^ (One of) the outputs of the circuit containing the traces
  -> String
  -- ^ Name of trace to dump
  -> IO ByteString
dumpReplayable :: forall a (dom :: Symbol).
NFDataX a =>
Int -> Signal dom a -> [Char] -> IO TypeRepBS
dumpReplayable Int
n Signal dom a
oSignal [Char]
traceName = do
  IORef Maps -> Signal dom a -> [[Char]] -> IO ()
forall a (dom :: Symbol).
NFDataX a =>
IORef Maps -> Signal dom a -> [[Char]] -> IO ()
waitForTraces# IORef Maps
maps# Signal dom a
oSignal [[Char]
traceName]
  replaySignal <- (TraceMap -> [Char] -> (TypeRepBS, Int, Int, [AddValue], [Value])
forall k a. Ord k => Map k a -> k -> a
Map.! [Char]
traceName) (TraceMap -> (TypeRepBS, Int, Int, [AddValue], [Value]))
-> (Maps -> TraceMap)
-> Maps
-> (TypeRepBS, Int, Int, [AddValue], [Value])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maps -> TraceMap
traceMap (Maps -> (TypeRepBS, Int, Int, [AddValue], [Value]))
-> IO Maps -> IO (TypeRepBS, Int, Int, [AddValue], [Value])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Maps -> IO Maps
forall a. IORef a -> IO a
readIORef IORef Maps
maps#
  let (tRep, _period, _width, _addValues, samples) = replaySignal
  pure (ByteStringLazy.concat (tRep : map encode (take n samples)))

-- | Take a serialized signal (dumped with @dumpReplayable@) and convert it
-- back into a signal. Will error if dumped type does not match requested
-- type. The first value in the signal that fails to decode will stop the
-- decoding process and yield an error. Not that this always happens if you
-- evaluate more values than were originally dumped.
replay
  :: forall a dom n
   . ( Typeable a
     , NFDataX a
     , BitPack a
     , KnownNat n
     , n ~ BitSize a )
  => ByteString
  -> Either String (Signal dom a)
replay :: forall a (dom :: Symbol) (n :: Natural).
(Typeable a, NFDataX a, BitPack a, KnownNat n, n ~ BitSize a) =>
TypeRepBS -> Either [Char] (Signal dom a)
replay TypeRepBS
bytes0 = Either [Char] (Signal dom a)
samples1
 where
  samples1 :: Either [Char] (Signal dom a)
samples1 =
    case TypeRepBS
-> Either
     (TypeRepBS, ByteOffset, [Char]) (TypeRepBS, ByteOffset, TypeRep a)
forall a.
Binary a =>
TypeRepBS
-> Either
     (TypeRepBS, ByteOffset, [Char]) (TypeRepBS, ByteOffset, a)
decodeOrFail TypeRepBS
bytes0 of
      Left (TypeRepBS
_, ByteOffset
_, [Char]
err) ->
        [Char] -> Either [Char] (Signal dom a)
forall a b. a -> Either a b
Left ([Char]
"Failed to decode typeRep. Parser reported:\n\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err)
      Right (TypeRepBS
bytes1, ByteOffset
_, TypeRep a
_ :: TypeRep a) ->
        let samples0 :: [Either [Char] a]
samples0 = TypeRepBS -> [Either [Char] a]
forall a (n :: Natural).
(BitPack a, KnownNat n, n ~ BitSize a) =>
TypeRepBS -> [Either [Char] a]
decodeSamples TypeRepBS
bytes1 in
        let err :: [Char]
err = [Char]
"Failed to decode value in signal. Parser reported:\n\n " in
        Signal dom a -> Either [Char] (Signal dom a)
forall a b. b -> Either a b
Right ([a] -> Signal dom a
forall a (dom :: Symbol). NFDataX a => [a] -> Signal dom a
fromList ((Either [Char] a -> a) -> [Either [Char] a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (([Char] -> a) -> (a -> a) -> Either [Char] a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> ([Char] -> [Char]) -> [Char] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
err [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)) a -> a
forall a. a -> a
id) [Either [Char] a]
samples0))

-- | Helper function of 'replay'. Decodes ByteString to some type with
-- BitVector as an intermediate type.
decodeSamples
  :: forall a n
   . ( BitPack a
     , KnownNat n
     , n ~ BitSize a )
  => ByteString
  -> [Either String a]
decodeSamples :: forall a (n :: Natural).
(BitPack a, KnownNat n, n ~ BitSize a) =>
TypeRepBS -> [Either [Char] a]
decodeSamples TypeRepBS
bytes0 =
  case TypeRepBS
-> Either
     (TypeRepBS, ByteOffset, [Char]) (TypeRepBS, ByteOffset, Value)
forall a.
Binary a =>
TypeRepBS
-> Either
     (TypeRepBS, ByteOffset, [Char]) (TypeRepBS, ByteOffset, a)
decodeOrFail TypeRepBS
bytes0 of
    Left (TypeRepBS
_, ByteOffset
_, [Char]
err) ->
      [[Char] -> Either [Char] a
forall a b. a -> Either a b
Left [Char]
err]
    Right (TypeRepBS
bytes1, ByteOffset
_, (Natural
m, Natural
v)) ->
      (a -> Either [Char] a
forall a b. b -> Either a b
Right (BitVector (BitSize a) -> a
forall a. BitPack a => BitVector (BitSize a) -> a
unpack (Natural -> Natural -> BitVector n
forall (n :: Natural). Natural -> Natural -> BitVector n
BV Natural
m Natural
v))) Either [Char] a -> [Either [Char] a] -> [Either [Char] a]
forall a. a -> [a] -> [a]
: TypeRepBS -> [Either [Char] a]
forall a (n :: Natural).
(BitPack a, KnownNat n, n ~ BitSize a) =>
TypeRepBS -> [Either [Char] a]
decodeSamples TypeRepBS
bytes1

-- | Keep evaluating given signal until all trace names are present.
waitForTraces#
  :: NFDataX a
  => IORef Maps
  -- ^ Map with collected traces
  -> Signal dom a
  -- ^ (One of) the output(s) the circuit containing the traces
  -> [String]
  -- ^ The names of the traces you definitely want to be dumped to the VCD file
  -> IO ()
waitForTraces# :: forall a (dom :: Symbol).
NFDataX a =>
IORef Maps -> Signal dom a -> [[Char]] -> IO ()
waitForTraces# IORef Maps
maps Signal dom a
signal [[Char]]
traceNames = do
  written <- IORef Maps -> Maps -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef Maps
maps Maps
forall a. Default a => a
def
  rest <- foldM go (written `pseq` signal) traceNames
  seq rest (return ())
 where
  go :: Signal dom a -> [Char] -> IO (Signal dom a)
go (a
s0 :- Signal dom a
ss) [Char]
nm = do
    Maps{traceMap=m} <- IORef Maps -> IO Maps
forall a. IORef a -> IO a
readIORef IORef Maps
maps
    if Map.member nm m then
      deepseqX s0 (return ss)
    else
      deepseqX
        s0
        (go ss nm)

{- FOURMOLU_ENABLE -}