diff --git a/cabal.project b/cabal.project index 924a124238..962385cea9 100644 --- a/cabal.project +++ b/cabal.project @@ -9,6 +9,7 @@ packages: ./clash-prelude ./clash-prelude-hedgehog ./clash-cores + ./clash-testbench ./tests write-ghc-environment-files: always diff --git a/clash-testbench/LICENSE b/clash-testbench/LICENSE new file mode 100644 index 0000000000..b1793511ff --- /dev/null +++ b/clash-testbench/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2023 QBayLogic B.V. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/clash-testbench/clash-testbench.cabal b/clash-testbench/clash-testbench.cabal new file mode 100644 index 0000000000..95c8162b1d --- /dev/null +++ b/clash-testbench/clash-testbench.cabal @@ -0,0 +1,57 @@ +cabal-version: 2.2 + +name: clash-testbench +version: 0.1.0.0 +synopsis: Design your TestBenches in Clash +description: Design your TestBenches in Clash +bug-reports: https://github.com/clash-lang/clash-compiler/issues +license: BSD-2-Clause +license-file: LICENSE +author: QBayLogic B.V. +maintainer: devops@qbaylogic.com +copyright: Copyright © 2023, QBayLogic B.V. +category: Hardware + +library + default-language: Haskell2010 + default-extensions: + DataKinds + FlexibleContexts + FlexibleInstances + GADTs + ImplicitParams + LambdaCase + MagicHash + MultiWayIf + NamedFieldPuns + RankNTypes + RecordWildCards + ScopedTypeVariables + TupleSections + TypeApplications + TypeFamilies + ViewPatterns + ghc-options: + -Wall -Wcompat + exposed-modules: + Clash.Testbench + Clash.Testbench.Signal + Clash.Testbench.Input + Clash.Testbench.Output + Clash.Testbench.Simulate + Clash.Testbench.Generate + Clash.Testbench.Internal.ID + Clash.Testbench.Internal.Signal + Clash.Testbench.Internal.Monad + Control.Monad.Extra + build-depends: + base, + mtl, + array, + lattices, + hedgehog, + containers, + bytestring, + clash-ffi, + clash-prelude, + hs-source-dirs: src diff --git a/clash-testbench/example/Calculator.hs b/clash-testbench/example/Calculator.hs new file mode 100644 index 0000000000..8066e3a18c --- /dev/null +++ b/clash-testbench/example/Calculator.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +module Calculator where + +import Clash.Prelude hiding (Word) + +type Word = Signed 4 +data OPC a = ADD | MUL | Imm a | Pop | Push + deriving (Lift, Generic, BitPack, NFDataX, Show) + +(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d +(f .: g) a b = f (g a b) + +infixr 9 .: + +alu :: Num a => OPC a -> a -> a -> Maybe a +alu ADD = Just .: (+) +alu MUL = Just .: (*) +alu (Imm i) = const . const (Just i) +alu _ = const . const Nothing + +pu :: (Num a, Num b) + => (OPC a -> a -> a -> Maybe a) + -> (a, a, b) -- Current state + -> (a, OPC a) -- Input + -> ( (a, a, b) -- New state + , (b, Maybe a) -- Output + ) +pu _ (op1, _, cnt) (dmem, Pop) = ((dmem, op1, cnt - 1), (cnt, Nothing) ) +pu _ (op1, op2, cnt) ( _, Push) = ((op1, op2, cnt + 1) , (cnt, Nothing) ) +pu a (op1, op2, cnt) ( _, opc) = ((op1, op2, cnt) , (cnt, a opc op1 op2)) + +datamem :: (KnownNat n, Integral i) + => Vec n a -- Current state + -> (i, Maybe a) -- Input + -> (Vec n a, a) -- (New state, Output) +datamem mem (addr,Nothing) = (mem ,mem !! addr) +datamem mem (addr,Just val) = (replace addr val mem,mem !! addr) + +topEntity + :: Clock System + -> Reset System + -> Enable System + -> Signal System (OPC Word) + -> Signal System (Maybe Word) +topEntity = exposeClockResetEnable go where + go i = val where + (addr,val) = (pu alu <^> (0,0,0 :: Unsigned 3)) (mem,i) + mem = (datamem <^> initMem) (addr,val) + initMem = replicate d8 0 +{-# NOINLINE topEntity #-} diff --git a/clash-testbench/example/LICENSE b/clash-testbench/example/LICENSE new file mode 100644 index 0000000000..b1793511ff --- /dev/null +++ b/clash-testbench/example/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2023 QBayLogic B.V. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/clash-testbench/example/Main.hs b/clash-testbench/example/Main.hs new file mode 100644 index 0000000000..d088d0d7a3 --- /dev/null +++ b/clash-testbench/example/Main.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Data.Bool (bool) + +import Clash.Prelude (Signal, Clock, Reset, Enable, Signed, System, exposeClockResetEnable, register, bundle, unsafeFromReset, hasReset, fromEnable, hasEnable) + +import Clash.Testbench + +import Calculator (OPC(..)) +--import qualified Calculator (topEntity) +import qualified Register (topEntity) +import qualified RegisterFail (topEntity) + +import Control.Monad (void) +import Control.Monad.IO.Class +import Clash.Hedgehog.Sized.Signed +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +{- +genIO :: Gen [(OPC (Signed 4), Maybe (Signed 4))] +genIO = do + -- generate 7 constants + cs <- Gen.list (Range.singleton 7) (genSigned Range.constantBounded) + -- generate 6 operations + ops <- map (bool (ADD, (+)) (MUL, (*))) <$> Gen.list (Range.singleton 6) Gen.bool + + let + -- push the constants to the stack + in1 = concatMap ((: [Push]) . Imm) cs -- inputs + eo1 = concatMap ((: [Nothing]) . Just) cs -- expected outputs + + -- calculate the results of the applied operations + x : xr = reverse cs + rs = [ foldl (\a (op, b) -> op a b) x $ zip (map snd ops) $ take n xr + | n <- [1,2..length xr] + ] + + -- apply the operations + in2 = concatMap ((replicate 3 Pop <>) . pure . fst) ops -- inputs + eo2 = concatMap ((replicate 3 Nothing <>) . pure . Just) rs -- expected outputs + + return $ zip (in1 <> in2) (eo1 <> eo2) + +myTestbench + :: TB () +myTestbench = mdo + input <- fromList Pop [Imm 1, Push, Imm 2, Push, Pop, Pop, Pop, ADD] +-- input <- matchIOGenN output genIO + output <- ("topEntity" @@ Calculator.topEntity) auto auto auto input + watch input + watch output +-} + +rstenb + :: Clock System + -> Reset System + -> Enable System + -> Signal System (Bool, Bool) +rstenb = exposeClockResetEnable + $ bundle (unsafeFromReset hasReset, fromEnable hasEnable) + +myTestbench + :: TB () +myTestbench = mdo + input <- matchIOGenN output $ do + cs <- Gen.list (Range.singleton 7) (genSigned Range.constantBounded) + return $ ((0,0) :) $ zip cs $ 0 : cs + output <- ("topEntity" @@ Register.topEntity) auto auto auto input +-- x <- ("rstenb" @@ rstenb) auto auto auto +-- watch x + watch input + watch output + +myTestbenchFail + :: TB () +myTestbenchFail = mdo + input <- matchIOGenN output $ do + cs <- Gen.list (Range.singleton 7) (genSigned Range.constantBounded) + return $ ((0,0) :) $ zip cs $ 0 : cs + output <- ("topEntity" @@ RegisterFail.topEntity) auto auto auto input +-- x <- ("rstenb" @@ rstenb) auto auto auto +-- watch x + watch input + watch output + + +main :: IO () +main = +-- simulate 10 myTestbench + void $ checkParallel $ Group "Default" + [ ("'successful test'", withTests 1 $ tbProperty myTestbench) + , ("'failing test'", withTests 1 $ tbProperty myTestbenchFail) + ] + +foreign export ccall "clash_ffi_main" + ffiMain :: IO () + +ffiMain :: IO () +ffiMain = do +-- simulateFFI (SimSettings False False) myTestbench + sync <- ffiHedgehog + ffiCheckGroup sync $ Group "Default" + [ ("'successful test'", withTests 1 $ (tbPropertyFFI sync) myTestbench) +-- [ ("'failing test'", withTests 1 $ (tbPropertyFFI sync) myTestbenchFail) + ] diff --git a/clash-testbench/example/Register.hs b/clash-testbench/example/Register.hs new file mode 100644 index 0000000000..02f94efaab --- /dev/null +++ b/clash-testbench/example/Register.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE DataKinds #-} +module Register where + +import Clash.Prelude + +topEntity + :: Clock System + -> Reset System + -> Enable System + -> Signal System (Signed 4) + -> Signal System (Signed 4) + +topEntity = exposeClockResetEnable reg + where + reg i = register 0 i diff --git a/clash-testbench/example/RegisterFail.hs b/clash-testbench/example/RegisterFail.hs new file mode 100644 index 0000000000..9f9bcc5462 --- /dev/null +++ b/clash-testbench/example/RegisterFail.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DataKinds #-} +module RegisterFail where + +import Clash.Prelude + +topEntity + :: Clock System + -> Reset System + -> Enable System + -> Signal System (Signed 4) + -> Signal System (Signed 4) + +topEntity = exposeClockResetEnable regFail + where + reg i = register 0 i + + count :: + HiddenClockResetEnable dom => + Signal dom (Signed 3) + count = + register 0 ((+1) <$> count) + + regFail :: + HiddenClockResetEnable dom => + Signal dom (Signed 4) -> + Signal dom (Signed 4) + + regFail = + mux ((== 4) <$> count) 0 . reg + + diff --git a/clash-testbench/example/Setup.hs b/clash-testbench/example/Setup.hs new file mode 100644 index 0000000000..44aa2fdebb --- /dev/null +++ b/clash-testbench/example/Setup.hs @@ -0,0 +1,91 @@ +module Main where + +import Control.Monad +import Data.Maybe +import Distribution.PackageDescription.Utils +import Distribution.Simple +import Distribution.Simple.Build +import Distribution.Simple.BuildPaths +import Distribution.Simple.Setup +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Types.ForeignLib +import Distribution.Types.ForeignLibType +import Distribution.Types.GenericPackageDescription +import Distribution.Types.HookedBuildInfo +import Distribution.Types.LocalBuildInfo +import Distribution.Types.PackageDescription +import Distribution.Types.UnqualComponentName +import Distribution.Verbosity +import System.Directory +import System.FilePath + +main :: IO () +main = + defaultMainWithHooks simpleUserHooks + { postBuild = ffiPostBuild } + +ffiPostBuild + :: Args + -> BuildFlags + -> PackageDescription + -> LocalBuildInfo + -> IO () +ffiPostBuild args flags desc info = do + -- Create lib/ in the project directory + let outPath = takeDirectory (fromJust $ pkgDescrFile info) "lib" + createDirectoryIfMissing True outPath + + -- Copy each foreign library to lib/ + forM_ (foreignLibs desc) $ \flib -> + let name = unUnqualComponentName (foreignLibName flib) + dLib = buildDir info name flibTargetName info flib + in copySoAsVpl outPath dLib + + -- Do the normal post-build hook action + postBuild simpleUserHooks args flags desc info + +-- | Get the name of the library that will be written to disk when building +-- the library. Lifted from `Distribution.Simple.GHC`. +-- +flibTargetName :: LocalBuildInfo -> ForeignLib -> String +flibTargetName lbi flib = + case (os, foreignLibType flib) of + (Windows, ForeignLibNativeShared) -> nm <.> "dll" + (Windows, ForeignLibNativeStatic) -> nm <.> "lib" + (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt + (_other, ForeignLibNativeShared) -> + "lib" ++ nm <.> dllExtension (hostPlatform lbi) + (_other, ForeignLibNativeStatic) -> + "lib" ++ nm <.> staticLibExtension (hostPlatform lbi) + (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type" + where + nm :: String + nm = unUnqualComponentName $ foreignLibName flib + + os :: OS + os = let (Platform _ os') = hostPlatform lbi + in os' + + -- If a foreign lib foo has lib-version-info 5:1:2 or + -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1 + -- Libtool's version-info data is translated into library versions in a + -- nontrivial way: so refer to libtool documentation. + versionedExt :: String + versionedExt = + let nums = foreignLibVersion flib os + in foldl (<.>) "so" (map show nums) + +-- | Copy a file to the same directory, but change the extension to .vpl. This +-- is needed for iverilog, as it will not load VPI modules which do not have +-- either a .vpi or .vpl extension, unlike other simulators which will load +-- the .so file that cabal normally produces. +-- +copySoAsVpl :: FilePath -> FilePath -> IO () +copySoAsVpl outDir so = + -- We use installMaybeExecutable file because it preserves the permissions + -- of the original file. On my machine, just using installExecutableFile + -- meant the permissions were *slightly* different. + let outPath = replaceDirectory (replaceExtensions so "vpl") outDir + in installMaybeExecutableFile verbose so outPath + diff --git a/clash-testbench/example/cabal.project b/clash-testbench/example/cabal.project new file mode 100644 index 0000000000..220cf06d39 --- /dev/null +++ b/clash-testbench/example/cabal.project @@ -0,0 +1,6 @@ +packages: . .. ../../clash-ghc ../../clash-lib ../../clash-prelude ../../clash-ffi ../../clash-prelude-hedgehog + +write-ghc-environment-files: always + +--package * +-- ghc-options: -fPIC -shared diff --git a/clash-testbench/example/clash-testbench-example.cabal b/clash-testbench/example/clash-testbench-example.cabal new file mode 100644 index 0000000000..00163139ee --- /dev/null +++ b/clash-testbench/example/clash-testbench-example.cabal @@ -0,0 +1,57 @@ +cabal-version: 2.4 +name: clash-testbench-example +version: 0.1.0.0 +synopsis: Exmaple for using clash-testbench +description: Exmaple for using clash-testbench +bug-reports: https://github.com/clash-lang/clash-compiler/issues +license: BSD-2-Clause +license-file: LICENSE +author: QBayLogic B.V. +maintainer: devops@qbaylogic.com +copyright: Copyright © 2023, QBayLogic B.V. +category: Hardware + +common basic-config + default-language: Haskell2010 + ghc-options: + -Wall -Wcompat -threaded + -fplugin GHC.TypeLits.Extra.Solver + -fplugin GHC.TypeLits.Normalise + -fplugin GHC.TypeLits.KnownNat.Solver + build-depends: + base, + hedgehog, + clash-prelude, + clash-prelude-hedgehog, + clash-testbench, + ghc-typelits-extra, + ghc-typelits-knownnat, + ghc-typelits-natnormalise, + +custom-setup + setup-depends: + base >= 4.11 && < 5, + Cabal >= 2.4 && < 3.7, + directory >= 1.3.6 && < 1.4, + filepath >= 1.4.2 && < 1.5, + +executable simulate + import: basic-config + main-is: Main.hs + other-modules: Calculator + Register + RegisterFail + -- this option is required, since clash-ffi and clash-testbench come + -- with unresovled symbols for the VPI interface + ghc-options: -optl -Wl,--unresolved-symbols=ignore-in-object-files + + +foreign-library simulate-ffi + import: basic-config + other-modules: Main + Calculator + Register + RegisterFail + type: native-shared +-- options: standalone + lib-version-info: 0:1:0 diff --git a/clash-testbench/example/run-iverilog.sh b/clash-testbench/example/run-iverilog.sh new file mode 100755 index 0000000000..8b19ff42b4 --- /dev/null +++ b/clash-testbench/example/run-iverilog.sh @@ -0,0 +1,36 @@ +#!/bin/sh + +# This is just a minimalistic script for demonstrating the process of +# running the clash-testbench example using the Icarus Verilog VVP +# runtime engine. The script is not designed to work in any possible +# system environment and may not work immediately for you. It is +# intended to serve as an easy starter instead. Adapt it to your needs +# if it's not working out-of-the-box for you. + +############################### + +# Adjust these variables if the tools are not in your PATH already + +# Cabal +# https://www.haskell.org/cabal +CABAL=cabal +# Clash +# https://github.com/clash-lang/clash-compiler +CLASH="${CABAL} run clash --" +# Icarus Verilog VVP runtime engine +# http://iverilog.icarus.com +IVERILOG=iverilog +VVP=vvp + +############################### + +${CABAL} build clash-testbench-example || exit $? +${CLASH} --verilog Calculator.hs || exit $? +${CLASH} --verilog Register.hs || exit $? +${CLASH} --verilog RegisterFail.hs || exit $? +${IVERILOG} verilog/Register.topEntity/topEntity.v -o Register.vvp \ + || exit $? +echo "" +echo "Running Icarus Verilog VVP runtime engine:" +echo "" +${VVP} -Mlib -mlibsimulate-ffi Register.vvp diff --git a/clash-testbench/src/Clash/Testbench.hs b/clash-testbench/src/Clash/Testbench.hs new file mode 100644 index 0000000000..42944de6ea --- /dev/null +++ b/clash-testbench/src/Clash/Testbench.hs @@ -0,0 +1,20 @@ +{-| +Copyright: (C) 2023 Google Inc. +License: BSD2 (see the file LICENSE) +Maintainer: QBayLogic B.V. + +Design your TestBenches in Clash +-} +module Clash.Testbench + ( module Clash.Testbench.Signal + , module Clash.Testbench.Input + , module Clash.Testbench.Output + , module Clash.Testbench.Simulate + , module Clash.Testbench.Generate + ) where + +import Clash.Testbench.Signal +import Clash.Testbench.Input +import Clash.Testbench.Output +import Clash.Testbench.Simulate +import Clash.Testbench.Generate diff --git a/clash-testbench/src/Clash/Testbench/Generate.hs b/clash-testbench/src/Clash/Testbench/Generate.hs new file mode 100644 index 0000000000..a3b48ac66e --- /dev/null +++ b/clash-testbench/src/Clash/Testbench/Generate.hs @@ -0,0 +1,226 @@ +{-| +Copyright: (C) 2023 Google Inc. +License: BSD2 (see the file LICENSE) +Maintainer: QBayLogic B.V. + +Use generators to create signal data. +-} + +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +module Clash.Testbench.Generate where + +import Hedgehog +import Hedgehog.Gen +import Control.Monad.Extra ((), (<:>)) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.State.Lazy (liftIO, when, modify) +import Data.IORef (newIORef, readIORef, writeIORef) + +import Clash.Prelude (KnownDomain(..), BitPack(..), NFDataX) + +import Clash.Testbench.Signal +import Clash.Testbench.Internal.ID +import Clash.Testbench.Internal.Signal hiding (TBSignal, TBClock, TBReset, TBEnable) +import Clash.Testbench.Internal.Monad + +-- | Use a generator to create new signal data at every simulation +-- step. +generate :: + forall dom a. + (NFDataX a, BitPack a, KnownDomain dom) => + Gen a -> TB (TBSignal dom a) +generate gen = do + TBDomain{..} <- tbDomain @dom + + vRef <- liftIO $ newIORef undefined + ifProgress <- progressCheck simStepRef True + signalHistory <- newHistory + + mind SomeSignal IOInput + { signalId = NoID + , signalCurVal = const $ ifProgress + do + x <- sample gen + writeIORef vRef x + memorize signalHistory x + return x + <:> + readIORef vRef + , signalPrint = Nothing + , .. + } + +-- | Extended version of 'generate', which allows to generate a finite +-- sequence of data values, where one value is consumed per simulation +-- step. The generator is repeatedly called after all steps of a +-- generation has been consumed. +generateN :: + forall dom a. + (NFDataX a, BitPack a, KnownDomain dom) => + a -> Gen [a] -> TB (TBSignal dom a) +generateN def gen = do + TBDomain{..} <- tbDomain @dom + + vRef <- liftIO $ newIORef [def] + ifProgress <- progressCheck simStepRef False + signalHistory <- newHistory + + mind SomeSignal IOInput + { signalId = NoID + , signalCurVal = const $ ifProgress + readIORef vRef >>= \case + h : x : xr -> do + memorize signalHistory h + writeIORef vRef (x : xr) + return x + [h] -> do + memorize signalHistory h + x : xr <- sample gen + writeIORef vRef (x : xr) + return x + _ -> error "unreachable" + <:> readIORef vRef >>= \case + x : _ -> return x + [] -> do + x : xr <- sample gen + writeIORef vRef (x : xr) + return x + , signalPrint = Nothing + , .. + } + +-- | Use an input/output generator to describe an IO relation that +-- specifies valid behavior. The satisfaction of this relation is +-- automatically checked during simulation. +matchIOGen :: + forall dom i o. + (NFDataX i, BitPack i, KnownDomain dom, Eq o, Show o) => + TBSignal dom o -> Gen (i, o) -> TB (TBSignal dom i) +matchIOGen checkedOutput gen = do + TBDomain{..} <- tbDomain @dom + + vRef <- liftIO $ newIORef undefined + ifProgress <- progressCheck simStepRef False + signalHistory <- newHistory + + mind SomeSignal $ IOInput + { signalId = NoID + , signalCurVal = const $ ifProgress + do + (input, expectedOutput) <- sample gen + curStep <- readIORef simStepRef + signalExpect checkedOutput $ Expectation (curStep, verifier expectedOutput) + writeIORef vRef input + return input + <:> + readIORef vRef + , signalPrint = Nothing + , .. + } + + where + verifier :: o -> o -> Verifier + verifier expectedOutput observedOutput = Verifier $ \case + Simple -> checkDifferenceWith error undefined + Hedgehog -> checkDifferenceWith footnote (expectedOutput === observedOutput) + where + checkDifferenceWith :: MonadIO m => (String -> m ()) -> m () -> m () + checkDifferenceWith report abort = + when (expectedOutput /= observedOutput) $ do + report + $ "Expected to see the output '" <> show expectedOutput <> "'," + <> "but the observed output is '" <> show observedOutput <> "'." + abort + +-- | Extended version of 'matchIOGen', which allows to specify valid +-- IO behavior over a finite amount of simulation steps. During native +-- simulation (no property check), the generator is repeatedly called +-- after all the generated simulation steps have been consumed. The +-- generator is only called once if the test bench is converted to a +-- property instead. +matchIOGenN :: + forall dom i o. + (NFDataX i, BitPack i, KnownDomain dom, Eq o, Show o, Show i) => + TBSignal dom o -> Gen [(i, o)] -> TB (TBSignal dom i) +matchIOGenN checkedOutput gen = mdo + TBDomain{..} <- tbDomain @dom + + xs <- liftIO $ sample gen + modify $ \st@ST{..} -> st { simSteps = max simSteps $ length xs } + + vRef <- liftIO $ newIORef xs + ifProgress <- progressCheck simStepRef False + signalHistory <- newHistory + + s <- mind SomeSignal $ IOInput + { signalId = NoID + , signalCurVal = const $ ifProgress + readIORef vRef >>= \case + (h, _) : (i, o) : xr -> do + memorize signalHistory h + writeIORef vRef ((i, o) : xr) + curStep <- readIORef simStepRef + signalExpect checkedOutput $ Expectation (curStep, verifier s i o) + return i + [(h, _)] -> do + memorize signalHistory h + (i, o) : xr <- sample gen + + writeIORef vRef ((i, o) : xr) + curStep <- readIORef simStepRef + signalExpect checkedOutput $ Expectation (curStep, verifier s i o) + return i + _ -> error "unreachable" + <:> readIORef vRef >>= \case + (i, _) : _ -> return i + [] -> do + (i, o) : xr <- sample gen + writeIORef vRef ((i, o) : xr) + Prelude.print $ (i, o) : xr + return i + , signalPrint = Nothing + , .. + } + + return s + + where + verifier :: TBSignal dom i -> i -> o -> o -> Verifier + verifier generatedInput currentInput expectedOutput observedOutput = + Verifier $ \case + Simple -> checkDifferenceWith error undefined + Hedgehog -> checkDifferenceWith footnote failure + where + checkDifferenceWith :: MonadIO m => (String -> m ()) -> m () -> m () + checkDifferenceWith report abort = do + xs <- + (<> [(currentInput, observedOutput)]) + <$> (zip <$> history generatedInput <*> history checkedOutput) + + let + cHeading = "Cycle" + iHeading = "Input" + oHeading = "Output" + cLen = length cHeading + iLen = maximum $ (length iHeading :) $ fmap (length . show . fst) xs + oLen = maximum $ (length oHeading :) $ fmap (length . show . snd) xs + + when (expectedOutput /= observedOutput) $ do + report $ unlines $ + [ "Expected to see the output '" <> show expectedOutput <> "'," + , "but the observed output is '" <> show observedOutput <> "'." + , "" + , "I/O History:" + , "" + , cHeading <> + replicate (iLen - length iHeading + 2) ' ' <> iHeading <> + replicate (oLen - length oHeading + 2) ' ' <> oHeading + , replicate (cLen + iLen + oLen + 4) '-' + ] <> + [ replicate (cLen - length (show c)) ' ' <> show c <> + replicate (iLen - length (show i) + 2) ' ' <> show i <> + replicate (oLen - length (show o) + 2) ' ' <> show o + | (c, (i, o)) <- zip [0 :: Int,1..] xs + ] + abort diff --git a/clash-testbench/src/Clash/Testbench/Input.hs b/clash-testbench/src/Clash/Testbench/Input.hs new file mode 100644 index 0000000000..764ed4eb70 --- /dev/null +++ b/clash-testbench/src/Clash/Testbench/Input.hs @@ -0,0 +1,80 @@ +{-| +Copyright: (C) 2023 Google Inc. +License: BSD2 (see the file LICENSE) +Maintainer: QBayLogic B.V. + +Input sources for simulating 'Clash.Testbench.Simulate.TB' defined +test benches. +-} +module Clash.Testbench.Input + ( fromList + ) where + +import Control.Monad.State.Lazy +import Data.IORef + +import Clash.Prelude (KnownDomain(..), BitPack(..), NFDataX) + +import Clash.Testbench.Signal (TBSignal) +import Clash.Testbench.Internal.Signal hiding (TBSignal) +import Clash.Testbench.Internal.Monad +import Clash.Testbench.Internal.ID + +-- | The mode defines how to expand finite lists towards infinite +-- ones. If a list is already infinite, then it does not matter which +-- mode is chosen at this point. +data ExpansionMode a = + Repeat + -- ^ Repeat a finite list indefinitely. This mode causes an error + -- if the list to be repeated is the empty list. + | Default a + -- ^ Repeat a given default value after the end of a finite list + -- has been reached. + | IsInfinite + -- ^ The list has to be infinite. This mode causes an error if the + -- end of a finite list is reached. + +-- | Creates an input signal whose values are taken from a finite or +-- infinite list. If the list is finite and the number of simulation +-- steps exceeds the length of the list, then the value of the first +-- argument is used repeatedly. +fromList :: forall dom a. + (KnownDomain dom, BitPack a, NFDataX a) => + ExpansionMode a -> [a] -> TB (TBSignal dom a) + +fromList Repeat [] = + error $ "Clash.Testbench.Input.fromList: " + <> "The empty list cannot be repeated indefinitely." + +fromList mode xs = do + TBDomain{..} <- tbDomain @dom + + vRef <- liftIO $ newIORef xs + checkForProgress <- progressCheck simStepRef False + signalHistory <- newHistory + + let + signalCurVal m = do + x : xr <- readIORef vRef >>= return . \case + [] -> case mode of + Repeat -> xs + Default v -> [v] + IsInfinite -> error $ "Clash.Testbench.Input.fromList: " + <> "end of list reached" + yr -> yr + + progress <- checkForProgress + + if progress + then do + memorize signalHistory x + writeIORef vRef xr + signalCurVal m + else + return x + + mind SomeSignal $ IOInput + { signalId = NoID + , signalPrint = Nothing + , .. + } diff --git a/clash-testbench/src/Clash/Testbench/Internal/ID.hs b/clash-testbench/src/Clash/Testbench/Internal/ID.hs new file mode 100644 index 0000000000..261000ff3c --- /dev/null +++ b/clash-testbench/src/Clash/Testbench/Internal/ID.hs @@ -0,0 +1,210 @@ +{-| +Copyright: (C) 2023 Google Inc. +License: BSD2 (see the file LICENSE) +Maintainer: QBayLogic B.V. + +'Clash.Testbench.Simulate.TB' lifted signals. +-} + +module Clash.Testbench.Internal.ID + ( SIGNAL + , DOMAIN + , IDT + , ID(..) + , MID(..) + , idToInt + ) where + +import GHC.Arr (Ix(..)) + +-- | ID reference for the standard Clash 'Clash.Signal.Signal' type. +data SIGNAL +-- | ID reference for domain specific special Clash types like +-- 'Clash.Internal.Signal.Clock', 'Clash.Internal.Signal.Reset', or +-- 'Clash.Internal.Signal.Enable'. +data DOMAIN + +-- | Some closed type family used for capturing the available ID types. +type family IDT a where + IDT DOMAIN = DOMAIN + IDT a = SIGNAL + +-- | The ID data constructors for holding the different ID types. +data ID a where + -- the pool of free IDs + FreeID :: Int -> ID Int + -- the different ID types + SignalID :: Int -> ID SIGNAL + ClockID :: Int -> ID DOMAIN + ResetID :: Int -> ID DOMAIN + EnableID :: Int -> ID DOMAIN + -- signals that result from higher order transformations may not be + -- tracked explicitly + NoID :: ID SIGNAL + -- wrapper type for passing different ID types around. Note that IDs + -- of the free id pool are excluded here. + SomeID :: (a ~ IDT a) => ID a -> ID () + +-- | Accesses the encapsulated 'Int' of an 'ID'. Note that 'NoID' is +-- mapped to zero. Hence, 'SignalID' should only be used on positive +-- values to ensure proper behavior. +idToInt :: ID a -> Int +idToInt = \case + FreeID x -> x + SignalID x -> x + ClockID x -> x + ResetID x -> x + EnableID x -> x + NoID -> 0 + SomeID x -> idToInt x + +-- | ID context switch, guarded via 'Maybe'. +class MID a where + mID :: ID b -> Maybe (ID a) + +instance MID () where + mID = \case + x@SomeID{} -> Just x + _ -> Nothing + +instance MID Int where + mID = \case + x@FreeID{} -> Just x + _ -> Nothing + +instance MID SIGNAL where + mID = \case + x@NoID{} -> Just x + x@SignalID{} -> Just x + SomeID x -> mID x + _ -> Nothing + +instance MID DOMAIN where + mID = \case + x@ClockID{} -> Just x + x@ResetID{} -> Just x + x@EnableID{} -> Just x + SomeID x -> mID x + _ -> Nothing + +instance Num (ID Int) where + FreeID x + FreeID y = FreeID $ x + y + FreeID x - FreeID y = FreeID $ x - y + FreeID x * FreeID y = FreeID $ x * y + abs (FreeID x) = FreeID $ abs x + signum (FreeID x) = FreeID $ signum x + fromInteger = FreeID . fromInteger + +instance Eq (ID a) where + (==) = \case + FreeID x -> \case + FreeID y -> x == y + SignalID x -> \case + SignalID y -> x == y + _ -> False + NoID -> \case + NoID -> True + _ -> False + ClockID x -> \case + ClockID y -> x == y + _ -> False + ResetID x -> \case + ResetID y -> x == y + _ -> False + EnableID x -> \case + EnableID y -> x == y + _ -> False + SomeID x -> \case + SomeID y -> case x of + z@SignalID{} -> (==) (Just z) $ mID y + z@NoID{} -> (==) (Just z) $ mID y + z@ClockID{} -> (==) (Just z) $ mID y + z@ResetID{} -> (==) (Just z) $ mID y + z@EnableID{} -> (==) (Just z) $ mID y + +instance Ord (ID a) where + compare = \case + FreeID x -> \case + FreeID y -> compare x y + SignalID x -> \case + SignalID y -> compare x y + NoID -> GT + NoID -> \case + NoID -> EQ + SignalID{} -> LT + ClockID x -> \y -> case compare x $ idToInt y of + EQ -> case y of + ClockID{} -> EQ + _ -> LT + v -> v + ResetID x -> \y -> case compare x $ idToInt y of + EQ -> case y of + ClockID{} -> GT + ResetID{} -> EQ + EnableID{} -> LT + v -> v + EnableID x -> \y -> case compare x $ idToInt y of + EQ -> case y of + EnableID{} -> EQ + _ -> GT + v -> v + SomeID x -> \case + SomeID y -> case x of + z@SignalID{} -> maybe LT (compare z) $ mID y + z@NoID{} -> maybe LT (compare z) $ mID y + z@ClockID{} -> maybe GT (compare z) $ mID y + z@ResetID{} -> maybe GT (compare z) $ mID y + z@EnableID{} -> maybe GT (compare z) $ mID y + +instance Show (ID a) where + show = \case + FreeID x -> show x + SignalID x -> 's' : show x + NoID -> "-" + ClockID x -> 'c' : show x + ResetID x -> 'r' : show x + EnableID x -> 'e' : show x + SomeID x -> show x + +instance Ix (ID SIGNAL) where + {-# INLINE range #-} + range (NoID, NoID ) = [NoID] + range (NoID, SignalID x) = NoID : map SignalID (range (1,x)) + range (SignalID x, SignalID y) = map SignalID (range (x,y)) + range (SignalID _, NoID ) = [] + + {-# INLINE unsafeIndex #-} + unsafeIndex _ = \case + NoID -> 0 + SignalID x -> x + + {-# INLINE index #-} + index b i + | inRange b i = unsafeIndex b i + | otherwise = error $ "Index " <> show i <> " out of range: " <> show b + + + {-# INLINE inRange #-} + inRange (NoID, NoID) = (NoID ==) + inRange (NoID, SignalID x) = \case + NoID -> True + SignalID i -> inRange (1, x) i + inRange (SignalID x, SignalID y) = \case + NoID -> False + SignalID i -> inRange (x, y) i + inRange (SignalID _, NoID) = const False + +instance Ix (ID DOMAIN) where + {-# INLINE range #-} + range (x, y) = map ClockID $ range (idToInt x, idToInt y) + + {-# INLINE unsafeIndex #-} + unsafeIndex = const idToInt + + {-# INLINE index #-} + index b i + | inRange b i = unsafeIndex b i + | otherwise = error $ "Index " <> show i <> " out of range: " <> show b + + {-# INLINE inRange #-} + inRange (x, y) = inRange (idToInt x, idToInt y) . idToInt diff --git a/clash-testbench/src/Clash/Testbench/Internal/Monad.hs b/clash-testbench/src/Clash/Testbench/Internal/Monad.hs new file mode 100644 index 0000000000..265c90e4d5 --- /dev/null +++ b/clash-testbench/src/Clash/Testbench/Internal/Monad.hs @@ -0,0 +1,715 @@ +{-| +Copyright: (C) 2023 Google Inc. +License: BSD2 (see the file LICENSE) +Maintainer: QBayLogic B.V. + +The monadic 'Clash.Testbench.Simulate.TB' context used for test +bench creation (internal module). +-} + +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} +module Clash.Testbench.Internal.Monad + ( KnownSignals + , KnownDomains + , Testbench(..) + , TB + , ST(..) + , LiftAcc(..) + , ArgOf + , LiftTBSignalConstraints + , LiftTB(..) + , runTB + , tbDomain + , mind + , progressCheck + , newHistory + , memorize + , history + ) where + +import Data.Bifunctor (bimap) +import Data.Function (on) +import Data.Type.Equality +import Algebra.PartialOrd +import Control.Monad.Extra ((), (<:>)) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.State.Lazy + (StateT, liftIO, get, gets, modify, evalStateT, forM_, void, when) +import Data.Function ((&)) +import Data.Array.IO (newArray, writeArray, getElems) +import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) +import Data.List (partition, sort, sortBy, groupBy) +import Data.Maybe (catMaybes) + +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import qualified Data.Array as A + +import Clash.Prelude + ( KnownDomain(..), BitPack(..), SDomainConfiguration(..), NFDataX + , Enable, Clock, Reset + , ssymbolToString, clockGen, resetGen, enableGen, sameDomain + , unsafeToReset, unsafeFromReset, toEnable, fromEnable + ) +import Clash.Signal.Internal + ( Signal(..), head#, tail# + ) + +import Clash.Testbench.Signal +import Clash.Testbench.Internal.ID +import Clash.Testbench.Internal.Signal hiding (TBSignal, TBClock, TBReset, TBEnable) +import Clash.Testbench.Internal.Signal + ( pattern TBSignal, pattern TBClock, pattern TBReset, pattern TBEnable + ) +import qualified Clash.Testbench.Internal.Signal as Internal + +-- | The test bench signals that have been captured during test +-- bench creation. +type KnownSignals (s :: Stage) = S.Set (SomeSignal s) + +-- | The test bench domains that have been captured during test bench +-- creation. +type KnownDomains (s :: Stage) = M.Map String (SomeDomain s) + +-- | The internal state that is manipulated during test bench +-- creation. +data ST = + ST + { idSigCount :: ID Int + -- ^ Counter for generating free IDs to be assigned to signal + -- (functions) + , signals :: KnownSignals 'USER + -- ^ Captured signal (functions) + , idDomCount :: ID Int + -- ^ Counter for generating free IDs to be assigned to domains + , domains :: KnownDomains 'USER + -- ^ Captured domains + , simSteps :: Int + -- ^ Simulation step preset + , defaultHistorySize :: Int + -- ^ Default size of the history for all simulated signals, as + -- long as not explicitly overwritten per signal. + } + +instance Show ST where + show ST{..} = + "ST {" + <> show idSigCount <> ", " + <> show (S.toAscList signals) <> ", " + <> show idDomCount <> ", " + <> show (M.toAscList domains) + <> "}" + +-- | A 'Testbench' is the result of finalizing the test bench creation +-- environment inside the 'TB' context. +data Testbench = + Testbench + { tbSignals :: [SomeSignal 'FINAL] + -- ^ All captured signals + , tbSignalLookup :: A.Array (ID SIGNAL) (SomeSignal 'FINAL) + -- ^ Signal lookup via ID (partial array) + , tbDomains :: [(SomeDomain 'FINAL, [ID SIGNAL])] + -- ^ All captured domains + references to the captured signals + -- that are driven by this domain + , tbDomainLookup :: A.Array (ID DOMAIN) (SomeDomain 'FINAL) + -- ^ Domain lookup via ID (partial array) + , tbSimSteps :: Int + -- ^ Simulation step preset + } +instance Show Testbench where + show Testbench{..} = + "Testbench {" + <> show tbSignals <> ", " + <> show tbDomains <> "}" + +-- | The 'TB' monad defines the context in which the test bench gets +-- created by the user. Within the 'TB' context, the user can lift any +-- Clash 'Clash.Signal.Signal' or signal function into the context +-- using the '@@' operator. The lifted signal (function) then can be +-- applied to 'IO' driven inputs or the outputs of the lifted signal +-- can be post-processed inside 'IO'. +-- +-- Note that 'TB' offers a construction environment, i.e., it is used +-- to describe the test bench structure. The test bench is not +-- executed inside 'TB'. +type TB a = StateT ST IO a + +-- | Some type family to access the argument of a function. +type family ArgOf a where + ArgOf (a -> b) = a + +-- | The accumulator state is used to redirect the input for the +-- arguments (resulting from the execution of some 'IO') to the signal +-- transformer. Due to the polyvariadic nature of the 'LiftTB' class +-- (used to support lifting signal functions of any arity), the +-- arguments must be processed in a tail recursive fashion. Moreover, +-- the 'IO' that produces the values to be passed to the signal +-- transformer cannot be executed nor can time proceed until we have +-- processed all arguments. Therefore, to accomplish the +-- transformation, we instead build a transformer, which is extended +-- for each argument (step by step) and is finally applied to the +-- signal (function) at once. We call this operation the "continuation +-- transformation", as it captures the application of the signal +-- function on it's inputs at the current point in time and the signal +-- transformation to be applied at the next point in time. +-- +-- Moreover, the accumulator state captures some information that is +-- collected initially and during traversal of the arguments to be +-- available for creation of the lifted signal (function) in the end. +data LiftAcc a b = + LiftAcc + { name :: String + -- ^ The name of the lifted signal (function) + , deps :: [ID ()] + -- ^ The dependencies of the lifted signal (function) + , sfRef :: IORef b + -- ^ Some IO reference to the lifted signal (function) + , cont :: IO (a, (a -> a) -> b -> b) + -- ^ The continuation transformation of the lifted signal + -- (function) + } + +-- | Lift clash circuitry into 'TB'. +class LiftTB a where + -- | The operator lifts a signal or signal function into 'TB'. As + -- the operator is polyvariadic lifting functions of any arity and + -- shape is supported. Additionally, every lifted signal (function) + -- must be given a name, which is used to identify the top module in + -- case the resulting test bench gets simulated using an external + -- simulator. + (@@) :: String -> a + + -- | Internal lift for traversing the arguments and the result of + -- the given signal function. + liftTB :: TB (LiftAcc (ArgOf a) b) -> a + +-- | 'LiftTB' instance constraints for lifting a Clash +-- 'Clash.Signal.Signal' into a test bench +-- 'Clash.Testbench.Signal.TBSignal'. +type LiftTBSignalConstraints domA domB a a' = + ( KnownDomain domA, KnownDomain domB + , domA ~ domB, a ~ a' + , NFDataX a, BitPack a + , Show a + ) + +instance + LiftTBSignalConstraints domA domB a a' => + LiftTB (Signal domA a -> TB (TBSignal domB a')) + where + (@@) = initializeLiftTB + + liftTB exec signalOrigin = do + extVal <- liftIO $ newIORef Nothing + expectations <- liftIO $ newIORef [] + + LiftAcc{..} <- exec + TBDomain{..} <- tbDomain @domA + -- Initial progress ensures that the value reference and the + -- signal function reference are updated immediately after the + -- first call to `signalCurVal`, which is required for the first + -- continuation transformation to be applied on the initial + -- values. + ifProgress <- progressCheck simStepRef True + vRef <- liftIO $ newIORef undefined + signalHistory <- newHistory + + let + signalCurVal = \case + Internal -> ifProgress + do + (head# -> x, step) <- cont + writeIORef vRef x + modifyIORef sfRef $ step tail# + + -- update the history + memorize signalHistory x + + return x + <:> + readIORef vRef + + External -> readIORef extVal >>= \case + Nothing -> error "No Value @Signal" + Just x -> ifProgress + memorize signalHistory x >> return x + <:> return x + + mind SomeSignal $ Internal.SimSignal + { signalId = NoID + , signalDeps = reverse deps + , signalName = name + , signalUpdate = Just (writeIORef extVal . Just) + , signalExpect = modifyIORef expectations . (:) + , signalVerify = \sMode -> Verifier $ \vMode -> do + curStep <- liftIO $ readIORef simStepRef + value <- liftIO $ signalCurVal sMode + expcts <- liftIO $ readIORef expectations + + let sepAt n = partition (`leq` Expectation (n, undefined)) + (xs, later) = sepAt curStep expcts + (_, current) = sepAt (curStep - 1) xs + + liftIO $ writeIORef expectations (current <> later) + mapM_ ((`verifier` vMode) . (value &) . snd . expectation) current + , signalPrint = Nothing + , signalPlug = Nothing + , .. + } + +instance + ( KnownDomain dom, LiftTB (b -> c) + , arg ~ TBSignal dom a + ) => LiftTB ((Signal dom a -> b) -> arg -> c) + where + (@@) = initializeLiftTB + + liftTB a sf s = liftTB (upd <$> a) $ sf $ signalOrigin s + where + upd acc@LiftAcc{..} = + acc { deps = SomeID (signalId s) : deps + , cont = extendVia cont + (signalCurVal s Internal) + pure + (\v f sf' -> f . sf' . (v :-)) + } + +instance + ( KnownDomain dom, LiftTB (b -> c) + , arg ~ TBClock dom + ) => LiftTB ((Clock dom -> b) -> arg -> c) + where + (@@) = initializeLiftTB + + liftTB a sf c = liftTB (upd <$> knownClock c <*> a) $ sf $ clock c + where + knownClock = \case + tbc@TBClock{} -> return tbc + AutoClock -> do + tbd@TBDomain{..} <- tbDomain + case domainClock of + Just tbc -> return tbc + Nothing -> do + clockId <- nextFreeID ClockID + let tbc = TBClock { clock = clockGen + , clockSource = return clockGen + , .. + } + updDomain tbd { domainClock = Just tbc } + return tbc + + upd tbc acc@LiftAcc{..} = + acc { deps = SomeID (clockId tbc) : deps + , cont = extendVia cont + (pure $ clock tbc) + id + (const (.)) + } + +instance + ( KnownDomain dom, LiftTB (b -> c) + , arg ~ TBReset dom + ) => LiftTB ((Reset dom -> b) -> arg -> c) + where + (@@) = initializeLiftTB + + liftTB a sf r = liftTB (upd <$> knownReset r <*> a) $ sf $ reset r + where + knownReset = \case + tbr@TBReset{} -> return tbr + AutoReset -> do + tbd@TBDomain{..} <- tbDomain + case domainReset of + Just tbr -> return tbr + Nothing -> do + let reset = resetGen + + resetId <- nextFreeID ResetID + extVal <- liftIO $ newIORef Nothing + signalRef <- liftIO $ newIORef $ unsafeFromReset reset + ifProgress <- progressCheck simStepRef False + + let + resetCurVal = \case + Internal -> do + x :- xr <- readIORef signalRef + ifProgress + do + writeIORef signalRef xr + return $ head# xr + <:> + return x + + External -> readIORef extVal >>= \case + Nothing -> error "No Value @Reset" + Just x -> return x + + resetUpdate = + writeIORef extVal . Just + + tbr = TBReset{..} + + updDomain tbd { domainReset = Just tbr } + return tbr + + upd tbr acc@LiftAcc{..} = + acc { deps = SomeID (resetId tbr) : deps + , cont = extendVia cont + (resetCurVal tbr Internal) + (unsafeToReset . pure) + (const (.)) + } + +instance + ( KnownDomain dom, LiftTB (b -> c) + , arg ~ TBEnable dom + ) => LiftTB ((Enable dom -> b) -> arg -> c) + where + (@@) = initializeLiftTB + + liftTB a sf e = liftTB (upd <$> knownEnable e <*> a) $ sf $ enable e + where + knownEnable = \case + tbe@TBEnable{} -> return tbe + AutoEnable -> do + tbd@TBDomain{..} <- tbDomain + case domainEnable of + Just tbe -> return tbe + Nothing -> do + let enable = enableGen + + enableId <- nextFreeID EnableID + extVal <- liftIO $ newIORef Nothing + signalRef <- liftIO $ newIORef (fromEnable enable) + ifProgress <- progressCheck simStepRef False + + let + enableCurVal = \case + Internal -> do + x :- xr <- readIORef signalRef + ifProgress + do + writeIORef signalRef xr + return $ head# xr + <:> + return x + + External -> readIORef extVal >>= \case + Nothing -> error "No Value @Enable" + Just x -> return x + + enableUpdate = + writeIORef extVal . Just + + tbe = TBEnable{..} + + updDomain tbd { domainEnable = Just tbe } + return tbe + + upd tbe acc@LiftAcc{..} = + acc { deps = SomeID (enableId tbe) : deps + , cont = extendVia cont + (enableCurVal tbe Internal) + (toEnable . pure) + (const (.)) + } + +-- | Initializes the lift of a signal (function). +-- +-- Note: this primarily serves as the default implementation of the +-- '@@' operator for the 'LiftTB' class. The implementation is kept +-- separate, however, to not obfuscate users with the additional +-- constraints that are required for this kind of uniform +-- implementation. +initializeLiftTB :: (LiftTB a, a ~ (ArgOf a -> b)) => String -> ArgOf a -> b +initializeLiftTB name x = liftTB accInit x + where + accInit = do + sfRef <- liftIO $ newIORef x + return LiftAcc + { deps = [] + , cont = (,($)) <$> readIORef sfRef + , .. + } + +-- | Creates a new simulation step reference, against which the global +-- reference is compared on execution of the returned progress +-- check. The local reference gets automatically updated to the global +-- one when checking for progress and progress is detected. The +-- boolean argument determines whether progress gets immediately +-- triggered at startup (@True@) or with the first clock change +-- (@False@). +progressCheck :: IORef Int -> Bool -> TB (IO Bool) +progressCheck simStepRef initialProgress = do + simStepCache <- liftIO ((offset <$> readIORef simStepRef) >>= newIORef) + return $ do + globalRef <- readIORef simStepRef + localRef <- readIORef simStepCache + + when (globalRef > localRef) $ + writeIORef simStepCache globalRef + + return $ globalRef > localRef + where + offset + | initialProgress = (+ (-1)) + | otherwise = id + +-- | Creates a new 'History' container. +newHistory :: + TB (History a) +newHistory = do + size <- gets defaultHistorySize + historySize <- liftIO $ newIORef size + historyBufferPos <- liftIO $ newIORef 0 + historyBuffer <- liftIO $ newIORef Nothing + return History{..} + +-- | Memorizes a value inside the given 'History' container. +memorize :: MonadIO m => History a -> a -> m () +memorize History{..} value = + liftIO $ readIORef historySize >>= \case + 0 -> return () + n -> do + pos <- readIORef historyBufferPos + buf <- readIORef historyBuffer >>= \case + Just a -> return a + Nothing -> do + a <- newArray (0, n-1) Nothing + writeIORef historyBuffer $ Just a + return a + + writeArray buf pos $ Just value + writeIORef historyBufferPos $ pos + 1 + +-- | Reveals the history of a test bench signal. The returned list is +-- given in temporal order. +history :: + (KnownDomain dom, MonadIO m) => + TBSignal dom a -> + m [a] +history s = liftIO $ readIORef historyBuffer >>= \case + Nothing -> return [] + Just buf -> do + pos <- readIORef historyBufferPos + catMaybes . uncurry (flip (<>)) . splitAt pos <$> getElems buf + where + History{..} = signalHistory s + +-- | Some generalized extender for the accumulated continuation. +extendVia :: + Monad m => + -- the continuation accumulator executed inside the monad @m@ + m (b -> c, e -> f) -> + -- the monadic action from which the runtime value is taken + m a -> + -- a transformer to convert the runtime value to the application domain + (a -> b) -> + -- the extension of the continuation resulting from the application + -- of the given runtime value + (a -> d -> e) -> + -- the resulting continuation accumulator + m (c, d -> f) +extendVia contAcc valueM f g = do + v <- valueM + (sf, step) <- contAcc + return (sf $ f v, step . g v) + +-- | Query the next free 'ID' based on the 'ID' context. +class NextFreeID a where + nextFreeID :: (Int -> ID a) -> TB (ID a) + +instance NextFreeID SIGNAL where + nextFreeID c = do + i@(FreeID x) <- gets idSigCount + modify $ \st -> st { idSigCount = i + 1 } + return $ c x + +instance NextFreeID DOMAIN where + nextFreeID c = do + i@(FreeID x) <- gets idDomCount + modify $ \st -> st { idDomCount = i + 1 } + return $ c x + +-- | Adds a test bench signal to the set of known signals +-- automatically assigning it a the next free +-- 'Clash.Testbench.Internal.ID', if the signal does not have some +-- 'Clash.Testbench.Internal.ID' already. +mind :: + (KnownDomain dom, NFDataX a, BitPack a) => + (TBSignal dom a -> SomeSignal 'USER) -> + TBSignal dom a -> + TB (TBSignal dom a) +mind t s = case signalId s of + NoID -> do + i <- nextFreeID SignalID + let s' = s { signalId = i } + modify $ \st@ST{..} -> st { signals = S.insert (t s') signals } + return s' + _ -> do + modify $ \st@ST{..} -> + st { signals = S.insert (t s) $ case S.lookupIndex (t s) signals of + Nothing -> signals + Just i -> S.deleteAt i signals + } + return s + +-- | Query the current 'TBDomain' according to the context. If the +-- domain has not already been captured, a new entry gets created +-- automatically. +tbDomain :: + forall dom. + KnownDomain dom => + TB (TBDomain 'USER dom) +tbDomain = case knownDomain @dom of + SDomainConfiguration (ssymbolToString -> domainName) _ _ _ _ _ -> do + M.lookup domainName <$> gets domains >>= \case + Just (SomeDomain (d :: TBDomain 'USER dom')) -> case sameDomain @dom @dom' of + Just (Refl :: dom :~: dom') -> return d + Nothing -> mindDomain domainName + Nothing -> mindDomain domainName + +mindDomain :: forall dom. KnownDomain dom => String -> TB (TBDomain 'USER dom) +mindDomain domainName = do + simStepRef <- liftIO $ newIORef 0 + let + domain :: TBDomain 'USER dom + domain = TBDomain { domainClock = Nothing + , domainReset = Nothing + , domainEnable = Nothing + , .. + } + modify $ \st@ST{..} -> st + { domains = M.insert domainName (SomeDomain domain) domains + } + return domain + +updDomain :: + forall dom. + KnownDomain dom => + TBDomain 'USER dom -> + TB () +updDomain domain = case knownDomain @dom of + SDomainConfiguration domainName _ _ _ _ _ -> do + idx <- M.findIndex (ssymbolToString domainName) <$> gets domains + modify $ \st@ST{..} -> st + { domains = M.updateAt (const $ const $ Just $ SomeDomain domain) idx domains + } + +-- | Finalizes a test bench that has been created inside the 'TB' +-- monad. +runTB :: SimMode -> TB a -> IO (a, Testbench) +runTB mode testbench = + evalStateT (testbench >>= finalize) ST + { idSigCount = 1 + , signals = S.empty + , idDomCount = 0 + , domains = M.empty + , simSteps = 0 + , defaultHistorySize = 100 + } + where + finalize r = do + -- finalize the signals first + tbSignals <- + map (finalizeSignal `onAllSignalTypes`) . S.toAscList + <$> gets signals + + let + -- group the known signals according to their domains + tbSignalDoms = + map (\xs -> (someSignalDomain $ head xs, xs)) + $ groupBy ((==) `on` someSignalDomain) + $ sortBy (compare `on` someSignalDomain) + tbSignals + + -- mind domains that may not have been captured yet (just to be sure) + forM_ tbSignalDoms $ \(_, x : _) -> + (`onAllSignalTypes` x) $ \(_ :: Internal.TBSignal 'FINAL dom b) -> + void $ tbDomain @dom + + -- all of the internal state is final at this point + ST { idSigCount = FreeID n + , idDomCount = FreeID m + , simSteps = tbSimSteps + , .. + } <- get + + let + -- finalize the domains + tbDomains = (`map` tbSignalDoms) $ bimap + ((finalizeDomain `onAllDomainTypes`) . (M.!) domains) + (sort . map (signalId `onAllSignalTypes`)) + + -- create efficient lookup tables + tbSignalLookup = + A.array (NoID, SignalID (n-1)) $ flip map tbSignals $ \s -> + (signalId `onAllSignalTypes` s, s) + + tbDomainLookup = + A.array (ClockID 0, ClockID (m-1)) + $ flip concatMap tbDomains $ \(fst -> d) -> + (, d) <$> (domIds `onAllDomainTypes` d) + + return(r, Testbench{..}) + + domIds TBDomain{..} = + catMaybes + [ clockId <$> domainClock + , resetId <$> domainReset + , enableId <$> domainEnable + ] + + finalizeSignal :: + (KnownDomain dom, NFDataX a, BitPack a) => + Internal.TBSignal 'USER dom a -> + SomeSignal 'FINAL + finalizeSignal = SomeSignal . \case + SimSignal{..} -> + SimSignal + { signalCurVal = signalCurVal mode + , signalVerify = signalVerify mode + , .. + } + IOInput{..} -> + IOInput + { signalCurVal = signalCurVal mode + , .. + } + TBSignal{..} -> + TBSignal + { signalCurVal = signalCurVal mode + , .. + } + + finalizeDomain :: + KnownDomain dom => + TBDomain 'USER dom -> + SomeDomain 'FINAL + finalizeDomain = SomeDomain . \case + TBDomain{..} -> + TBDomain + { domainClock = (<$> domainClock) $ \TBClock{..} -> + TBClock + { .. + } + , domainReset = (<$> domainReset) $ \TBReset{..} -> + TBReset + { resetCurVal = resetCurVal mode + , .. + } + , domainEnable = (<$> domainEnable) $ \TBEnable{..} -> + TBEnable + { enableCurVal = enableCurVal mode + , .. + } + , .. + } + +someSignalDomain :: SomeSignal s -> String +someSignalDomain = onAllSignalTypes $ \(_ :: Internal.TBSignal s dom a) -> + case knownDomain @dom of + SDomainConfiguration (ssymbolToString -> domainName) _ _ _ _ _ -> + domainName diff --git a/clash-testbench/src/Clash/Testbench/Internal/Signal.hs b/clash-testbench/src/Clash/Testbench/Internal/Signal.hs new file mode 100644 index 0000000000..2e270b2ae8 --- /dev/null +++ b/clash-testbench/src/Clash/Testbench/Internal/Signal.hs @@ -0,0 +1,443 @@ +{-| +Copyright: (C) 2023 Google Inc. +License: BSD2 (see the file LICENSE) +Maintainer: QBayLogic B.V. + +Lifted signal types and internal data structures for +'Clash.Testbench.Internal.TB' (internal module). +-} +module Clash.Testbench.Internal.Signal where + +import Algebra.PartialOrd +import Control.Monad.IO.Class (MonadIO) +import Data.Array.IO (IOArray) +import Data.Function (on) +import Data.IORef (IORef) +import Hedgehog (PropertyT) + +import Clash.Prelude + ( KnownDomain(..), BitPack(..), SDomainConfiguration(..), NFDataX, Type + , Domain, Signal, Clock, Reset, Enable + , ssymbolToString + ) + +import Clash.FFI.VPI.Module (Module) +import Clash.FFI.VPI.Port (Port, Direction) + +import Clash.Testbench.Internal.ID + +-- | Test bench design stages +data Stage :: Type where + USER :: Stage + -- ^ The test bench is created in the USER stage. The elements of + -- the test bench are setup by the user inside the + -- 'Clash.Testbench.Internal.Monad.TB' monad during this stage. + FINAL :: Stage + -- ^ The FINAL stage is reached once the test bench has been created + -- and all elements of the setup are known. Furthermore, + -- post-processing of the setup has passed + -- successfully. Post-processing also introduces the switch from + -- 'USER' to 'FINAL' on the type level. + +-- | Supported simulation modes sources +data SimMode = + Internal + -- ^ Internal pure Haskell based simulation + | External + -- ^ Co-Simulation via Clash-FFI + +-- | Type family for handling simulation mode dependent types. +-- 'SimMode' does not have to be fixed during test bench creation, but +-- will be fixed once the test bench got finalized. Hence, at the +-- final stage the 'SimMode' argument gets obsolete. +type family SimModeDependent (s :: Stage) a where + SimModeDependent 'USER a = SimMode -> a + SimModeDependent 'FINAL a = a + +-- | Clash-FFI port connector +data PortInterface = + PortInterface + { port :: Port + , portName :: String + , portSize :: Int + , portIndex :: Int + , portDirection :: Direction + } + +-- | Clash-FFI module connector +data ModuleInterface = + ModuleInterface + { module_ :: Module + , inputPort :: ID () -> PortInterface + -- TODO: multiple port support vie Bundle/Unbundle + , outputPort :: PortInterface + } + +-- | Size bounded signal history +data History a = + History + { historySize :: IORef Int + , historyBufferPos :: IORef Int + , historyBuffer :: IORef (Maybe (IOArray Int (Maybe a))) + } + +-- | Expectations on certain outputs at the given simulation step +newtype Expectation a = Expectation { expectation :: (Int, a -> Verifier) } + +-- | Expectations cannot be compared: they are always unequal. +instance Eq (Expectation a) where + _ == _ = False + +-- | Expectations enjoy some partial order on the simulation steps at +-- which they are verified. +instance PartialOrd (Expectation a) where + leq (Expectation (x, _)) (Expectation (y, _)) = x <= y + comparable (Expectation (x, _)) (Expectation (y, _)) = x /= y + +-- | The verification mode determines the environment in which a +-- verifier is executed. +data VerificationMode m where + Simple :: VerificationMode IO + Hedgehog :: VerificationMode (PropertyT IO) + +-- | Existential quantified container for passing different +-- verification environments around. +data Verifier = + Verifier + { verifier :: (forall m. MonadIO m => VerificationMode m -> m ()) + } + +-- | Runs a verifier in a supported verification environment. +class Verify m where + verify :: Verifier -> m () + +instance Verify IO where + verify = \case + Verifier v -> v Simple + +instance Verify (PropertyT IO) where + verify = \case + Verifier v -> v Hedgehog + +-- | The lifted 'Clash.Signal.Signal' type to be used in +-- 'Clash.Testbench.Internal.Monad.TB'. +data TBSignal (s :: Stage) (dom :: Domain) a = + -- | A signal that is simulated + SimSignal + { signalId :: ID SIGNAL + -- ^ Some unique signal ID + , signalCurVal :: SimModeDependent s (IO a) + -- ^ The data value that is captured by the signal at the + -- current simulation step + , signalName :: String + -- ^ Some name identifier for the signal (this name is used for + -- module port matching in case of simulation with an external + -- simulator) + , signalOrigin :: Signal dom a + -- ^ The Clash signal, out of which the test bench signal has + -- been created (for internal use only) + , signalDeps :: [ID ()] + -- ^ The dependencies of the signal (i.e., all other input + -- signals whose content is required for computing the values of + -- this signal) + , signalExpect :: Expectation a -> IO () + -- ^ Registers an expectation on the content of this signal to + -- be verified during simulation + , signalVerify :: SimModeDependent s Verifier + -- ^ The expectation verifier + , signalHistory :: History a + -- ^ Bounded history of signal values + , signalUpdate :: Maybe (a -> IO ()) + -- ^ Overwrites the value of the signal at the current + -- simulation step (only available in external simulation mode) + + -- TODO: Use proper type families instead of the 'Maybe' wrapper + -- here. + , signalPlug :: Maybe ModuleInterface + -- ^ Some external module interface whose ports match with this + -- signal's type (only available in external simulation mode) + , signalPrint :: Maybe (a -> String) + -- ^ Some optional value printer for inspection of the signal content + } + -- | A signal that receives its content via some IO + | IOInput + { signalId :: ID SIGNAL + -- ^ Some unique signal ID + , signalCurVal :: SimModeDependent s (IO a) + -- ^ The data value hold by the signal at the current simulation step + , signalHistory :: History a + -- ^ Bounded history of signal values + , signalPrint :: Maybe (a -> String) + -- ^ Some optional value printer for inspection of the signal content + } + -- | A signal that results from composition + | TBSignal + { signalId :: ID SIGNAL + -- ^ This is always 'Clash.Testbench.Internal.ID.NoID', because + -- it is impossible to keep track of signals that are created + -- via some functor or applicative composition (note that + -- tracking those is also not necessary: the corresponding + -- transformation cannot be run through an external execution + -- engine anyway) + , signalCurVal :: SimModeDependent s (IO a) + -- ^ The data value hold by the signal at the current simulation step + , signalPrint :: Maybe (a -> String) + -- ^ Some optional value printer for inspection of the signal content + } + +-- | For internal use only (this is __not__ connected to the data that +-- is hold by the signal) +instance KnownDomain dom => Show (TBSignal s dom a) where + show = case knownDomain @dom of + SDomainConfiguration domainName _ _ _ _ _ -> \case + SimSignal{..} -> + "Signal \"" + <> signalName <> "\" @" + <> ssymbolToString domainName <> " " + <> show signalId <> " " + <> show signalDeps + IOInput{..} -> + "Input " <> show signalId + TBSignal{} -> + "TS" + +-- | For internal use only (this is __not__ connected to the data that +-- is hold by the signal) +instance Eq (TBSignal s dom a) where + (==) = (==) `on` signalId + +-- | For internal use only (this is __not__ connected to the data that +-- is hold by the signal) +instance Ord (TBSignal s dom a) where + compare = compare `on` signalId + +instance Functor (TBSignal 'USER dom) where + fmap f s = + TBSignal + { signalId = NoID + , signalCurVal = fmap f . signalCurVal s + -- we lose printing abilities at this point. This is fine, + -- since printing capabilities are recovered automatically + -- once the mapped signal requires printing capabilities + -- again. + , signalPrint = Nothing + } + +instance Applicative (TBSignal 'USER dom) where + pure x = + TBSignal + { signalId = NoID + , signalCurVal = const $ pure x + , signalPrint = Nothing + } + + f <*> s = + TBSignal + { signalId = NoID + , signalCurVal = \m -> signalCurVal f m <*> signalCurVal s m + , signalPrint = Nothing + } + +-- | The lifted 'Clash.Signal.Clock' type to be used in +-- 'Clash.Testbench.Internal.Monad.TB'. +data TBClock (s :: Stage) (dom :: Domain) where + AutoClock :: + forall dom. + KnownDomain dom => + TBClock 'USER dom + TBClock :: + forall s dom. + KnownDomain dom => + { clock :: Clock dom + , clockId :: ID DOMAIN + , clockSource :: IO (Clock dom) + } -> + TBClock s dom + +instance KnownDomain dom => Show (TBClock s dom) where + show clk = case knownDomain @dom of + SDomainConfiguration domainName _ _ _ _ _ -> + "Clock @" <> ssymbolToString domainName <> " " <> + ( case clk of + AutoClock -> "auto" + TBClock{..} -> show clockId + ) + +instance Eq (TBClock s dom) where + (==) = \case + AutoClock -> \case + AutoClock -> True + _ -> False + x@TBClock{} -> \case + y@TBClock{} -> clockId x == clockId y + _ -> False + +instance Ord (TBClock s dom) where + compare = \case + AutoClock -> \case + AutoClock -> EQ + TBClock{} -> LT + x@TBClock{} -> \case + y@TBClock{} -> compare (clockId x) (clockId y) + AutoClock -> GT + +-- | The lifted 'Clash.Signal.Clock' type to be used in +-- 'Clash.Testbench.Internal.Monad.TB'. +data TBReset (s :: Stage) (dom :: Domain) where + AutoReset :: + forall dom. + KnownDomain dom => + TBReset 'USER dom + TBReset :: + forall s dom. + KnownDomain dom => + { reset :: Reset dom + , resetId :: ID DOMAIN + , resetCurVal :: SimModeDependent s (IO Bool) + , resetUpdate :: Bool -> IO () + } -> + TBReset s dom + +instance KnownDomain dom => Show (TBReset s dom) where + show rst = case knownDomain @dom of + SDomainConfiguration domainName _ _ _ _ _ -> + "Reset @" <> ssymbolToString domainName <> " " <> + ( case rst of + AutoReset -> "auto" + TBReset{..} -> show resetId + ) + +instance Eq (TBReset s dom) where + (==) = \case + AutoReset -> \case + AutoReset -> True + _ -> False + x@TBReset{} -> \case + y@TBReset{} -> resetId x == resetId y + _ -> False + +instance Ord (TBReset s dom) where + compare = \case + AutoReset -> \case + AutoReset -> EQ + TBReset{} -> LT + x@TBReset{} -> \case + y@TBReset{} -> compare (resetId x) (resetId y) + AutoReset -> GT + +-- | The lifted 'Clash.Signal.Enable' type to be used in +-- 'Clash.Testbench.Internal.Monad.TB'. +data TBEnable (s :: Stage) (dom :: Domain) where + AutoEnable :: + forall dom. + KnownDomain dom => + TBEnable 'USER dom + TBEnable :: + forall s dom. + KnownDomain dom => + { enable :: Enable dom + , enableId :: ID DOMAIN + , enableCurVal :: SimModeDependent s (IO Bool) + , enableUpdate :: Bool -> IO () + } -> + TBEnable s dom + +instance KnownDomain dom => Show (TBEnable s dom) where + show enb = case knownDomain @dom of + SDomainConfiguration domainName _ _ _ _ _ -> + "Enable @" <> ssymbolToString domainName <> " " <> + ( case enb of + AutoEnable -> "auto" + TBEnable{..} -> show enableId + ) + +instance Eq (TBEnable s dom) where + (==) = \case + AutoEnable -> \case + AutoEnable -> True + _ -> False + x@TBEnable{} -> \case + y@TBEnable{} -> enableId x == enableId y + _ -> False + +instance Ord (TBEnable s dom) where + compare = \case + AutoEnable -> \case + AutoEnable -> EQ + TBEnable{} -> LT + x@TBEnable{} -> \case + y@TBEnable{} -> compare (enableId x) (enableId y) + AutoEnable -> GT + +-- | Existential data type wrapper for 'TBSignal'. +data SomeSignal (s :: Stage) where + SomeSignal :: + forall s dom a. + (KnownDomain dom, NFDataX a, BitPack a) => + TBSignal s dom a -> + SomeSignal s + +instance Eq (SomeSignal s) where + (==) = (==) `on` (signalId `onAllSignalTypes`) + +instance Ord (SomeSignal s) where + compare = compare `on` (signalId `onAllSignalTypes`) + +instance Show (SomeSignal s) where + show = (show `onAllSignalTypes`) + +-- | Applies a 'TBSignal' transformation inside the existential +-- context of 'SomeSignal'. +-- +-- Note that this implementation supports multiple constructors of +-- 'SomeSignal' although there may be only one right now. +onAllSignalTypes :: + forall s b. + ( forall dom a. + (KnownDomain dom, NFDataX a, BitPack a) => + TBSignal s dom a -> b + ) -> + SomeSignal s -> + b +onAllSignalTypes f = \case + SomeSignal s -> f s + +-- | The internal 'Clash.Signal.Domain' representation that is used +-- inside 'Clash.Testbench.Internal.TB'. +data TBDomain (s :: Stage) (dom :: Domain) = + TBDomain + { domainClock :: Maybe (TBClock s dom) + , domainReset :: Maybe (TBReset s dom) + , domainEnable :: Maybe (TBEnable s dom) + , simStepRef :: IORef Int + } + +-- | Existential data type wrapper for 'TBDomain'. +data SomeDomain (s :: Stage) where + SomeDomain :: + forall s dom. + KnownDomain dom => + TBDomain s dom -> + SomeDomain s + +instance Show (SomeDomain s) where + show = \case + SomeDomain (_ :: TBDomain s dom) -> case knownDomain @dom of + SDomainConfiguration domainName _ _ _ _ _ -> + ssymbolToString domainName + +-- | Applies a 'TBDomain' transformation inside the existential +-- context of 'SomeDomain'. +-- +-- Note that this implementation supports multiple constructors of +-- 'SomeDomain' although there may be only one right now. +onAllDomainTypes :: + forall s b. + ( forall dom. + KnownDomain dom => + TBDomain s dom -> b + ) -> + SomeDomain s -> + b +onAllDomainTypes f = \case + SomeDomain d -> f d diff --git a/clash-testbench/src/Clash/Testbench/Output.hs b/clash-testbench/src/Clash/Testbench/Output.hs new file mode 100644 index 0000000000..a42a02720b --- /dev/null +++ b/clash-testbench/src/Clash/Testbench/Output.hs @@ -0,0 +1,35 @@ +{-| +Copyright: (C) 2023 Google Inc. +License: BSD2 (see the file LICENSE) +Maintainer: QBayLogic B.V. + +Output processors for post-processing output that results from +simulating 'Clash.Testbench.Simulate.TB' defined test benches. +-} +module Clash.Testbench.Output + ( watch + , watchWith + ) where + +import Control.Monad (void) + +import Clash.Prelude (KnownDomain(..), BitPack(..), NFDataX) + +import Clash.Testbench.Signal (TBSignal) +import Clash.Testbench.Internal.Signal hiding (TBSignal) +import Clash.Testbench.Internal.Monad + +-- | Output the values of the given signal to @stdout@ during +-- simulation using the 'Show' implementation of @a@. +watch :: + (KnownDomain dom, BitPack a, NFDataX a, Show a) => + TBSignal dom a -> TB () +watch = watchWith show + +-- | Output the values of the given signal to @stdout@ during +-- simulation using the provided 'String' transformer for @a@. +watchWith :: + (KnownDomain dom, BitPack a, NFDataX a) => + (a -> String) -> TBSignal dom a -> TB () +watchWith toStr tbs = + void $ mind SomeSignal tbs { signalPrint = Just toStr } diff --git a/clash-testbench/src/Clash/Testbench/Signal.hs b/clash-testbench/src/Clash/Testbench/Signal.hs new file mode 100644 index 0000000000..550a09b0c2 --- /dev/null +++ b/clash-testbench/src/Clash/Testbench/Signal.hs @@ -0,0 +1,49 @@ +{-| +Copyright: (C) 2023 Google Inc. +License: BSD2 (see the file LICENSE) +Maintainer: QBayLogic B.V. + +'Clash.Testbench.Simulate.TB' lifted signals (internal). +-} +module Clash.Testbench.Signal + ( TBSignal + , TBClock + , TBReset + , TBEnable + , AutoTB(..) + ) where + +import Clash.Prelude (KnownDomain) + +import qualified Clash.Testbench.Internal.Signal as Internal + +-- | A 'Clash.Signal.Signal' that has been lifted into the +-- 'Clash.Testbench.Simulate.TB' context. +type TBSignal dom = Internal.TBSignal 'Internal.USER dom + +-- | A 'Clash.Signal.Clock' signal that has been lifted into the +-- 'Clash.Testbench.Simulate.TB' context. +type TBClock dom = Internal.TBClock 'Internal.USER dom + +-- | A 'Clash.Signal.Reset' signal that has been lifted into the +-- 'Clash.Testbench.Simulate.TB' context. +type TBReset dom = Internal.TBReset 'Internal.USER dom + +-- | An 'Clash.Signal.Enable' signal that has been lifted into the +-- 'Clash.Testbench.Simulate.TB' context. +type TBEnable dom = Internal.TBEnable 'Internal.USER dom + +-- | Signals that are implicitly available inside +-- 'Clash.Testbench.Simulate.TB' and can be driven by the simulator +-- automatically. +class AutoTB a where + auto :: a + +instance KnownDomain dom => AutoTB (TBClock dom) where + auto = Internal.AutoClock + +instance KnownDomain dom => AutoTB (TBReset dom) where + auto = Internal.AutoReset + +instance KnownDomain dom => AutoTB (TBEnable dom) where + auto = Internal.AutoEnable diff --git a/clash-testbench/src/Clash/Testbench/Simulate.hs b/clash-testbench/src/Clash/Testbench/Simulate.hs new file mode 100644 index 0000000000..b8f6f36a29 --- /dev/null +++ b/clash-testbench/src/Clash/Testbench/Simulate.hs @@ -0,0 +1,487 @@ +{-| +Copyright: (C) 2023 Google Inc. +License: BSD2 (see the file LICENSE) +Maintainer: QBayLogic B.V. + +All it needs for building and running test benches that are created +from Clash circuitry. +-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Clash.Testbench.Simulate + ( TB + , LiftTB((@@)) + , SimSettings(..) + , simulate + , simulateFFI + , tbProperty + , tbPropertyFFI + , ffiCheckGroup + , ffiHedgehog + ) where + +import Prelude hiding (putStrLn, putStr, print) +import qualified Prelude as Prelude (putStrLn, putStr) + +import Control.Concurrent (forkOS) +import Control.Concurrent.MVar +import Control.Exception (catch) +import Control.Monad.IO.Class +import Control.Monad.State.Lazy hiding (lift) +import Data.Proxy + +import qualified Hedgehog (Property, Group, property, checkSequential) + +import Data.Array ((!)) +import Data.Coerce (Coercible) +import Data.IORef +import Data.Bits (complement) +import Data.Typeable (Typeable) +import Foreign.C.String (newCString) +import Foreign.Marshal.Alloc (free) +import Control.Exception (SomeException, try) +import Data.Int (Int64) +import qualified Data.Map as M +import qualified Data.ByteString.Char8 as B +import qualified Data.Array as A + +import Clash.Prelude + ( KnownDomain(..), BitSize, BitPack(..), SNat(..), Bit + , natVal, resize, low, high, boolToBit + ) + +import Clash.FFI.Monad +import Clash.FFI.VPI.Info +import Clash.FFI.VPI.Callback +import Clash.FFI.VPI.Control +import Clash.FFI.VPI.IO +import Clash.FFI.VPI.Module +import Clash.FFI.VPI.Object +import Clash.FFI.VPI.Port + +import Clash.Testbench.Internal.ID +import Clash.Testbench.Internal.Signal +import Clash.Testbench.Internal.Monad + +-- | Simulation Settings +data SimSettings = + SimSettings + { quietRun :: Bool + , validate :: Bool + } + deriving (Eq, Ord, Show) + +class PutStr s m where + putStr :: (?settings :: SimSettings) => s -> m () + putStrLn :: (?settings :: SimSettings) => s -> m () + +instance PutStr String IO where + putStr x = when (not $ quietRun ?settings) $ Prelude.putStr x + putStrLn x = when (not $ quietRun ?settings) $ Prelude.putStrLn x + +instance PutStr B.ByteString IO where + putStr x = when (not $ quietRun ?settings) $ B.putStr x + putStrLn x = when (not $ quietRun ?settings) $ B.putStrLn x + +instance PutStr B.ByteString (SimCont o) where + putStr x = when (not $ quietRun ?settings) (simPutStr x >> simFlushIO) + putStrLn x = when (not $ quietRun ?settings) (simPutStrLn x >> simFlushIO) + +instance PutStr String (SimCont o) where + putStr = putStr . B.pack + putStrLn = putStrLn . B.pack + +{- +class Print m where + print :: (?settings :: SimSettings, Show a) => a -> m () + +instance Print IO where + print = putStrLn . show + +instance Print (SimCont o) where + print = putStrLn . B.pack . show +-} + +-- | @simulate n testbench@ simulates the @testbench@, created in the +-- 'Clash.Testbench.Simulate.TB' context, for @n@ simulation steps. +-- +-- The simulation is run on the native Clash implementation, as given +-- by the Clash signals and signal functions lifted into 'TB'. +simulate :: (MonadIO m, Verify m) => SimSettings -> TB a -> m a +simulate simSettings@SimSettings{..} testbench = do + let ?settings = simSettings + (r, Testbench{..}) <- liftIO $ runTB Internal testbench + replicateM_ tbSimSteps $ do + forM_ tbDomains $ \(d, map (tbSignalLookup !) -> xs) -> + (`onAllDomainTypes` d) $ \(TBDomain{..} :: TBDomain 'FINAL dom) -> do + forM_ xs $ onAllSignalTypes $ \s -> do + when validate $ case s of + SimSignal{..} -> verify signalVerify + _ -> return () + v <- liftIO $ signalCurVal s + when (not quietRun) $ case signalPrint s of + Nothing -> return () + Just toStr -> liftIO $ putStrLn . (<> toStr v) $ case s of + IOInput{} -> "I " + SimSignal{} -> "O " + TBSignal{} -> "S " + liftIO $ modifyIORef simStepRef (+ 1) + return r + +-- | Turns a test bench design into a 'Hedgehog.Property' to be +-- simulated with Haskell. +tbProperty :: TB () -> Hedgehog.Property +tbProperty = Hedgehog.property . simulate + SimSettings + { quietRun = True + , validate = True + } + +data VPIState = + VPIState + { testbench :: Testbench + -- multiple clocks are not supported yet, currently all clocks + -- are synchronously executed. + , vpiClock :: Bit + , vpiSimSteps :: Int + , vpiInit :: Bool + , syncA :: MVar () + , syncB :: MVar Bool + } + +type Sync = (MVar (), MVar Bool) + +ffiHedgehog :: IO Sync +ffiHedgehog = (,) <$> newEmptyMVar <*> newEmptyMVar + +ffiCheckGroup :: Sync -> Hedgehog.Group -> IO () +ffiCheckGroup (syncA, _) g = do + void $ forkOS (void $ Hedgehog.checkSequential g >> putMVar syncA ()) + takeMVar syncA + +-- | @simulate n testbench@ simulates the @testbench@, created in the +-- 'TB' context, for @n@ simulation steps with an external simulator +-- bound via Clash-FFI. +-- +-- Note that this function is not executable in a standard Haskell +-- environment, but must to be bound to a @ffiMain@ foreign call that +-- is shipped via a shared library and executed by an external +-- simulator. See Clash-FFI for more details. +simulateFFI :: (MonadIO m, Verify m) => Sync -> SimSettings -> TB a -> m a +simulateFFI (syncA, syncB) simSettings tb = do + let ?settings = simSettings + (r, testbench@Testbench{..}) <- liftIO $ runTB External tb + success <- liftIO $ do + let vpiClock = low + vpiSimSteps = tbSimSteps - 1 + vpiInit = True + let ?state = VPIState{..} + initializeSimulation + putMVar syncA () + takeMVar syncB + + unless (success) $ + -- re-verify at the current cycle to produce a failure in the + -- current MonadIO context + forM_ tbDomains $ \(d, map (tbSignalLookup !) -> xs) -> + (`onAllDomainTypes` d) $ \(TBDomain{} :: TBDomain 'FINAL dom) -> do + forM_ xs $ onAllSignalTypes $ \case + SimSignal{..} -> verify signalVerify + _ -> return () + + return r + +-- | Turns a test bench design into a 'Hedgehog.Property' to be +-- simulated with external simulator. +tbPropertyFFI :: Sync -> TB () -> Hedgehog.Property +tbPropertyFFI sync = Hedgehog.property . simulateFFI sync + SimSettings + { quietRun = True + , validate = True + } + +initializeSimulation :: (?state :: VPIState, ?settings :: SimSettings) => IO () +initializeSimulation = runSimAction $ do + -- reset the simulator to ensure some defined initial state + -- controlSimulator $ Reset Processing Nothing NoDiagnostics + + -- print simulator info + putStrLn "[ Simulator Info ]" + Info{..} <- receiveSimulatorInfo + putStrLn infoProduct + putStrLn infoVersion + putStrLn "" + + -- print top modules + putStrLn "[ Top Modules ]" + tops' <- topModules + topNames <- mapM (receiveProperty Name) tops' + mapM_ putStrLn topNames + putStrLn "" + + -- iverilog runs into problems if iterated objects are used as a + -- long-term reference. Hence, they only should be used for + -- analyzing the architecture upfront. For long-term references to + -- be reusable during simulation, the objects should be queried via + -- their architectural name reference instead. + topM <- M.fromList + <$> mapM (\x -> (B.unpack x, ) <$> findTopModule x) topNames + + -- add the VPI module references to the signals + vpiSignals <- + forM tbSignals $ onAllSignalTypes $ \case + s@SimSignal{..} -> + case M.lookup signalName topM of + Just m -> (signalId, ) . SomeSignal <$> matchModule m s + Nothing -> error $ "No module matches \"" <> signalName <> "\"" + x -> return (signalId x, SomeSignal x) + + let + ?state = + ?state + { testbench = testbench + { tbSignals = map snd vpiSignals + , tbSignalLookup = A.array (A.bounds tbSignalLookup) vpiSignals + } + } + + putStrLn "[ Simulation start ]" + putStrLn "" + + nextCB ReadWriteSynch 0 assignInputs + where + VPIState{..} = ?state + Testbench{..} = testbench + +assignInputs :: (?state :: VPIState, ?settings :: SimSettings) => SimAction () +assignInputs = do +-- SimTime time <- receiveTime Sim (Nothing @Object) +-- putStrLn $ "assignInputs " <> show (time, vpiClock, vpiInit) + + forM_ tbDomains $ \(d, map (tbSignalLookup !) -> xs) -> + (`onAllDomainTypes` d) $ const $ do + forM_ xs $ onAllSignalTypes $ \case + SimSignal{..} -> mapM_ (assignModuleInputs signalPlug) signalDeps + _ -> return () + + let ?state = ?state { vpiClock = complement vpiClock + , vpiInit = False + } + + if vpiClock == high + then nextCB ReadWriteSynch 1 assignInputs + else nextCB ReadOnlySynch 1 readOutputs + + where + VPIState{..} = ?state + Testbench{..} = testbench + + assignModuleInputs :: + Typeable b => + Maybe ModuleInterface -> + ID () -> SimCont b () + assignModuleInputs = \case + Nothing -> const $ return () + Just ModuleInterface{..} -> \sid@(SomeID x) -> + let PortInterface{..} = inputPort sid + in case x of + NoID -> return () + ClockID _TODO -> sendV port vpiClock + ResetID _TODO -> sendV port $ boolToBit vpiInit + EnableID _TODO -> sendV port high + i@(SignalID _TODO) + | vpiClock == high -> return () + | otherwise -> + (`onAllSignalTypes` (tbSignalLookup ! i)) $ \s -> + liftIO (signalCurVal s) >>= \v -> do + sendV port v + + sendV :: (BitPack a, Typeable b) => Port -> a -> SimCont b () + sendV port v = + liftIO $ runSimAction $ + sendValue port (BitVectorVal SNat $ pack v) + $ InertialDelay $ SimTime 0 + +readOutputs :: (?state :: VPIState, ?settings :: SimSettings) => SimAction () +readOutputs = do +-- SimTime time <- receiveTime Sim (Nothing @Object) +-- putStrLn $ "readOutputs " <> show time + + failure <- fmap or $ forM tbDomains $ \(d, map (tbSignalLookup !) -> xs) -> + (`onAllDomainTypes` d) $ \(TBDomain{..} :: TBDomain 'FINAL dom) -> do + -- receive the outputs + forM_ xs $ onAllSignalTypes $ \case + SimSignal{..} -> case signalPlug of + Nothing -> error "Cannot read from module" + Just ModuleInterface{..} -> + receiveValue VectorFmt (port outputPort) >>= \case + BitVectorVal SNat v -> case signalUpdate of + Just upd -> liftIO $ upd $ unpack $ resize v + Nothing -> error "No signal update" + _ -> error "Unexpected return format" + _ -> return () + -- print the watched signals + failure <- fmap or $ forM xs $ onAllSignalTypes $ \s -> do + failure <- + if not validate then return False else case s of + SimSignal{..} -> liftIO $ catch + (verify signalVerify >> return False) + (\(_ :: SomeException) -> return True) + _ -> return False + v <- liftIO $ signalCurVal s + when (not quietRun) $ case signalPrint s of + Nothing -> return () + Just toStr -> putStrLn . B.pack . (<> toStr v) $ case s of + IOInput{} -> "I " + SimSignal{} -> "O " + TBSignal{} -> "S " + return failure + -- proceed time for all instances not running trough Clash-FFI + unless failure + $ liftIO $ modifyIORef simStepRef (+ 1) + return failure + + if failure then do + putStrLn "" + putStrLn "[ Simulation failed ]" + + liftIO $ do + putMVar syncB False + takeMVar syncA + + liftIO $ void $ try @SomeException $ runSimAction + $ controlSimulator $ Finish NoDiagnostics + else if vpiSimSteps > 0 then do + let ?state = ?state { vpiSimSteps = vpiSimSteps - 1 } + nextCB ReadWriteSynch 1 assignInputs + else do + putStrLn "" + putStrLn "[ Simulation done ]" + + liftIO $ do + putMVar syncB True + takeMVar syncA + + liftIO $ void $ try @SomeException $ runSimAction + $ controlSimulator $ Finish NoDiagnostics + where + VPIState{..} = ?state + SimSettings{..} = ?settings + Testbench{..} = testbench + +matchModule :: + ( ?state :: VPIState, ?settings :: SimSettings + , KnownDomain dom, BitPack a, Typeable b + ) => Module -> TBSignal 'FINAL dom a -> SimCont b (TBSignal 'FINAL dom a) +matchModule module_ = \case + tbs@SimSignal{..} -> do + ports <- modulePorts module_ + dirs <- mapM direction ports + + let + inputPorts = map fst $ filter (isInput . snd) $ zip ports dirs + outputPorts = map fst $ filter (isOutput . snd) $ zip ports dirs + + inputPort <- + (M.!) . M.fromList + <$> ( mapM (matchPort module_) + $ zip signalDeps + $ map Just inputPorts <> repeat Nothing + ) + + outputPort <- case outputPorts of + [p] -> do + portNameBS <- receiveProperty Name p + portSize <- fromEnum <$> getProperty Size p + portIndex <- fromEnum <$> getProperty PortIndex p + portDirection <- direction p + + let portName = B.unpack portNameBS + port <- getByName (Just module_) portNameBS + + checkPort (toInteger portSize) tbs portDirection + + return $ PortInterface{..} + _ -> error "TODO: later / " + + return tbs { signalPlug = Just ModuleInterface{..} } + _ -> error "Unfiltered TBS" + + where + isInput = \case + Input -> True + _ -> False + + isOutput = \case + Output -> True + _ -> False + +matchPort :: + (?state :: VPIState, ?settings :: SimSettings, Typeable b) => + Module -> (ID (), Maybe Port) -> SimCont b (ID (), PortInterface) +matchPort m = \case + (_, Nothing) -> error "Not enough ports" + (sid, Just p) -> liftIO $ runSimAction $ do + portNameBS <- receiveProperty Name p + portSize <- fromEnum <$> getProperty Size p + portIndex <- fromEnum <$> getProperty PortIndex p + portDirection <- direction p + + let portName = B.unpack portNameBS + checkID portName portSize portDirection sid + + -- Get a long-term reference via direct name access. Iterator + -- references may not be persistent. + port <- getByName (Just m) portNameBS + + return (sid, PortInterface{..}) + where + VPIState{..} = ?state + Testbench{..} = testbench + + match :: forall b. Int -> Int -> String -> String -> SimCont b () + match n k tName pName = + when (n /= k) $ error $ "Not a " <> tName <> " port: " <> pName + + checkID :: forall b. String -> Int -> Direction -> ID () -> SimCont b () + checkID name size dir (SomeID x) = case x of + ClockID{} -> match size 1 "clock" name + ResetID{} -> match size 1 "reset" name + EnableID{} -> match size 1 "enable" name + NoID -> error "NoID, TODO check" + i@SignalID{} -> (`onAllSignalTypes` (tbSignalLookup ! i)) $ \s -> + checkPort (toInteger size) s dir + +checkPort :: + forall dom a b. + (BitPack a, KnownDomain dom) => + Integer -> TBSignal 'FINAL dom a -> Direction -> SimCont b () +checkPort s + | natVal (Proxy @(BitSize a)) /= s = error "port size does not match" + | otherwise = \case + IOInput{} -> \case + Input -> return () + _ -> error "No Input" + _ -> const $ return () + +getByName :: + (Coercible a Object, Show a, Typeable a, Coercible Object b) => + Maybe a -> B.ByteString -> SimCont o b +getByName m name = do + ref <- liftIO $ newCString $ B.unpack name + obj <- getChild ref m + liftIO $ free ref + return obj + +nextCB :: + (Maybe Object -> Time -> CallbackReason) -> + Int64 -> + SimAction () -> + SimAction () +nextCB reason time action = + void $ liftIO $ runSimAction $ registerCallback + CallbackInfo + { cbReason = reason Nothing (SimTime time) + , cbRoutine = const (runSimAction action >> return 0) + , cbIndex = 0 + , cbData = B.empty + } diff --git a/clash-testbench/src/Control/Monad/Extra.hs b/clash-testbench/src/Control/Monad/Extra.hs new file mode 100644 index 0000000000..5bd7a26357 --- /dev/null +++ b/clash-testbench/src/Control/Monad/Extra.hs @@ -0,0 +1,24 @@ +{-| +Copyright: (C) 2023 Google Inc. +License: BSD2 (see the file LICENSE) +Maintainer: QBayLogic B.V. + +Some extra monad operations. +-} +module Control.Monad.Extra + ( () + , (<:>) + ) where + +-- | A fully monadic "if-then-else", which is recommended to be used +-- with '<:>'. +infixr 0 +() :: Monad m => m Bool -> (m a, m a) -> m a +c (a, b) = c >>= \case True -> a + False -> b + +-- | Some type restricted syntactic sugar for the pair constructor +-- @(,)@ (to make the usage of'' look nice). +infixr 0 <:> +(<:>) :: Monad m => m a -> m b -> (m a, m b) +(<:>) = (,)