From afe48a02dc580b6b3fd71074f63d42b64dfa4dff Mon Sep 17 00:00:00 2001 From: Felix Klein Date: Tue, 25 Apr 2023 13:41:13 +0200 Subject: [PATCH 1/9] First clash-testbench prototype --- cabal.project | 1 + clash-testbench/LICENSE | 22 ++ clash-testbench/clash-testbench.cabal | 55 +++ clash-testbench/example/Calculator.hs | 56 +++ clash-testbench/example/LICENSE | 22 ++ clash-testbench/example/Main.hs | 24 ++ clash-testbench/example/Setup.hs | 91 +++++ clash-testbench/example/cabal.project | 3 + .../example/clash-testbench-example.cabal | 49 +++ clash-testbench/example/run-iverilog.sh | 34 ++ clash-testbench/src/Clash/Testbench.hs | 18 + clash-testbench/src/Clash/Testbench/Input.hs | 53 +++ .../src/Clash/Testbench/Internal/Auto.hs | 43 ++ .../src/Clash/Testbench/Internal/ID.hs | 197 +++++++++ .../src/Clash/Testbench/Internal/Monad.hs | 281 +++++++++++++ .../src/Clash/Testbench/Internal/Signal.hs | 155 ++++++++ clash-testbench/src/Clash/Testbench/Output.hs | 42 ++ clash-testbench/src/Clash/Testbench/Signal.hs | 29 ++ .../src/Clash/Testbench/Simulate.hs | 373 ++++++++++++++++++ 19 files changed, 1548 insertions(+) create mode 100644 clash-testbench/LICENSE create mode 100644 clash-testbench/clash-testbench.cabal create mode 100644 clash-testbench/example/Calculator.hs create mode 100644 clash-testbench/example/LICENSE create mode 100644 clash-testbench/example/Main.hs create mode 100644 clash-testbench/example/Setup.hs create mode 100644 clash-testbench/example/cabal.project create mode 100644 clash-testbench/example/clash-testbench-example.cabal create mode 100755 clash-testbench/example/run-iverilog.sh create mode 100644 clash-testbench/src/Clash/Testbench.hs create mode 100644 clash-testbench/src/Clash/Testbench/Input.hs create mode 100644 clash-testbench/src/Clash/Testbench/Internal/Auto.hs create mode 100644 clash-testbench/src/Clash/Testbench/Internal/ID.hs create mode 100644 clash-testbench/src/Clash/Testbench/Internal/Monad.hs create mode 100644 clash-testbench/src/Clash/Testbench/Internal/Signal.hs create mode 100644 clash-testbench/src/Clash/Testbench/Output.hs create mode 100644 clash-testbench/src/Clash/Testbench/Signal.hs create mode 100644 clash-testbench/src/Clash/Testbench/Simulate.hs 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..acce77ea74 --- /dev/null +++ b/clash-testbench/clash-testbench.cabal @@ -0,0 +1,55 @@ +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 + other-modules: + Clash.Testbench.Internal.ID + Clash.Testbench.Internal.Signal + Clash.Testbench.Internal.Monad + Clash.Testbench.Internal.Auto + build-depends: + base, + mtl, + array, + 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..c0368e5671 --- /dev/null +++ b/clash-testbench/example/Main.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE RecursiveDo #-} +module Main where + +import Clash.Testbench + +import Calculator (OPC(..)) +import qualified Calculator (topEntity) + +myTestbench + :: TB () +myTestbench = mdo + input <- inputFromList Pop [Imm 1, Push, Imm 2, Push, Pop, Pop, Pop, ADD] + output <- ("topEntity" @@ Calculator.topEntity) auto auto auto input + watch input + watch output + +main :: IO () +main = simulate 10 myTestbench + +foreign export ccall "clash_ffi_main" + ffiMain :: IO () + +ffiMain :: IO () +ffiMain = simulateFFI 10 myTestbench 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..ac247a039c --- /dev/null +++ b/clash-testbench/example/cabal.project @@ -0,0 +1,3 @@ +packages: . .. ../../clash-ghc ../../clash-lib ../../clash-prelude ../../clash-ffi + +write-ghc-environment-files: always diff --git a/clash-testbench/example/clash-testbench-example.cabal b/clash-testbench/example/clash-testbench-example.cabal new file mode 100644 index 0000000000..dd461b1997 --- /dev/null +++ b/clash-testbench/example/clash-testbench-example.cabal @@ -0,0 +1,49 @@ +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 + -fplugin GHC.TypeLits.Extra.Solver + -fplugin GHC.TypeLits.Normalise + -fplugin GHC.TypeLits.KnownNat.Solver + build-depends: + base, + clash-prelude, + 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 + -- 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 + type: native-shared + 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..1c746448ba --- /dev/null +++ b/clash-testbench/example/run-iverilog.sh @@ -0,0 +1,34 @@ +#!/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 $? +${IVERILOG} verilog/Calculator.topEntity/topEntity.v -o Calculator.vvp \ + || exit $? +echo "" +echo "Running Icarus Verilog VVP runtime engine:" +echo "" +${VVP} -Mlib -mlibsimulate-ffi Calculator.vvp diff --git a/clash-testbench/src/Clash/Testbench.hs b/clash-testbench/src/Clash/Testbench.hs new file mode 100644 index 0000000000..a205573798 --- /dev/null +++ b/clash-testbench/src/Clash/Testbench.hs @@ -0,0 +1,18 @@ +{-| +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 + ) where + +import Clash.Testbench.Signal +import Clash.Testbench.Input +import Clash.Testbench.Output +import Clash.Testbench.Simulate diff --git a/clash-testbench/src/Clash/Testbench/Input.hs b/clash-testbench/src/Clash/Testbench/Input.hs new file mode 100644 index 0000000000..7a99a29b4b --- /dev/null +++ b/clash-testbench/src/Clash/Testbench/Input.hs @@ -0,0 +1,53 @@ +{-| +Copyright: (C) 2023 Google Inc. +License: BSD2 (see the file LICENSE) +Maintainer: QBayLogic B.V. + +Input sources for simulating 'TB' defined testbenches. +-} +module Clash.Testbench.Input + ( inputFromList + ) where + +import Control.Monad.State.Lazy +import Data.IORef +import Data.Maybe (fromMaybe) +import Data.List (uncons) + +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 + +-- | Generates input that is 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 instead. +inputFromList + :: (KnownDomain dom, BitPack a, NFDataX a) => a -> [a] -> TB (TBSignal dom a) +inputFromList x xs = do + FreeID i <- nextFreeID + ST{..} <- get + + listRef <- liftIO $ newIORef $ x : xs + simStepCache <- liftIO (readIORef simStepRef >>= newIORef) + + registerTBS $ IOInput + { signalId = SignalID i + , signalPrint = Nothing + , signalCurVal = do + (r, rs) <- fromMaybe (x, []) . uncons <$> readIORef listRef + v <- readIORef simStepRef + v' <- readIORef simStepCache + + if v == v' + then return r + else do + writeIORef listRef rs + writeIORef simStepCache v + return $ case rs of + [] -> x + y:_ -> y + } diff --git a/clash-testbench/src/Clash/Testbench/Internal/Auto.hs b/clash-testbench/src/Clash/Testbench/Internal/Auto.hs new file mode 100644 index 0000000000..2c5589a6af --- /dev/null +++ b/clash-testbench/src/Clash/Testbench/Internal/Auto.hs @@ -0,0 +1,43 @@ +module Clash.Testbench.Internal.Auto where + +import Clash.Testbench.Signal +import Clash.Testbench.Internal.ID +import Clash.Testbench.Internal.Signal hiding (TBClock, TBReset, TBEnable) +import qualified Clash.Testbench.Internal.Signal as Internal + +import Clash.Prelude + ( KnownDomain(..), SDomainConfiguration(..) + , clockGen, resetGen, enableGen, ssymbolToString + ) + +-- | 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 = case knownDomain @dom of + SDomainConfiguration domainName _ _ _ _ _ -> + Internal.TBClock + { clock = clockGen + , clockId = ClockID $ AutoDom $ ssymbolToString domainName + , clockSource = return clockGen + } + +instance KnownDomain dom => AutoTB (TBReset dom) where + auto = case knownDomain @dom of + SDomainConfiguration domainName _ _ _ _ _ -> + Internal.TBReset + { reset = resetGen + , resetId = ResetID $ AutoDom $ ssymbolToString domainName + , resetCurVal = return False + } + +instance KnownDomain dom => AutoTB (TBEnable dom) where + auto = case knownDomain @dom of + SDomainConfiguration domainName _ _ _ _ _ -> + Internal.TBEnable + { enable = enableGen + , enableId = EnableID $ AutoDom $ ssymbolToString domainName + , enableCurVal = return True + } 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..fd94e5eec8 --- /dev/null +++ b/clash-testbench/src/Clash/Testbench/Internal/ID.hs @@ -0,0 +1,197 @@ +module Clash.Testbench.Internal.ID + ( Source(..) + , Stage(..) + , AnyStage + , SIGNAL + , CLOCK + , RESET + , ENABLE + , IDT + , IDSource + , ID(..) + , idToInt + , isSignalID + , isClockID + , isResetID + , isEnableID + ) where + +import Clash.Prelude (Type) + +-- | Source of identification +data Source = + AutoDom String + -- ^ Implicit source determined through the domain + -- (given in reified form here) + | UserDef Int + -- ^ User defined source that has some modeled given by the user + deriving (Eq, Ord) + +instance Show Source where + show = \case + AutoDom str -> '@' : str + UserDef i -> show i + +data Stage :: Type where + -- | The test bench is created in the USER stage. The elements of + -- the test bench are setup by the user inside the TB monad during + -- this stage. + USER :: 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. + FINAL :: Stage + +-- | ID reference for the standard Clash 'Signal' type. +data SIGNAL +-- | ID reference for the special Clash 'Clock' type. +data CLOCK +-- | ID reference for the special Clash 'Reset' type. +data RESET +-- | ID reference for the special Clash 'Enable' type. +data ENABLE + +-- | Some closed type family used for capturing the available ID types. +type family IDT a where + IDT CLOCK = CLOCK + IDT RESET = RESET + IDT ENABLE = ENABLE + IDT a = SIGNAL + +-- | Closed type family, which determines the underlying ID type for +-- each of the different stages. +type family IDSource (s :: Stage) a where + -- at the final stage all ids must be of type Int + IDSource 'FINAL a = Int + -- clocks, resets and enable signals may have been introduced on the + -- fly and still need to get some unique id during post-processing. + IDSource 'USER CLOCK = Source + IDSource 'USER RESET = Source + IDSource 'USER ENABLE = Source + -- everything has a known id already + IDSource s a = Int + +-- | The ID data constructors for holding the different ID types. +data ID (stage :: Stage) a where + -- the pool of free IDs is only available a the USER stage and gets + -- closed at later stages + FreeID :: IDSource 'USER Int -> ID 'USER Int + -- the different ID types + SignalID :: IDSource stage SIGNAL -> ID stage SIGNAL + ClockID :: IDSource stage CLOCK -> ID stage CLOCK + ResetID :: IDSource stage RESET -> ID stage RESET + EnableID :: IDSource stage ENABLE -> ID stage ENABLE + -- wrapper type for passing different ID types around. Note that IDs + -- of the free id pool cannot be passed around this way. + SomeID :: (a ~ IDT a) => ID stage a -> ID stage () + +-- | This class collects some operations that are available during all +-- stages. It is mostly used to defined the remaining type class +-- instances of 'ID'. +class AnyStage (s :: Stage) where + mapID :: (Either Int Source -> b) -> ID s a -> b + +instance AnyStage 'USER where + mapID f = \case + FreeID x -> f $ Left x + SignalID x -> f $ Left x + ClockID x -> f $ Right x + ResetID x -> f $ Right x + EnableID x -> f $ Right x + SomeID s -> mapID f s + +instance AnyStage 'FINAL where + mapID f = \case + SignalID x -> f $ Left x + ClockID x -> f $ Left x + ResetID x -> f $ Left x + EnableID x -> f $ Left x + SomeID s -> mapID f s + +instance Num (ID 'USER 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 AnyStage s => Eq (ID s a) where + x == y = mapID (mapID (==) x) y + +instance AnyStage s => Ord (ID s a) where + compare x = mapID (mapID compare x) + +instance Show (ID s Int) where + show (FreeID x) = show x + +instance Show (ID s SIGNAL) where + show (SignalID x) = 's' : show x + +instance AnyStage s => Show (ID s CLOCK) where + show x = 'c' : mapID showEither x + +instance AnyStage s => Show (ID s RESET) where + show x = 'r' : mapID showEither x + +instance AnyStage s => Show (ID s ENABLE) where + show x = 'e' : mapID showEither x + +instance AnyStage s => Show (ID s ()) where + show (SomeID x) = case x of + SignalID{} -> show x + ClockID{} -> show x + ResetID{} -> show x + EnableID{} -> show x + +showEither :: (Show a, Show b) => Either a b -> String +showEither = \case + Left x -> show x + Right x -> show x + +-- | At the final stage all IDs are of type Int. +idToInt :: ID 'FINAL a -> Int +idToInt = \case + SignalID x -> x + ClockID x -> x + ResetID x -> x + EnableID x -> x + SomeID s -> idToInt s + +-- | Checks whether the given ID is a signal identifier. +isSignalID :: ID s a -> Bool +isSignalID = \case + SignalID{} -> True + SomeID s -> case s of + SignalID{} -> True + _ -> False + _ -> False + +-- | Checks whether the given ID is a clock identifier. +isClockID :: ID s a -> Bool +isClockID = \case + ClockID{} -> True + SomeID s -> case s of + ClockID{} -> True + _ -> False + _ -> False + +-- | Checks whether the given ID is a reset identifier. +isResetID :: ID s a -> Bool +isResetID = \case + ResetID{} -> True + SomeID s -> case s of + ResetID{} -> True + _ -> False + _ -> False + +-- | Checks whether the given ID is an enable identifier. +isEnableID :: ID s a -> Bool +isEnableID = \case + ResetID{} -> True + SomeID s -> case s of + ResetID{} -> True + _ -> False + _ -> False 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..efcd4eb323 --- /dev/null +++ b/clash-testbench/src/Clash/Testbench/Internal/Monad.hs @@ -0,0 +1,281 @@ +module Clash.Testbench.Internal.Monad where + +import Control.Arrow (second) +import Control.Monad.State.Lazy (StateT, liftIO, get, gets, modify, forM, evalStateT) +import Data.Set (Set, toList, member, insert) +import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) + +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Array as A + +import Clash.Signal.Internal (Signal(..), head#, tail#) +import Clash.Prelude + ( KnownDomain(..), BitPack(..), NFDataX, Enable, Clock, Reset + , toEnable, unsafeToReset + ) + +import Clash.Testbench.Signal +import Clash.Testbench.Internal.ID +import Clash.Testbench.Internal.Signal hiding (TBSignal, TBClock, TBReset, TBEnable) +import qualified Clash.Testbench.Internal.Signal as Internal + +-- | Simulation mode +data Simulator = + Internal + -- ^ Internal pure Haskell based simulation + | External + -- ^ Co-Simulation using an external simulator + +data DomainSpecificIDSource = + DSClock { domainFromDS :: Int } + | DSReset { domainFromDS :: Int } + | DSEnable { domainFromDS :: Int } + +instance Eq DomainSpecificIDSource where + DSClock{} == DSClock{} = True + DSReset{} == DSReset{} = True + DSEnable{} == DSEnable{} = True + _ == _ = False + +instance Ord DomainSpecificIDSource where + compare DSClock{} DSClock{} = EQ + compare DSClock{} _ = GT + compare _ DSClock{} = LT + compare DSReset{} DSReset{} = EQ + compare DSEnable{} DSEnable{} = EQ + compare DSEnable{} _ = LT + compare _ DSEnable{} = GT + +data ST = + ST + { idCount :: ID 'USER Int + , signals :: Set (SomeSignal 'USER) + , simStepRef :: IORef Int + , simMode :: IORef Simulator + , domIds :: M.Map String (Set DomainSpecificIDSource) + } + +data Testbench = + Testbench + { tbSignals :: [SomeSignal 'FINAL] + , tbLookupID :: ID 'FINAL () -> SomeSignal 'FINAL + , tbSimStepRef :: IORef Int + , tbSimMode :: IORef Simulator + } + +instance Show ST where + show ST{..} = + "ST {" + <> show idCount <> ", " + <> show (toList signals) + <> "}" + +-- | The 'TB' monad defines the context in which the test bench gets +-- be created by the user. To this end, the user can lift any Clash +-- 'Clash.Signal.Signal' or signal function into 'TB' using the '@@' +-- operator. The lifted signal / signal function then can be applied +-- to 'IO' driven inputs or the outputs can be post-processed inside +-- 'IO'. +-- +-- Note that 'TB' offers a construction environment, i.e., it is used +-- to describe the test bench structure. However, the test bench is +-- not executed inside 'TB'. +type TB a = StateT ST IO a + +nextFreeID :: TB (ID 'USER Int) +nextFreeID = do + i <- gets idCount + modify $ \st -> st { idCount = i + 1 } + return i + +registerTBS :: + (NFDataX a, BitPack a, KnownDomain dom) => + TBSignal dom a -> + TB (TBSignal dom a) +registerTBS s = do + let s' = SomeSignal s + modify $ \st@ST{..} -> + st { signals = if s' `member` signals then signals else insert s' signals } + return s + +type family ArgOf a where + ArgOf (a -> b) = a + +-- | 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 / 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 + + liftTB :: String -> [ID 'USER ()] + -> IO (IORef b, IO (ArgOf a, (ArgOf a -> ArgOf a) -> b -> b)) -> a + + +defTBLift :: (LiftTB a, a ~ (ArgOf a -> b)) => String -> ArgOf a -> b +defTBLift name x = + liftTB name [] ((\r -> (r, (,($)) <$> readIORef r)) <$> newIORef x) x + +instance + ( KnownDomain domA, KnownDomain domB + , domA ~ domB, a ~ a' + , NFDataX a, BitPack a + ) => LiftTB (Signal domA a -> TB (TBSignal domB a')) + where + (@@) = defTBLift + + liftTB name deps exec s = do + FreeID i <- nextFreeID + mode <- simMode <$> get + extVal <- liftIO $ newIORef Nothing + + ST{..} <- get + (signalRef, run) <- liftIO exec + simStepCache <- liftIO (readIORef simStepRef >>= newIORef) + + registerTBS $ Internal.TBSignal + { signal = s + , signalId = SignalID i + , signalDeps = reverse deps + , signalName = name + , signalCurVal = do + readIORef mode >>= \case + Internal -> do + (head# -> x, step) <- run + local <- readIORef simStepRef + world <- readIORef simStepCache + -- THOUGHT: one could also use an individual simulation + -- counter per domain allowing for multiple steps to be + -- simulated at once, if necessary. + if local == world + then return x + else do + modifyIORef signalRef $ step tail# + writeIORef simStepCache world + return x + External -> readIORef extVal >>= \case + Nothing -> error "No Value" + Just x -> return x + , signalUpdate = writeIORef extVal . Just + , signalPrint = Nothing + , vpiInstance = Nothing + } + +instance + ( KnownDomain dom, LiftTB (b -> c) + , arg ~ TBSignal dom a + ) => LiftTB ((Signal dom a -> b) -> arg -> c) + where + (@@) = defTBLift + + liftTB name deps exec sf s = + flip (liftTB name (SomeID (signalId s) : deps)) (sf $ signal s) + $ (<$> exec) $ second $ (=<<) $ \(sf', cont) -> do + v <- signalCurVal s + return (sf' $ pure v, cont . (\f sf'' -> f . sf'' . (v :-))) + +instance + ( KnownDomain dom, LiftTB (b -> c) + , arg ~ TBClock dom + ) => LiftTB ((Clock dom -> b) -> arg -> c) + where + (@@) = defTBLift + + liftTB name deps exec sf c = + flip (liftTB name (SomeID (clockId c) : deps)) (sf $ clock c) + $ (<$> exec) $ second $ (=<<) $ \(sf', cont) -> + return (sf' $ clock c, cont . (.)) + +instance + ( KnownDomain dom, LiftTB (b -> c) + , arg ~ TBReset dom + ) => LiftTB ((Reset dom -> b) -> arg -> c) + where + (@@) = defTBLift + + liftTB name deps exec sf r = + flip (liftTB name (SomeID (resetId r) : deps)) (sf $ reset r) + $ (<$> exec) $ second $ (=<<) $ \(sf', cont) -> do + v <- resetCurVal r + return (sf' $ unsafeToReset $ pure v, cont . (.)) + +instance + ( KnownDomain dom, LiftTB (b -> c) + , arg ~ TBEnable dom + ) => LiftTB ((Enable dom -> b) -> arg -> c) + where + (@@) = defTBLift + + liftTB name deps exec sf e = + flip (liftTB name (SomeID (enableId e) : deps)) (sf $ enable e) + $ (<$> exec) $ second $ (=<<) $ \(sf', cont) -> do + v <- enableCurVal e + return (sf' $ toEnable $ pure v, cont . (.)) + +runTB :: Simulator -> TB a -> IO (a, Testbench) +runTB mode testbench = do + simStepRef <- newIORef 0 + simMode <- newIORef mode + evalStateT (testbench >>= finalize) ST + { idCount = 0 + , signals = S.empty + , domIds = M.empty + , .. + } + where + finalize r = do + ST { signals, simStepRef, simMode } <- get + tbSignals <- forM (S.toAscList signals) $ \case + SomeSignal s -> case s of + (IOInput {signalId = SignalID x, ..} :: TBSignal dom a) -> + return $ SomeSignal + (IOInput { signalId = SignalID x, .. } :: Internal.TBSignal 'FINAL dom a) + Internal.TBSignal {signalId = SignalID x, ..} -> do + deps <- mapM fixAutoDomIds signalDeps + return $ SomeSignal $ Internal.TBSignal + { signalId = SignalID x + , signalDeps = deps + , .. + } + + FreeID n <- gets idCount + let a :: A.Array Int (SomeSignal 'FINAL) + a = A.array (0, n-1) + $ map (\s -> ((idToInt . signalId) `onAllSignalTypes` s, s)) + tbSignals + + return + ( r + , Testbench + { tbSimStepRef = simStepRef + , tbSimMode = simMode + , tbLookupID = (a A.!) . idToInt + , .. + } + ) + + fixAutoDomIds :: ID 'USER () -> TB (ID 'FINAL ()) + fixAutoDomIds (SomeID s) = case s of + SignalID x -> return $ SomeID $ SignalID x + ClockID x -> updAutoDom DSClock (SomeID . ClockID) x + ResetID x -> updAutoDom DSReset (SomeID . ResetID) x + EnableID x -> updAutoDom DSEnable (SomeID . EnableID) x + + updAutoDom ds c = \case + UserDef x -> return $ c x + AutoDom str -> do + sm <- gets domIds + case M.lookup str sm of + Just s -> case S.lookupIndex (ds 0) s of + Just i -> return $ c $ domainFromDS $ S.elemAt i s + Nothing -> nextAutoDomId ds c str sm (`S.insert` s) + Nothing -> nextAutoDomId ds c str sm S.singleton + + nextAutoDomId ds c str sm upd = do + FreeID x <- nextFreeID + modify $ \st -> st { domIds = M.insert str (upd $ ds x) sm } + return $ c x 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..d53bb8d3bd --- /dev/null +++ b/clash-testbench/src/Clash/Testbench/Internal/Signal.hs @@ -0,0 +1,155 @@ +module Clash.Testbench.Internal.Signal where + +import Data.Function (on) + +import Clash.Prelude + ( KnownDomain(..), BitPack(..), SDomainConfiguration(..), NFDataX + , Domain, Signal, Clock, Reset, Enable + , ssymbolToString + ) + +import Clash.FFI.VPI.Module (Module) +import Clash.FFI.VPI.Port (Port, Direction) + +import Clash.Testbench.Internal.ID + +data VPIPort = + VPIPort + { port :: Port + , portName :: String + , portSize :: Int + , portIndex :: Int + , portDirection :: Direction + } + +data VPIInstance = + VPIInstance + { vpiModule :: Module + , vpiInputPort :: ID 'FINAL () -> VPIPort + -- TODO: multiple port support vie Bundle/Unbundle + , vpiOutputPort :: VPIPort + } + +data TBSignal (s :: Stage) (dom :: Domain) a = + TBSignal + { signalId :: ID s SIGNAL + , signalDeps :: [ID s ()] + , signalName :: String + , signal :: Signal dom a + , signalCurVal :: IO a + , signalUpdate :: a -> IO () + , signalPrint :: Maybe (a -> String) + , vpiInstance :: Maybe VPIInstance + } + | IOInput + { signalId :: ID s SIGNAL + , signalCurVal :: IO a + , signalPrint :: Maybe (a -> String) + } + +instance (KnownDomain dom, AnyStage s) => Show (TBSignal s dom a) where + show = case knownDomain @dom of + SDomainConfiguration domainName _ _ _ _ _ -> \case + TBSignal{..} -> + "Signal \"" + <> signalName <> "\" @" + <> ssymbolToString domainName <> " " + <> show signalId <> " " + <> show signalDeps + IOInput{..} -> + "Input " <> show signalId + +instance AnyStage s => Eq (TBSignal s dom a) where + (==) = (==) `on` signalId + +instance AnyStage s => Ord (TBSignal s dom a) where + compare = compare `on` signalId + +----------- + +data TBClock (s :: Stage) (dom :: Domain) = + TBClock + { clock :: Clock dom + , clockId :: ID s CLOCK + , clockSource :: IO (Clock dom) + } + +instance (KnownDomain dom, AnyStage s) => Show (TBClock s dom) where + show TBClock{..} = case knownDomain @dom of + SDomainConfiguration domainName _ _ _ _ _ -> + "Clock @" + <> ssymbolToString domainName <> " " + <> show clockId + +instance AnyStage s => Eq (TBClock s dom) where + (==) = (==) `on` clockId + +instance AnyStage s => Ord (TBClock s dom) where + compare = compare `on` clockId + +data TBReset (s :: Stage) (dom :: Domain) = + TBReset + { reset :: Reset dom + , resetId :: ID s RESET + , resetCurVal :: IO Bool + } + +instance (KnownDomain dom, AnyStage s)=> Show (TBReset s dom) where + show TBReset{..} = case knownDomain @dom of + SDomainConfiguration domainName _ _ _ _ _ -> + "Reset @" + <> ssymbolToString domainName <> " " + <> show resetId + +instance AnyStage s => Eq (TBReset s dom) where + (==) = (==) `on` resetId + +instance AnyStage s => Ord (TBReset s dom) where + compare = compare `on` resetId + +data TBEnable (s :: Stage) (dom :: Domain) = + TBEnable + { enable :: Enable dom + , enableId :: ID s ENABLE + , enableCurVal :: IO Bool + } + +instance (KnownDomain dom, AnyStage s) => Show (TBEnable s dom) where + show TBEnable{..} = case knownDomain @dom of + SDomainConfiguration domainName _ _ _ _ _ -> + "Enable @" + <> ssymbolToString domainName <> " " + <> show enableId + +instance AnyStage s => Eq (TBEnable s dom) where + (==) = (==) `on` enableId + +instance AnyStage s => Ord (TBEnable s dom) where + compare = compare `on` enableId + +data SomeSignal (s :: Stage) where + SomeSignal :: + forall s dom a. + (KnownDomain dom, NFDataX a, BitPack a) => + TBSignal s dom a -> + SomeSignal s + +instance AnyStage s => Eq (SomeSignal s) where + (==) = (==) `on` (signalId `onAllSignalTypes`) + +instance AnyStage s => Ord (SomeSignal s) where + compare = compare `on` (signalId `onAllSignalTypes`) + +instance AnyStage s => Show (SomeSignal s) where + show = (show `onAllSignalTypes`) + +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 diff --git a/clash-testbench/src/Clash/Testbench/Output.hs b/clash-testbench/src/Clash/Testbench/Output.hs new file mode 100644 index 0000000000..ff9f5740c4 --- /dev/null +++ b/clash-testbench/src/Clash/Testbench/Output.hs @@ -0,0 +1,42 @@ +{-| +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 'TB' defined testbenches. +-} +module Clash.Testbench.Output + ( watch + , watchWith + ) where + +import Control.Monad.State.Lazy (modify) +import Data.Set (lookupIndex, insert, deleteAt) + +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'-converter for @a@. +watchWith :: + (KnownDomain dom, BitPack a, NFDataX a) => + (a -> String) -> TBSignal dom a -> TB () +watchWith toStr tbs = + modify $ \st@ST{..} -> + st { signals = case lookupIndex tbs' signals of + Nothing -> insert tbs' signals + Just i -> insert tbs' $ deleteAt i signals + } + where + tbs' = 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..9968094a33 --- /dev/null +++ b/clash-testbench/src/Clash/Testbench/Signal.hs @@ -0,0 +1,29 @@ +{-| +Copyright: (C) 2023 Google Inc. +License: BSD2 (see the file LICENSE) +Maintainer: QBayLogic B.V. + +'Clash.Testbench.Simulate.TB' lifted signals. +-} + +module Clash.Testbench.Signal + ( TBSignal + , TBClock + , TBReset + , TBEnable + ) where + +import Clash.Testbench.Internal.ID (Stage(..)) +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 'USER dom + +-- | A 'Clash.Signal.Clock' signal that has been lifted into the 'Clash.Testbench.Simulate.TB' context. +type TBClock dom = Internal.TBClock 'USER dom + +-- | A 'Clash.Signal.Reset' signal that has been lifted into the 'Clash.Testbench.Simulate.TB' context. +type TBReset dom = Internal.TBReset 'USER dom + +-- | An 'Clash.Signal.Enable' signal that has been lifted into the 'Clash.Testbench.Simulate.TB' context. +type TBEnable dom = Internal.TBEnable 'USER dom diff --git a/clash-testbench/src/Clash/Testbench/Simulate.hs b/clash-testbench/src/Clash/Testbench/Simulate.hs new file mode 100644 index 0000000000..30ee90a678 --- /dev/null +++ b/clash-testbench/src/Clash/Testbench/Simulate.hs @@ -0,0 +1,373 @@ +{-| +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. +-} +module Clash.Testbench.Simulate + ( TB + , LiftTB((@@)) + , AutoTB(..) + , simulate + , simulateFFI + ) where + +import Prelude hiding (putStrLn) +import qualified Prelude (putStrLn) + +import Control.Monad.IO.Class +import Control.Monad.State.Lazy hiding (lift) +import Data.Proxy + +import Data.Coerce (Coercible) +import Data.IORef +import Data.Bits (complement) +import Data.Maybe (catMaybes) +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 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.IO +import Clash.FFI.VPI.Callback +import Clash.FFI.VPI.Control +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 +import Clash.Testbench.Internal.Auto + +-- | @simulate n testbench@ simulates the @testbench@, created in the +-- '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 :: Int -> TB a -> IO a +simulate steps testbench = do + (r, Testbench{..}) <- runTB Internal testbench + replicateM_ (steps + 1) $ do + forM_ tbSignals $ onAllSignalTypes $ \s -> do + v <- signalCurVal s + i <- readIORef tbSimStepRef + when (i > 0) $ case signalPrint s of + Nothing -> return () + Just toStr -> Prelude.putStrLn . (<> toStr v) $ case s of + IOInput{} -> "I " + TBSignal{} -> "O " + modifyIORef tbSimStepRef (+ 1) + return r + +data VPIState = + VPIState + { vpiSignal :: ID 'FINAL () -> SomeSignal 'FINAL + , vpiSignals :: [SomeSignal 'FINAL] + , vpiStepRef :: IORef Int + , vpiClock :: Bit + , vpiSimSteps :: Int + , vpiInit :: Bool + } + +-- | @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 some @ffiMain@ foreign call +-- that is shipped via a shared library and executed by an external +-- simulator. See Clash-FFI for more details. +simulateFFI :: Int -> TB a -> IO a +simulateFFI steps testbench = do + (r, Testbench{..}) <- runTB External testbench + + let ?signalFromID = tbLookupID + + runSimAction $ do + -- print simulator info + putStrLn "[ Simulator Info ]" + Info{..} <- receiveSimulatorInfo + simPutStrLn infoProduct + simPutStrLn infoVersion + putStrLn "" + + -- print top modules + putStrLn "[ Top Modules ]" + tops' <- topModules + topNames <- mapM (receiveProperty Name) tops' + mapM_ simPutStrLn 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. + tops <- mapM findTopModule topNames + + -- match top modules with the signals -- + vpiSignals <- + fmap ((<>) (filter (not . isTBSignal) tbSignals) . catMaybes) + $ mapM matchModule + $ M.toAscList + $ M.unionWith (\(x,_) (_,y) -> (x,y)) + ( M.fromList + $ map (\s -> (signalName `onAllSignalTypes` s, (Just s, Nothing))) + $ filter isTBSignal tbSignals + ) + ( M.fromList + $ zip (map B.unpack topNames) + $ map (\t -> (Nothing, Just t)) tops + ) + + let + ?state = + VPIState + { vpiStepRef = tbSimStepRef + , vpiClock = low + , vpiSimSteps = steps + , vpiSignal = createIDMap vpiSignals + , vpiInit = True + , .. + } + + putStrLn "[ Simulation start ]" + putStrLn "" + + nextCB ReadWriteSynch 0 assignInputs + + return r + + where + createIDMap a b = + let f = flip M.lookup $ M.fromAscList $ map (\x -> (SomeID (signalId `onAllSignalTypes` x), x)) a in case f b of + Just x -> x + Nothing -> error $ show b + + isTBSignal = \case + SomeSignal TBSignal{} -> True + _ -> False + +assignInputs :: (?state :: VPIState) => SimAction () +assignInputs = do +-- SimTime time <- receiveTime Sim (Nothing @Object) +-- putStrLn $ "assignInputs " <> show (time, vpiClock, vpiInit) + + forM_ vpiSignals $ onAllSignalTypes $ \case + IOInput{} -> return () + TBSignal{..} -> mapM_ (assignModuleInputs vpiInstance) signalDeps + + let ?state = ?state { vpiClock = complement vpiClock + , vpiInit = False + } + + if vpiClock == low || vpiInit + then nextCB ReadWriteSynch 1 assignInputs + else nextCB ReadOnlySynch 1 readOutputs + + where + VPIState{..} = ?state + + assignModuleInputs :: Typeable b => Maybe VPIInstance -> ID 'FINAL () -> SimCont b () + assignModuleInputs = \case + Nothing -> const $ return () + Just VPIInstance{..} -> \sid@(SomeID x) -> + let VPIPort{..} = vpiInputPort sid + in case x of + ClockID _TODO -> sendV port vpiClock + ResetID _TODO -> sendV port $ boolToBit vpiInit + EnableID _TODO -> sendV port high + SignalID _TODO + | vpiClock == high -> return () + | otherwise -> + (`onAllSignalTypes` vpiSignal sid) $ \s -> + liftIO (signalCurVal s) >>= \v -> do + sendV port v + + sendV :: (BitPack a, Typeable b) => Port -> a -> SimCont b () + sendV port v = do + sendValue port (BitVectorVal SNat $ pack v) $ InertialDelay $ SimTime 0 + +readOutputs :: (?state :: VPIState) => SimAction () +readOutputs = do +-- SimTime time <- receiveTime Sim (Nothing @Object) +-- putStrLn $ "readOutputs " <> show time + + forM_ vpiSignals $ onAllSignalTypes $ \case + IOInput{} -> return () + TBSignal{..} -> case vpiInstance of + Nothing -> error "Cannot read from module" + Just VPIInstance{..} -> + receiveValue VectorFmt (port vpiOutputPort) >>= \case + BitVectorVal SNat v -> + liftIO $ signalUpdate $ unpack $ resize v + _ -> error "Unexpected return format" + + -- print the watched signals + i <- liftIO $ readIORef vpiStepRef + when (i > 0) $ forM_ vpiSignals $ onAllSignalTypes $ \s -> do + v <- liftIO $ signalCurVal s + case signalPrint s of + Nothing -> return () + Just toStr -> putStrLn . (<> toStr v) $ case s of + IOInput{} -> "I " + TBSignal{} -> "O " + + -- proceed time for all instances not running trough Clash-FFI + liftIO $ modifyIORef vpiStepRef (+ 1) + + if vpiSimSteps > 0 then do + let ?state = ?state { vpiSimSteps = vpiSimSteps - 1 } + nextCB ReadWriteSynch 1 assignInputs + else do + putStrLn "" + putStrLn "[ Simulation done ]" + + liftIO $ void $ try @SomeException $ runSimAction + $ controlSimulator $ Finish NoDiagnostics + + where + VPIState{..} = ?state + +matchModule :: + (?signalFromID :: ID 'FINAL () -> SomeSignal 'FINAL, Typeable b) => + (String, (Maybe (SomeSignal 'FINAL), Maybe Module)) -> + SimCont b (Maybe (SomeSignal 'FINAL)) +matchModule = \case + (_, (Just s, Just m)) -> case s of + SomeSignal s' -> Just . SomeSignal <$> vpiInst m s' + (name, (_, Nothing)) -> + error $ "No module matches \"" <> name <> "\"" + (name, (Nothing, _)) -> do + putStrLn $ "Module not required: \"" <> name <> "\" (ignoring)" + return Nothing + +vpiInst :: + (?signalFromID :: ID 'FINAL () -> SomeSignal 'FINAL, KnownDomain dom, BitPack a, Typeable b) => + Module -> TBSignal 'FINAL dom a -> SimCont b (TBSignal 'FINAL dom a) +vpiInst vpiModule = \case + IOInput{} -> error "Unfiltered IOInput" + tbs@TBSignal{..} -> do + ports <- modulePorts vpiModule + dirs <- mapM direction ports + + let + inputPorts = map fst $ filter (isInput . snd) $ zip ports dirs + outputPorts = map fst $ filter (isOutput . snd) $ zip ports dirs + + vpiInputPort <- + (M.!) . M.fromList + <$> ( mapM (matchPort vpiModule) + $ zip signalDeps + $ map Just inputPorts <> repeat Nothing + ) + + vpiOutputPort <- 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 vpiModule) portNameBS + + checkPort (toInteger portSize) tbs portDirection + + return $ VPIPort{..} + _ -> error "TODO: later / " + + return tbs { vpiInstance = Just VPIInstance{..} } + + where + isInput = \case + Input -> True + _ -> False + + isOutput = \case + Output -> True + _ -> False + +matchPort :: + (?signalFromID :: ID 'FINAL () -> SomeSignal 'FINAL, Typeable b) => + Module -> (ID 'FINAL (), Maybe Port) -> SimCont b (ID 'FINAL (), VPIPort) +matchPort m = \case + (_, Nothing) -> error "Not enough ports" + (sid, Just p) -> do + portNameBS <- receiveProperty Name p + portSize <- fromEnum <$> getProperty Size p + portIndex <- fromEnum <$> getProperty PortIndex p + portDirection <- direction p + + let portName = B.unpack portNameBS + + if + | isSignalID sid -> (`onAllSignalTypes` ?signalFromID sid) $ \s -> + checkPort (toInteger portSize) s portDirection + | isClockID sid && portSize /= 1 -> error $ "Not a clock port: " <> portName + | isResetID sid && portSize /= 1 -> error $ "Not a reset port: " <> portName + | isEnableID sid && portSize /= 1 -> error $ "Not a enable port: " <> portName + | otherwise -> return () + + -- Get a long-term reference via direct name access. Iterator + -- references may not be persitent. + port <- getByName (Just m) portNameBS + + return (sid, VPIPort{..}) + +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 + +--putStr :: String -> SimCont a () +--putStr = simPutStr . B.pack + +putStrLn :: String -> SimCont a () +putStrLn = simPutStrLn . B.pack + +--print :: Show a => a -> SimCont b () +--print = simPutStrLn . B.pack . show + +nextCB :: + (Maybe Object -> Time -> CallbackReason) -> + Int64 -> + SimAction () -> + SimAction () +nextCB reason time action = + void $ registerCallback + CallbackInfo + { cbReason = reason Nothing (SimTime time) + , cbRoutine = const (runSimAction action >> return 0) + , cbIndex = 0 + , cbData = B.empty + } From 1eefff84cd44b94e1a2c410874fc44dff938586b Mon Sep 17 00:00:00 2001 From: Felix Klein Date: Fri, 28 Apr 2023 08:31:02 +0200 Subject: [PATCH 2/9] Add Functor and Applicative instances --- clash-testbench/example/Main.hs | 2 +- clash-testbench/src/Clash/Testbench/Input.hs | 11 ++-- .../src/Clash/Testbench/Internal/ID.hs | 22 ++++++- .../src/Clash/Testbench/Internal/Monad.hs | 60 ++++++++++++------- .../src/Clash/Testbench/Internal/Signal.hs | 46 +++++++++++++- clash-testbench/src/Clash/Testbench/Output.hs | 11 +--- .../src/Clash/Testbench/Simulate.hs | 7 ++- 7 files changed, 115 insertions(+), 44 deletions(-) diff --git a/clash-testbench/example/Main.hs b/clash-testbench/example/Main.hs index c0368e5671..8278d6d161 100644 --- a/clash-testbench/example/Main.hs +++ b/clash-testbench/example/Main.hs @@ -9,7 +9,7 @@ import qualified Calculator (topEntity) myTestbench :: TB () myTestbench = mdo - input <- inputFromList Pop [Imm 1, Push, Imm 2, Push, Pop, Pop, Pop, ADD] + input <- fromList Pop [Imm 1, Push, Imm 2, Push, Pop, Pop, Pop, ADD] output <- ("topEntity" @@ Calculator.topEntity) auto auto auto input watch input watch output diff --git a/clash-testbench/src/Clash/Testbench/Input.hs b/clash-testbench/src/Clash/Testbench/Input.hs index 7a99a29b4b..90acd740ad 100644 --- a/clash-testbench/src/Clash/Testbench/Input.hs +++ b/clash-testbench/src/Clash/Testbench/Input.hs @@ -6,7 +6,7 @@ Maintainer: QBayLogic B.V. Input sources for simulating 'TB' defined testbenches. -} module Clash.Testbench.Input - ( inputFromList + ( fromList ) where import Control.Monad.State.Lazy @@ -25,17 +25,16 @@ import Clash.Testbench.Internal.ID -- 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 instead. -inputFromList +fromList :: (KnownDomain dom, BitPack a, NFDataX a) => a -> [a] -> TB (TBSignal dom a) -inputFromList x xs = do - FreeID i <- nextFreeID +fromList x xs = do ST{..} <- get listRef <- liftIO $ newIORef $ x : xs simStepCache <- liftIO (readIORef simStepRef >>= newIORef) - registerTBS $ IOInput - { signalId = SignalID i + mindSignal $ IOInput + { signalId = NoID , signalPrint = Nothing , signalCurVal = do (r, rs) <- fromMaybe (x, []) . uncons <$> readIORef listRef diff --git a/clash-testbench/src/Clash/Testbench/Internal/ID.hs b/clash-testbench/src/Clash/Testbench/Internal/ID.hs index fd94e5eec8..d835a38a9d 100644 --- a/clash-testbench/src/Clash/Testbench/Internal/ID.hs +++ b/clash-testbench/src/Clash/Testbench/Internal/ID.hs @@ -14,6 +14,7 @@ module Clash.Testbench.Internal.ID , isClockID , isResetID , isEnableID + , isNoID ) where import Clash.Prelude (Type) @@ -83,6 +84,9 @@ data ID (stage :: Stage) a where ClockID :: IDSource stage CLOCK -> ID stage CLOCK ResetID :: IDSource stage RESET -> ID stage RESET EnableID :: IDSource stage ENABLE -> ID stage ENABLE + -- signals that result from higher order applications may not be + -- explicitly available + NoID :: ID stage SIGNAL -- wrapper type for passing different ID types around. Note that IDs -- of the free id pool cannot be passed around this way. SomeID :: (a ~ IDT a) => ID stage a -> ID stage () @@ -100,6 +104,7 @@ instance AnyStage 'USER where ClockID x -> f $ Right x ResetID x -> f $ Right x EnableID x -> f $ Right x + NoID -> f $ Left (-1) SomeID s -> mapID f s instance AnyStage 'FINAL where @@ -108,6 +113,7 @@ instance AnyStage 'FINAL where ClockID x -> f $ Left x ResetID x -> f $ Left x EnableID x -> f $ Left x + NoID -> f $ Left (-1) SomeID s -> mapID f s instance Num (ID 'USER Int) where @@ -128,7 +134,9 @@ instance Show (ID s Int) where show (FreeID x) = show x instance Show (ID s SIGNAL) where - show (SignalID x) = 's' : show x + show = \case + SignalID x -> 's' : show x + NoID -> "-" instance AnyStage s => Show (ID s CLOCK) where show x = 'c' : mapID showEither x @@ -145,6 +153,7 @@ instance AnyStage s => Show (ID s ()) where ClockID{} -> show x ResetID{} -> show x EnableID{} -> show x + NoID{} -> show x showEither :: (Show a, Show b) => Either a b -> String showEither = \case @@ -158,17 +167,28 @@ idToInt = \case ClockID x -> x ResetID x -> x EnableID x -> x + NoID -> -1 SomeID s -> idToInt s -- | Checks whether the given ID is a signal identifier. isSignalID :: ID s a -> Bool isSignalID = \case SignalID{} -> True + NoID{} -> True SomeID s -> case s of SignalID{} -> True + NoID{} -> True _ -> False _ -> False +isNoID :: ID s a -> Bool +isNoID = \case + NoID{} -> True + SomeID s -> case s of + NoID{} -> True + _ -> False + _ -> False + -- | Checks whether the given ID is a clock identifier. isClockID :: ID s a -> Bool isClockID = \case diff --git a/clash-testbench/src/Clash/Testbench/Internal/Monad.hs b/clash-testbench/src/Clash/Testbench/Internal/Monad.hs index efcd4eb323..6ce7a4c8f3 100644 --- a/clash-testbench/src/Clash/Testbench/Internal/Monad.hs +++ b/clash-testbench/src/Clash/Testbench/Internal/Monad.hs @@ -2,7 +2,6 @@ module Clash.Testbench.Internal.Monad where import Control.Arrow (second) import Control.Monad.State.Lazy (StateT, liftIO, get, gets, modify, forM, evalStateT) -import Data.Set (Set, toList, member, insert) import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) import qualified Data.Map as M @@ -47,13 +46,15 @@ instance Ord DomainSpecificIDSource where compare DSEnable{} _ = LT compare _ DSEnable{} = GT +type KnownSignals (s :: Stage) = S.Set (SomeSignal s) + data ST = ST { idCount :: ID 'USER Int - , signals :: Set (SomeSignal 'USER) + , signals :: KnownSignals 'USER , simStepRef :: IORef Int , simMode :: IORef Simulator - , domIds :: M.Map String (Set DomainSpecificIDSource) + , domIds :: M.Map String (S.Set DomainSpecificIDSource) } data Testbench = @@ -68,7 +69,7 @@ instance Show ST where show ST{..} = "ST {" <> show idCount <> ", " - <> show (toList signals) + <> show (S.toAscList signals) <> "}" -- | The 'TB' monad defines the context in which the test bench gets @@ -89,15 +90,24 @@ nextFreeID = do modify $ \st -> st { idCount = i + 1 } return i -registerTBS :: +mindSignal :: (NFDataX a, BitPack a, KnownDomain dom) => TBSignal dom a -> TB (TBSignal dom a) -registerTBS s = do - let s' = SomeSignal s - modify $ \st@ST{..} -> - st { signals = if s' `member` signals then signals else insert s' signals } - return s +mindSignal s = case signalId s of + NoID -> do + FreeID i <- nextFreeID + let s' = s { signalId = SignalID i } + modify $ \st@ST{..} -> st { signals = S.insert (SomeSignal s') signals } + return s' + _ -> do + let s' = SomeSignal s + modify $ \st@ST{..} -> + st { signals = S.insert s' $ case S.lookupIndex s' signals of + Nothing -> signals + Just i -> S.deleteAt i signals + } + return s type family ArgOf a where ArgOf (a -> b) = a @@ -128,8 +138,7 @@ instance where (@@) = defTBLift - liftTB name deps exec s = do - FreeID i <- nextFreeID + liftTB signalName (reverse -> signalDeps) exec signal = do mode <- simMode <$> get extVal <- liftIO $ newIORef Nothing @@ -137,11 +146,8 @@ instance (signalRef, run) <- liftIO exec simStepCache <- liftIO (readIORef simStepRef >>= newIORef) - registerTBS $ Internal.TBSignal - { signal = s - , signalId = SignalID i - , signalDeps = reverse deps - , signalName = name + mindSignal $ Internal.TBSignal + { signalId = NoID , signalCurVal = do readIORef mode >>= \case Internal -> do @@ -160,9 +166,10 @@ instance External -> readIORef extVal >>= \case Nothing -> error "No Value" Just x -> return x - , signalUpdate = writeIORef extVal . Just + , signalUpdate = Just (writeIORef extVal . Just) , signalPrint = Nothing , vpiInstance = Nothing + , .. } instance @@ -231,13 +238,21 @@ runTB mode testbench = do ST { signals, simStepRef, simMode } <- get tbSignals <- forM (S.toAscList signals) $ \case SomeSignal s -> case s of - (IOInput {signalId = SignalID x, ..} :: TBSignal dom a) -> + (IOInput{..} :: TBSignal dom a) -> return $ SomeSignal - (IOInput { signalId = SignalID x, .. } :: Internal.TBSignal 'FINAL dom a) - Internal.TBSignal {signalId = SignalID x, ..} -> do + ( IOInput + { signalId = case signalId of + NoID -> NoID + SignalID x -> SignalID x + , .. + } :: Internal.TBSignal 'FINAL dom a + ) + Internal.TBSignal{..} -> do deps <- mapM fixAutoDomIds signalDeps return $ SomeSignal $ Internal.TBSignal - { signalId = SignalID x + { signalId = case signalId of + NoID -> NoID + SignalID x -> SignalID x , signalDeps = deps , .. } @@ -260,6 +275,7 @@ runTB mode testbench = do fixAutoDomIds :: ID 'USER () -> TB (ID 'FINAL ()) fixAutoDomIds (SomeID s) = case s of + NoID -> return $ SomeID $ NoID SignalID x -> return $ SomeID $ SignalID x ClockID x -> updAutoDom DSClock (SomeID . ClockID) x ResetID x -> updAutoDom DSReset (SomeID . ResetID) x diff --git a/clash-testbench/src/Clash/Testbench/Internal/Signal.hs b/clash-testbench/src/Clash/Testbench/Internal/Signal.hs index d53bb8d3bd..748927412c 100644 --- a/clash-testbench/src/Clash/Testbench/Internal/Signal.hs +++ b/clash-testbench/src/Clash/Testbench/Internal/Signal.hs @@ -37,7 +37,7 @@ data TBSignal (s :: Stage) (dom :: Domain) a = , signalName :: String , signal :: Signal dom a , signalCurVal :: IO a - , signalUpdate :: a -> IO () + , signalUpdate :: Maybe (a -> IO ()) , signalPrint :: Maybe (a -> String) , vpiInstance :: Maybe VPIInstance } @@ -65,7 +65,49 @@ instance AnyStage s => Eq (TBSignal s dom a) where instance AnyStage s => Ord (TBSignal s dom a) where compare = compare `on` signalId ------------ +instance Functor (TBSignal 'USER dom) where + fmap f = \case + TBSignal{..} -> + TBSignal + { signalId = NoID + , signal = fmap f signal + , signalCurVal = f <$> signalCurVal + -- We cannot update the values of a mapped signal, which + -- makes sense, since a mapped signal cannot be simulated + -- externally. It is always defined as the result of + -- applying 'f' to the given source signal. + , signalUpdate = Nothing + -- we lose printing abilities at this point. This is fine, + -- since printing capabilities are recovered automatically + -- once the new signal gets watched. + , signalPrint = Nothing + , .. + } + IOInput{..} -> + IOInput + { signalId = NoID + , signalCurVal = f <$> signalCurVal + -- we lose printing abilities at this point. This is fine, + -- since printing capabilities are recovered automatically + -- once the new signal gets watched. + , signalPrint = Nothing + , .. + } + +instance Applicative (TBSignal 'USER dom) where + pure x = + IOInput + { signalId = NoID + , signalCurVal = pure x + , signalPrint = Nothing + } + + f <*> s = + IOInput + { signalId = NoID + , signalCurVal = signalCurVal f <*> signalCurVal s + , signalPrint = Nothing + } data TBClock (s :: Stage) (dom :: Domain) = TBClock diff --git a/clash-testbench/src/Clash/Testbench/Output.hs b/clash-testbench/src/Clash/Testbench/Output.hs index ff9f5740c4..5b876413e3 100644 --- a/clash-testbench/src/Clash/Testbench/Output.hs +++ b/clash-testbench/src/Clash/Testbench/Output.hs @@ -11,8 +11,7 @@ module Clash.Testbench.Output , watchWith ) where -import Control.Monad.State.Lazy (modify) -import Data.Set (lookupIndex, insert, deleteAt) +import Control.Monad (void) import Clash.Prelude (KnownDomain(..), BitPack(..), NFDataX) @@ -33,10 +32,4 @@ watchWith :: (KnownDomain dom, BitPack a, NFDataX a) => (a -> String) -> TBSignal dom a -> TB () watchWith toStr tbs = - modify $ \st@ST{..} -> - st { signals = case lookupIndex tbs' signals of - Nothing -> insert tbs' signals - Just i -> insert tbs' $ deleteAt i signals - } - where - tbs' = SomeSignal $ tbs { signalPrint = Just toStr } + void $ mindSignal tbs { signalPrint = Just toStr } diff --git a/clash-testbench/src/Clash/Testbench/Simulate.hs b/clash-testbench/src/Clash/Testbench/Simulate.hs index 30ee90a678..ec318403f5 100644 --- a/clash-testbench/src/Clash/Testbench/Simulate.hs +++ b/clash-testbench/src/Clash/Testbench/Simulate.hs @@ -190,7 +190,7 @@ assignInputs = do ClockID _TODO -> sendV port vpiClock ResetID _TODO -> sendV port $ boolToBit vpiInit EnableID _TODO -> sendV port high - SignalID _TODO + _ | vpiClock == high -> return () | otherwise -> (`onAllSignalTypes` vpiSignal sid) $ \s -> @@ -212,8 +212,9 @@ readOutputs = do Nothing -> error "Cannot read from module" Just VPIInstance{..} -> receiveValue VectorFmt (port vpiOutputPort) >>= \case - BitVectorVal SNat v -> - liftIO $ signalUpdate $ unpack $ resize v + BitVectorVal SNat v -> case signalUpdate of + Just upd -> liftIO $ upd $ unpack $ resize v + Nothing -> error "No signal update" _ -> error "Unexpected return format" -- print the watched signals From c46c1dd383ac8b39456909c79d15b10b7b963f67 Mon Sep 17 00:00:00 2001 From: Felix Klein Date: Fri, 28 Apr 2023 09:25:09 +0200 Subject: [PATCH 3/9] Add simple Hedgehog generator support --- clash-testbench/clash-testbench.cabal | 2 ++ clash-testbench/src/Clash/Testbench.hs | 2 ++ .../src/Clash/Testbench/Generate.hs | 24 +++++++++++++++++++ .../src/Clash/Testbench/Internal/Monad.hs | 11 +++++++++ .../src/Clash/Testbench/Internal/Signal.hs | 22 +++++++++++++---- .../src/Clash/Testbench/Simulate.hs | 17 +++++++------ 6 files changed, 67 insertions(+), 11 deletions(-) create mode 100644 clash-testbench/src/Clash/Testbench/Generate.hs diff --git a/clash-testbench/clash-testbench.cabal b/clash-testbench/clash-testbench.cabal index acce77ea74..3849be3b58 100644 --- a/clash-testbench/clash-testbench.cabal +++ b/clash-testbench/clash-testbench.cabal @@ -39,6 +39,7 @@ library Clash.Testbench.Input Clash.Testbench.Output Clash.Testbench.Simulate + Clash.Testbench.Generate other-modules: Clash.Testbench.Internal.ID Clash.Testbench.Internal.Signal @@ -48,6 +49,7 @@ library base, mtl, array, + hedgehog, containers, bytestring, clash-ffi, diff --git a/clash-testbench/src/Clash/Testbench.hs b/clash-testbench/src/Clash/Testbench.hs index a205573798..42944de6ea 100644 --- a/clash-testbench/src/Clash/Testbench.hs +++ b/clash-testbench/src/Clash/Testbench.hs @@ -10,9 +10,11 @@ module Clash.Testbench , 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..6983163d10 --- /dev/null +++ b/clash-testbench/src/Clash/Testbench/Generate.hs @@ -0,0 +1,24 @@ +module Clash.Testbench.Generate where + +import Hedgehog +import Hedgehog.Gen + +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 + +generate :: + (NFDataX a, BitPack a, KnownDomain dom) => + Gen a -> TB (TBSignal dom a) +generate generator = + mindSignal Generator + { signalId = NoID + , signalCurVal = sample generator + , signalPrint = Nothing + , .. + } + + diff --git a/clash-testbench/src/Clash/Testbench/Internal/Monad.hs b/clash-testbench/src/Clash/Testbench/Internal/Monad.hs index 6ce7a4c8f3..0850aa1690 100644 --- a/clash-testbench/src/Clash/Testbench/Internal/Monad.hs +++ b/clash-testbench/src/Clash/Testbench/Internal/Monad.hs @@ -247,6 +247,15 @@ runTB mode testbench = do , .. } :: Internal.TBSignal 'FINAL dom a ) + (Generator{..} :: TBSignal dom a) -> + return $ SomeSignal + ( Generator + { signalId = case signalId of + NoID -> NoID + SignalID x -> SignalID x + , .. + } :: Internal.TBSignal 'FINAL dom a + ) Internal.TBSignal{..} -> do deps <- mapM fixAutoDomIds signalDeps return $ SomeSignal $ Internal.TBSignal @@ -257,6 +266,8 @@ runTB mode testbench = do , .. } + + FreeID n <- gets idCount let a :: A.Array Int (SomeSignal 'FINAL) a = A.array (0, n-1) diff --git a/clash-testbench/src/Clash/Testbench/Internal/Signal.hs b/clash-testbench/src/Clash/Testbench/Internal/Signal.hs index 748927412c..3df504a0ac 100644 --- a/clash-testbench/src/Clash/Testbench/Internal/Signal.hs +++ b/clash-testbench/src/Clash/Testbench/Internal/Signal.hs @@ -8,6 +8,8 @@ import Clash.Prelude , ssymbolToString ) +import Hedgehog (Gen) + import Clash.FFI.VPI.Module (Module) import Clash.FFI.VPI.Port (Port, Direction) @@ -46,6 +48,12 @@ data TBSignal (s :: Stage) (dom :: Domain) a = , signalCurVal :: IO a , signalPrint :: Maybe (a -> String) } + | Generator + { signalId :: ID s SIGNAL + , signalCurVal :: IO a + , signalPrint :: Maybe (a -> String) + , generator :: Gen a + } instance (KnownDomain dom, AnyStage s) => Show (TBSignal s dom a) where show = case knownDomain @dom of @@ -58,6 +66,8 @@ instance (KnownDomain dom, AnyStage s) => Show (TBSignal s dom a) where <> show signalDeps IOInput{..} -> "Input " <> show signalId + Generator{..} -> + "Gen " <> show signalId instance AnyStage s => Eq (TBSignal s dom a) where (==) = (==) `on` signalId @@ -79,7 +89,7 @@ instance Functor (TBSignal 'USER dom) where , signalUpdate = Nothing -- we lose printing abilities at this point. This is fine, -- since printing capabilities are recovered automatically - -- once the new signal gets watched. + -- once the new signal requires printing capabilities again. , signalPrint = Nothing , .. } @@ -87,12 +97,16 @@ instance Functor (TBSignal 'USER dom) where IOInput { signalId = NoID , signalCurVal = f <$> signalCurVal - -- we lose printing abilities at this point. This is fine, - -- since printing capabilities are recovered automatically - -- once the new signal gets watched. , signalPrint = Nothing , .. } + Generator{..} -> + Generator + { signalId = NoID + , signalCurVal = f <$> signalCurVal + , signalPrint = Nothing + , generator = f <$> generator + } instance Applicative (TBSignal 'USER dom) where pure x = diff --git a/clash-testbench/src/Clash/Testbench/Simulate.hs b/clash-testbench/src/Clash/Testbench/Simulate.hs index ec318403f5..8d00bb82b7 100644 --- a/clash-testbench/src/Clash/Testbench/Simulate.hs +++ b/clash-testbench/src/Clash/Testbench/Simulate.hs @@ -67,8 +67,9 @@ simulate steps testbench = do when (i > 0) $ case signalPrint s of Nothing -> return () Just toStr -> Prelude.putStrLn . (<> toStr v) $ case s of - IOInput{} -> "I " - TBSignal{} -> "O " + IOInput{} -> "I " + Generator{} -> "I " + TBSignal{} -> "O " modifyIORef tbSimStepRef (+ 1) return r @@ -167,8 +168,9 @@ assignInputs = do -- putStrLn $ "assignInputs " <> show (time, vpiClock, vpiInit) forM_ vpiSignals $ onAllSignalTypes $ \case - IOInput{} -> return () TBSignal{..} -> mapM_ (assignModuleInputs vpiInstance) signalDeps + _ -> return () + let ?state = ?state { vpiClock = complement vpiClock , vpiInit = False @@ -207,7 +209,6 @@ readOutputs = do -- putStrLn $ "readOutputs " <> show time forM_ vpiSignals $ onAllSignalTypes $ \case - IOInput{} -> return () TBSignal{..} -> case vpiInstance of Nothing -> error "Cannot read from module" Just VPIInstance{..} -> @@ -216,6 +217,7 @@ readOutputs = do Just upd -> liftIO $ upd $ unpack $ resize v Nothing -> error "No signal update" _ -> error "Unexpected return format" + _ -> return () -- print the watched signals i <- liftIO $ readIORef vpiStepRef @@ -224,8 +226,9 @@ readOutputs = do case signalPrint s of Nothing -> return () Just toStr -> putStrLn . (<> toStr v) $ case s of - IOInput{} -> "I " - TBSignal{} -> "O " + IOInput{} -> "I " + Generator{} -> "I " + TBSignal{} -> "O " -- proceed time for all instances not running trough Clash-FFI liftIO $ modifyIORef vpiStepRef (+ 1) @@ -260,7 +263,6 @@ vpiInst :: (?signalFromID :: ID 'FINAL () -> SomeSignal 'FINAL, KnownDomain dom, BitPack a, Typeable b) => Module -> TBSignal 'FINAL dom a -> SimCont b (TBSignal 'FINAL dom a) vpiInst vpiModule = \case - IOInput{} -> error "Unfiltered IOInput" tbs@TBSignal{..} -> do ports <- modulePorts vpiModule dirs <- mapM direction ports @@ -292,6 +294,7 @@ vpiInst vpiModule = \case _ -> error "TODO: later / " return tbs { vpiInstance = Just VPIInstance{..} } + _ -> error "Unfiltered TBS" where isInput = \case From 313d055107d166d9f67eabedc8246027d28ad68f Mon Sep 17 00:00:00 2001 From: Felix Klein Date: Wed, 3 May 2023 14:40:13 +0200 Subject: [PATCH 4/9] Hedgehog Integration (WIP) --- clash-testbench/clash-testbench.cabal | 1 + clash-testbench/example/Main.hs | 41 ++++- clash-testbench/example/cabal.project | 2 +- .../example/clash-testbench-example.cabal | 2 + .../src/Clash/Testbench/Generate.hs | 137 ++++++++++++++- .../src/Clash/Testbench/Internal/Monad.hs | 157 +++++++++++------- .../src/Clash/Testbench/Internal/Signal.hs | 91 +++++----- .../src/Clash/Testbench/Simulate.hs | 36 ++-- 8 files changed, 337 insertions(+), 130 deletions(-) diff --git a/clash-testbench/clash-testbench.cabal b/clash-testbench/clash-testbench.cabal index 3849be3b58..9b0bc445c8 100644 --- a/clash-testbench/clash-testbench.cabal +++ b/clash-testbench/clash-testbench.cabal @@ -49,6 +49,7 @@ library base, mtl, array, + lattices, hedgehog, containers, bytestring, diff --git a/clash-testbench/example/Main.hs b/clash-testbench/example/Main.hs index 8278d6d161..6798f1b021 100644 --- a/clash-testbench/example/Main.hs +++ b/clash-testbench/example/Main.hs @@ -1,24 +1,59 @@ {-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE DataKinds #-} module Main where +import Data.Bool (bool) + +import Clash.Prelude (Signed) + import Clash.Testbench import Calculator (OPC(..)) import qualified Calculator (topEntity) +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 <- 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 main :: IO () -main = simulate 10 myTestbench +main = simulate 38 myTestbench foreign export ccall "clash_ffi_main" ffiMain :: IO () ffiMain :: IO () -ffiMain = simulateFFI 10 myTestbench +ffiMain = simulateFFI 38 myTestbench diff --git a/clash-testbench/example/cabal.project b/clash-testbench/example/cabal.project index ac247a039c..7c3861ca2f 100644 --- a/clash-testbench/example/cabal.project +++ b/clash-testbench/example/cabal.project @@ -1,3 +1,3 @@ -packages: . .. ../../clash-ghc ../../clash-lib ../../clash-prelude ../../clash-ffi +packages: . .. ../../clash-ghc ../../clash-lib ../../clash-prelude ../../clash-ffi ../../clash-prelude-hedgehog write-ghc-environment-files: always diff --git a/clash-testbench/example/clash-testbench-example.cabal b/clash-testbench/example/clash-testbench-example.cabal index dd461b1997..2aa14f9163 100644 --- a/clash-testbench/example/clash-testbench-example.cabal +++ b/clash-testbench/example/clash-testbench-example.cabal @@ -20,7 +20,9 @@ common basic-config -fplugin GHC.TypeLits.KnownNat.Solver build-depends: base, + hedgehog, clash-prelude, + clash-prelude-hedgehog, clash-testbench, ghc-typelits-extra, ghc-typelits-knownnat, diff --git a/clash-testbench/src/Clash/Testbench/Generate.hs b/clash-testbench/src/Clash/Testbench/Generate.hs index 6983163d10..c3a0143a86 100644 --- a/clash-testbench/src/Clash/Testbench/Generate.hs +++ b/clash-testbench/src/Clash/Testbench/Generate.hs @@ -2,6 +2,8 @@ module Clash.Testbench.Generate where import Hedgehog import Hedgehog.Gen +import Control.Monad.State.Lazy (liftIO, get) +import Data.IORef (newIORef, readIORef, writeIORef) import Clash.Prelude (KnownDomain(..), BitPack(..), NFDataX) @@ -10,15 +12,138 @@ import Clash.Testbench.Internal.ID import Clash.Testbench.Internal.Signal hiding (TBSignal, TBClock, TBReset, TBEnable) import Clash.Testbench.Internal.Monad +matchIOGen :: + (NFDataX i, BitPack i, KnownDomain dom, Eq o, Show o) => + TBSignal dom o -> Gen (i, o) -> TB (TBSignal dom i) +matchIOGen expectedOutput gen = do + ST{..} <- get + + vRef <- liftIO $ newIORef undefined + simStepCache <- liftIO (readIORef simStepRef >>= newIORef) + + mind SomeSignal $ IOInput + { signalId = NoID + , signalCurVal = do + v <- readIORef simStepRef + v' <- readIORef simStepCache + + if v == v' + then readIORef vRef + else do + (i, o) <- sample gen + signalExpect expectedOutput $ Expectation (v + 1, verify o) + + writeIORef vRef i + writeIORef simStepCache v + return i + , signalPrint = Nothing + } + where + verify x y + | x == y = Nothing + | otherwise = Just $ "Expected " <> show x <> " but the output is " <> show y + + +matchIOGenN :: + (NFDataX i, BitPack i, KnownDomain dom, Eq o, Show o) => + TBSignal dom o -> Gen [(i, o)] -> TB (TBSignal dom i) +matchIOGenN expectedOutput gen = do + ST{..} <- get + + vRef <- liftIO $ newIORef [] + simStepCache <- liftIO (readIORef simStepRef >>= newIORef) + + mind SomeSignal $ IOInput + { signalId = NoID + , signalCurVal = do + v <- readIORef simStepRef + v' <- readIORef simStepCache + + if v == v' + then readIORef vRef >>= \case + (i, _) : _ -> return i + [] -> do + (i, o) : xr <- sample gen + writeIORef vRef ((i, o) : xr) + return i + else do + writeIORef simStepCache v + readIORef vRef >>= \case + _ : (i, o) : xr -> do + writeIORef vRef ((i, o) : xr) + signalExpect expectedOutput $ Expectation (v, verify o) + return i + _ -> do + (i, o) : xr <- sample gen + writeIORef vRef ((i, o) : xr) + signalExpect expectedOutput $ Expectation (v, verify o) + return i + , signalPrint = Nothing + } + where + verify x y + | x == y = Nothing + | otherwise = Just $ "Expected '" <> show x <> "' but the output is '" <> show y <> "'" + + generate :: (NFDataX a, BitPack a, KnownDomain dom) => - Gen a -> TB (TBSignal dom a) -generate generator = - mindSignal Generator + a -> Gen a -> TB (TBSignal dom a) +generate def gen = do + ST{..} <- get + + vRef <- liftIO $ newIORef def + simStepCache <- liftIO (readIORef simStepRef >>= newIORef) + + mind SomeSignal IOInput { signalId = NoID - , signalCurVal = sample generator + , signalCurVal = do + v <- readIORef simStepRef + v' <- readIORef simStepCache + + if v == v' + then readIORef vRef + else do + x <- sample gen + writeIORef vRef x + writeIORef simStepCache v + return x , signalPrint = Nothing - , .. } - +generateN :: + (NFDataX a, BitPack a, KnownDomain dom) => + a -> Gen [a] -> TB (TBSignal dom a) +generateN def gen = do + ST{..} <- get + + vRef <- liftIO $ newIORef [def] + simStepCache <- liftIO (readIORef simStepRef >>= newIORef) + + mindSignal IOInput + { signalId = NoID + , signalCurVal = do + v <- readIORef simStepRef + v' <- readIORef simStepCache + + if v == v' + then readIORef vRef >>= \case + x : _ -> return x + [] -> do + x : xr <- sample gen + writeIORef vRef (x : xr) + return x + + else do + writeIORef simStepCache v + readIORef vRef >>= \case + _ : x : xr -> do + writeIORef vRef (x : xr) + return x + _ -> do + x : xr <- sample gen + writeIORef vRef (x : xr) + return x + , signalPrint = Nothing + , .. + } diff --git a/clash-testbench/src/Clash/Testbench/Internal/Monad.hs b/clash-testbench/src/Clash/Testbench/Internal/Monad.hs index 0850aa1690..7a9760092e 100644 --- a/clash-testbench/src/Clash/Testbench/Internal/Monad.hs +++ b/clash-testbench/src/Clash/Testbench/Internal/Monad.hs @@ -1,8 +1,12 @@ module Clash.Testbench.Internal.Monad where +import Algebra.PartialOrd import Control.Arrow (second) import Control.Monad.State.Lazy (StateT, liftIO, get, gets, modify, forM, evalStateT) +import Data.Function ((&)) import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) +import Data.List (uncons, partition) +import Data.Maybe (catMaybes) import qualified Data.Map as M import qualified Data.Set as S @@ -52,6 +56,7 @@ data ST = ST { idCount :: ID 'USER Int , signals :: KnownSignals 'USER + , monitors :: KnownSignals 'USER , simStepRef :: IORef Int , simMode :: IORef Simulator , domIds :: M.Map String (S.Set DomainSpecificIDSource) @@ -90,25 +95,37 @@ nextFreeID = do modify $ \st -> st { idCount = i + 1 } return i -mindSignal :: - (NFDataX a, BitPack a, KnownDomain dom) => +mind :: + (KnownDomain dom, NFDataX a, BitPack a) => + (TBSignal dom a -> SomeSignal 'USER) -> TBSignal dom a -> TB (TBSignal dom a) -mindSignal s = case signalId s of +mind t s = case signalId s of NoID -> do FreeID i <- nextFreeID let s' = s { signalId = SignalID i } - modify $ \st@ST{..} -> st { signals = S.insert (SomeSignal s') signals } + modify $ \st@ST{..} -> st { signals = S.insert (t s') signals } return s' _ -> do - let s' = SomeSignal s modify $ \st@ST{..} -> - st { signals = S.insert s' $ case S.lookupIndex s' signals of + st { signals = S.insert (t s) $ case S.lookupIndex (t s) signals of Nothing -> signals Just i -> S.deleteAt i signals } return s +mindSignal :: + (KnownDomain dom, NFDataX a, BitPack a) => + TBSignal dom a -> + TB (TBSignal dom a) +mindSignal = mind SomeSignal + +monitor :: + KnownDomain dom => + TBSignal dom Bool -> + TB (TBSignal dom Bool) +monitor = mind SomeMonitor + type family ArgOf a where ArgOf (a -> b) = a @@ -138,35 +155,53 @@ instance where (@@) = defTBLift - liftTB signalName (reverse -> signalDeps) exec signal = do + liftTB signalName (reverse -> dependencies) exec origin = do mode <- simMode <$> get extVal <- liftIO $ newIORef Nothing + expectations <- liftIO $ newIORef [] ST{..} <- get (signalRef, run) <- liftIO exec simStepCache <- liftIO (readIORef simStepRef >>= newIORef) - mindSignal $ Internal.TBSignal + let + signalCurVal = do + readIORef mode >>= \case + Internal -> do + (head# -> x, step) <- run + local <- readIORef simStepRef + world <- readIORef simStepCache + -- THOUGHT: one could also use an individual simulation + -- counter per domain allowing for multiple steps to be + -- simulated at once, if necessary. + if local == world + then return x + else do + modifyIORef signalRef $ step tail# + writeIORef simStepCache world + return x + External -> readIORef extVal >>= \case + Nothing -> error "No Value" + Just x -> return x + + mind SomeSignal $ Internal.SimSignal { signalId = NoID - , signalCurVal = do - readIORef mode >>= \case - Internal -> do - (head# -> x, step) <- run - local <- readIORef simStepRef - world <- readIORef simStepCache - -- THOUGHT: one could also use an individual simulation - -- counter per domain allowing for multiple steps to be - -- simulated at once, if necessary. - if local == world - then return x - else do - modifyIORef signalRef $ step tail# - writeIORef simStepCache world - return x - External -> readIORef extVal >>= \case - Nothing -> error "No Value" - Just x -> return x , signalUpdate = Just (writeIORef extVal . Just) + , signalExpect = modifyIORef expectations . (:) + , signalVerify = do + step <- readIORef simStepRef + value <- signalCurVal + expct <- readIORef expectations + + let + (cur, later) = + partition (flip leq $ Expectation (step + 1, undefined)) expct + + writeIORef expectations later + + return$ fmap fst $ uncons $ catMaybes + $ map ((value &) . snd . expectation) cur + , signalPrint = Nothing , vpiInstance = Nothing , .. @@ -180,7 +215,7 @@ instance (@@) = defTBLift liftTB name deps exec sf s = - flip (liftTB name (SomeID (signalId s) : deps)) (sf $ signal s) + flip (liftTB name (SomeID (signalId s) : deps)) (sf $ origin s) $ (<$> exec) $ second $ (=<<) $ \(sf', cont) -> do v <- signalCurVal s return (sf' $ pure v, cont . (\f sf'' -> f . sf'' . (v :-))) @@ -228,45 +263,18 @@ runTB mode testbench = do simStepRef <- newIORef 0 simMode <- newIORef mode evalStateT (testbench >>= finalize) ST - { idCount = 0 - , signals = S.empty - , domIds = M.empty + { idCount = 0 + , signals = S.empty + , monitors = S.empty + , domIds = M.empty , .. } where finalize r = do ST { signals, simStepRef, simMode } <- get tbSignals <- forM (S.toAscList signals) $ \case - SomeSignal s -> case s of - (IOInput{..} :: TBSignal dom a) -> - return $ SomeSignal - ( IOInput - { signalId = case signalId of - NoID -> NoID - SignalID x -> SignalID x - , .. - } :: Internal.TBSignal 'FINAL dom a - ) - (Generator{..} :: TBSignal dom a) -> - return $ SomeSignal - ( Generator - { signalId = case signalId of - NoID -> NoID - SignalID x -> SignalID x - , .. - } :: Internal.TBSignal 'FINAL dom a - ) - Internal.TBSignal{..} -> do - deps <- mapM fixAutoDomIds signalDeps - return $ SomeSignal $ Internal.TBSignal - { signalId = case signalId of - NoID -> NoID - SignalID x -> SignalID x - , signalDeps = deps - , .. - } - - + SomeSignal s -> SomeSignal <$> finalizeSignal s + SomeMonitor s -> SomeMonitor <$> finalizeSignal s FreeID n <- gets idCount let a :: A.Array Int (SomeSignal 'FINAL) @@ -284,6 +292,35 @@ runTB mode testbench = do } ) + finalizeSignal :: + Internal.TBSignal 'USER dom a -> + TB (Internal.TBSignal 'FINAL dom a) + + finalizeSignal = \case + SimSignal{..} -> do + deps <- mapM fixAutoDomIds dependencies + return $ SimSignal + { signalId = case signalId of + NoID -> NoID + SignalID x -> SignalID x + , dependencies = deps + , .. + } + IOInput{..} -> + return $ IOInput + { signalId = case signalId of + NoID -> NoID + SignalID x -> SignalID x + , .. + } + Internal.TBSignal{..} -> + return $ Internal.TBSignal + { signalId = case signalId of + NoID -> NoID + SignalID x -> SignalID x + , .. + } + fixAutoDomIds :: ID 'USER () -> TB (ID 'FINAL ()) fixAutoDomIds (SomeID s) = case s of NoID -> return $ SomeID $ NoID diff --git a/clash-testbench/src/Clash/Testbench/Internal/Signal.hs b/clash-testbench/src/Clash/Testbench/Internal/Signal.hs index 3df504a0ac..e8a476d57c 100644 --- a/clash-testbench/src/Clash/Testbench/Internal/Signal.hs +++ b/clash-testbench/src/Clash/Testbench/Internal/Signal.hs @@ -1,5 +1,6 @@ module Clash.Testbench.Internal.Signal where +import Algebra.PartialOrd import Data.Function (on) import Clash.Prelude @@ -8,11 +9,8 @@ import Clash.Prelude , ssymbolToString ) -import Hedgehog (Gen) - import Clash.FFI.VPI.Module (Module) import Clash.FFI.VPI.Port (Port, Direction) - import Clash.Testbench.Internal.ID data VPIPort = @@ -32,42 +30,57 @@ data VPIInstance = , vpiOutputPort :: VPIPort } +newtype Expectation a = Expectation { expectation :: (Int, a -> Maybe String) } + +-- | Expectations cannot be compared, hence they are always unequal +instance Eq (Expectation a) where + _ == _ = False + +-- | Expectations enjoy some partial order via the simulation step at +-- which they are verified. +instance PartialOrd (Expectation a) where + leq (Expectation (x, _)) (Expectation (y, _)) = x <= y + comparable (Expectation (x, _)) (Expectation (y, _)) = x /= y + data TBSignal (s :: Stage) (dom :: Domain) a = - TBSignal + -- | Signal that can be simulated + SimSignal { signalId :: ID s SIGNAL - , signalDeps :: [ID s ()] - , signalName :: String - , signal :: Signal dom a , signalCurVal :: IO a - , signalUpdate :: Maybe (a -> IO ()) , signalPrint :: Maybe (a -> String) + , origin :: Signal dom a + , dependencies :: [ID s ()] + , signalName :: String + , signalUpdate :: Maybe (a -> IO ()) + , signalExpect :: Expectation a -> IO () + , signalVerify :: IO (Maybe String) , vpiInstance :: Maybe VPIInstance } + -- | Signal | IOInput { signalId :: ID s SIGNAL , signalCurVal :: IO a , signalPrint :: Maybe (a -> String) } - | Generator + | TBSignal { signalId :: ID s SIGNAL , signalCurVal :: IO a , signalPrint :: Maybe (a -> String) - , generator :: Gen a } instance (KnownDomain dom, AnyStage s) => Show (TBSignal s dom a) where show = case knownDomain @dom of SDomainConfiguration domainName _ _ _ _ _ -> \case - TBSignal{..} -> + SimSignal{..} -> "Signal \"" <> signalName <> "\" @" <> ssymbolToString domainName <> " " <> show signalId <> " " - <> show signalDeps + <> show dependencies IOInput{..} -> "Input " <> show signalId - Generator{..} -> - "Gen " <> show signalId + TBSignal{} -> + "TS" instance AnyStage s => Eq (TBSignal s dom a) where (==) = (==) `on` signalId @@ -76,48 +89,26 @@ instance AnyStage s => Ord (TBSignal s dom a) where compare = compare `on` signalId instance Functor (TBSignal 'USER dom) where - fmap f = \case - TBSignal{..} -> - TBSignal - { signalId = NoID - , signal = fmap f signal - , signalCurVal = f <$> signalCurVal - -- We cannot update the values of a mapped signal, which - -- makes sense, since a mapped signal cannot be simulated - -- externally. It is always defined as the result of - -- applying 'f' to the given source signal. - , signalUpdate = Nothing - -- we lose printing abilities at this point. This is fine, - -- since printing capabilities are recovered automatically - -- once the new signal requires printing capabilities again. - , signalPrint = Nothing - , .. - } - IOInput{..} -> - IOInput - { signalId = NoID - , signalCurVal = f <$> signalCurVal - , signalPrint = Nothing - , .. - } - Generator{..} -> - Generator - { signalId = NoID - , signalCurVal = f <$> signalCurVal - , signalPrint = Nothing - , generator = f <$> generator - } + fmap f s = + TBSignal + { signalId = NoID + , signalCurVal = f <$> signalCurVal s + -- we lose printing abilities at this point. This is fine, + -- since printing capabilities are recovered automatically + -- once the new signal requires printing capabilities again. + , signalPrint = Nothing + } instance Applicative (TBSignal 'USER dom) where pure x = - IOInput + TBSignal { signalId = NoID , signalCurVal = pure x , signalPrint = Nothing } f <*> s = - IOInput + TBSignal { signalId = NoID , signalCurVal = signalCurVal f <*> signalCurVal s , signalPrint = Nothing @@ -189,6 +180,11 @@ data SomeSignal (s :: Stage) where (KnownDomain dom, NFDataX a, BitPack a) => TBSignal s dom a -> SomeSignal s + SomeMonitor :: + forall s dom. + KnownDomain dom => + TBSignal s dom Bool -> + SomeSignal s instance AnyStage s => Eq (SomeSignal s) where (==) = (==) `on` (signalId `onAllSignalTypes`) @@ -209,3 +205,4 @@ onAllSignalTypes :: b onAllSignalTypes f = \case SomeSignal s -> f s + SomeMonitor s -> f s diff --git a/clash-testbench/src/Clash/Testbench/Simulate.hs b/clash-testbench/src/Clash/Testbench/Simulate.hs index 8d00bb82b7..65868ff1a6 100644 --- a/clash-testbench/src/Clash/Testbench/Simulate.hs +++ b/clash-testbench/src/Clash/Testbench/Simulate.hs @@ -68,9 +68,17 @@ simulate steps testbench = do Nothing -> return () Just toStr -> Prelude.putStrLn . (<> toStr v) $ case s of IOInput{} -> "I " - Generator{} -> "I " + SimSignal{} -> "O " TBSignal{} -> "O " + modifyIORef tbSimStepRef (+ 1) + + forM_ tbSignals $ onAllSignalTypes $ \case + SimSignal{..} -> signalVerify >>= \case + Nothing -> Prelude.putStrLn "✓" + Just msg -> Prelude.putStrLn $ "✗ " <> msg + _ -> return () + return r data VPIState = @@ -121,13 +129,13 @@ simulateFFI steps testbench = do -- match top modules with the signals -- vpiSignals <- - fmap ((<>) (filter (not . isTBSignal) tbSignals) . catMaybes) + fmap ((<>) (filter (not . isSimSignal) tbSignals) . catMaybes) $ mapM matchModule $ M.toAscList $ M.unionWith (\(x,_) (_,y) -> (x,y)) ( M.fromList $ map (\s -> (signalName `onAllSignalTypes` s, (Just s, Nothing))) - $ filter isTBSignal tbSignals + $ filter isSimSignal tbSignals ) ( M.fromList $ zip (map B.unpack topNames) @@ -158,8 +166,8 @@ simulateFFI steps testbench = do Just x -> x Nothing -> error $ show b - isTBSignal = \case - SomeSignal TBSignal{} -> True + isSimSignal = \case + SomeSignal SimSignal{} -> True _ -> False assignInputs :: (?state :: VPIState) => SimAction () @@ -168,7 +176,7 @@ assignInputs = do -- putStrLn $ "assignInputs " <> show (time, vpiClock, vpiInit) forM_ vpiSignals $ onAllSignalTypes $ \case - TBSignal{..} -> mapM_ (assignModuleInputs vpiInstance) signalDeps + SimSignal{..} -> mapM_ (assignModuleInputs vpiInstance) dependencies _ -> return () @@ -189,10 +197,11 @@ assignInputs = do Just VPIInstance{..} -> \sid@(SomeID x) -> let VPIPort{..} = vpiInputPort sid in case x of + NoID -> return () ClockID _TODO -> sendV port vpiClock ResetID _TODO -> sendV port $ boolToBit vpiInit EnableID _TODO -> sendV port high - _ + SignalID _TODO | vpiClock == high -> return () | otherwise -> (`onAllSignalTypes` vpiSignal sid) $ \s -> @@ -209,7 +218,7 @@ readOutputs = do -- putStrLn $ "readOutputs " <> show time forM_ vpiSignals $ onAllSignalTypes $ \case - TBSignal{..} -> case vpiInstance of + SimSignal{..} -> case vpiInstance of Nothing -> error "Cannot read from module" Just VPIInstance{..} -> receiveValue VectorFmt (port vpiOutputPort) >>= \case @@ -227,8 +236,8 @@ readOutputs = do Nothing -> return () Just toStr -> putStrLn . (<> toStr v) $ case s of IOInput{} -> "I " - Generator{} -> "I " - TBSignal{} -> "O " + SimSignal{} -> "O " + TBSignal{} -> "S " -- proceed time for all instances not running trough Clash-FFI liftIO $ modifyIORef vpiStepRef (+ 1) @@ -252,7 +261,8 @@ matchModule :: SimCont b (Maybe (SomeSignal 'FINAL)) matchModule = \case (_, (Just s, Just m)) -> case s of - SomeSignal s' -> Just . SomeSignal <$> vpiInst m s' + SomeSignal s' -> Just . SomeSignal <$> vpiInst m s' + SomeMonitor s' -> Just . SomeMonitor <$> vpiInst m s' (name, (_, Nothing)) -> error $ "No module matches \"" <> name <> "\"" (name, (Nothing, _)) -> do @@ -263,7 +273,7 @@ vpiInst :: (?signalFromID :: ID 'FINAL () -> SomeSignal 'FINAL, KnownDomain dom, BitPack a, Typeable b) => Module -> TBSignal 'FINAL dom a -> SimCont b (TBSignal 'FINAL dom a) vpiInst vpiModule = \case - tbs@TBSignal{..} -> do + tbs@SimSignal{..} -> do ports <- modulePorts vpiModule dirs <- mapM direction ports @@ -274,7 +284,7 @@ vpiInst vpiModule = \case vpiInputPort <- (M.!) . M.fromList <$> ( mapM (matchPort vpiModule) - $ zip signalDeps + $ zip dependencies $ map Just inputPorts <> repeat Nothing ) From 9548cae713bb3ec544f119dcbb5969133e113ba6 Mon Sep 17 00:00:00 2001 From: Felix Klein Date: Tue, 16 May 2023 16:23:24 +0200 Subject: [PATCH 5/9] backend cleanup & more documentation --- clash-testbench/clash-testbench.cabal | 2 - .../src/Clash/Testbench/Generate.hs | 185 +++-- clash-testbench/src/Clash/Testbench/Input.hs | 30 +- .../src/Clash/Testbench/Internal/Auto.hs | 43 - .../src/Clash/Testbench/Internal/ID.hs | 379 +++++---- .../src/Clash/Testbench/Internal/Monad.hs | 737 ++++++++++++------ .../src/Clash/Testbench/Internal/Signal.hs | 329 +++++--- clash-testbench/src/Clash/Testbench/Output.hs | 6 +- clash-testbench/src/Clash/Testbench/Signal.hs | 42 +- .../src/Clash/Testbench/Simulate.hs | 213 +++-- 10 files changed, 1189 insertions(+), 777 deletions(-) delete mode 100644 clash-testbench/src/Clash/Testbench/Internal/Auto.hs diff --git a/clash-testbench/clash-testbench.cabal b/clash-testbench/clash-testbench.cabal index 9b0bc445c8..b7ada3abd4 100644 --- a/clash-testbench/clash-testbench.cabal +++ b/clash-testbench/clash-testbench.cabal @@ -40,11 +40,9 @@ library Clash.Testbench.Output Clash.Testbench.Simulate Clash.Testbench.Generate - other-modules: Clash.Testbench.Internal.ID Clash.Testbench.Internal.Signal Clash.Testbench.Internal.Monad - Clash.Testbench.Internal.Auto build-depends: base, mtl, diff --git a/clash-testbench/src/Clash/Testbench/Generate.hs b/clash-testbench/src/Clash/Testbench/Generate.hs index c3a0143a86..755e4b62ee 100644 --- a/clash-testbench/src/Clash/Testbench/Generate.hs +++ b/clash-testbench/src/Clash/Testbench/Generate.hs @@ -1,8 +1,16 @@ +{-| +Copyright: (C) 2023 Google Inc. +License: BSD2 (see the file LICENSE) +Maintainer: QBayLogic B.V. + +Use generators to create signal data. +-} + module Clash.Testbench.Generate where import Hedgehog import Hedgehog.Gen -import Control.Monad.State.Lazy (liftIO, get) +import Control.Monad.State.Lazy (liftIO) import Data.IORef (newIORef, readIORef, writeIORef) import Clash.Prelude (KnownDomain(..), BitPack(..), NFDataX) @@ -12,92 +20,21 @@ import Clash.Testbench.Internal.ID import Clash.Testbench.Internal.Signal hiding (TBSignal, TBClock, TBReset, TBEnable) import Clash.Testbench.Internal.Monad -matchIOGen :: - (NFDataX i, BitPack i, KnownDomain dom, Eq o, Show o) => - TBSignal dom o -> Gen (i, o) -> TB (TBSignal dom i) -matchIOGen expectedOutput gen = do - ST{..} <- get - - vRef <- liftIO $ newIORef undefined - simStepCache <- liftIO (readIORef simStepRef >>= newIORef) - - mind SomeSignal $ IOInput - { signalId = NoID - , signalCurVal = do - v <- readIORef simStepRef - v' <- readIORef simStepCache - - if v == v' - then readIORef vRef - else do - (i, o) <- sample gen - signalExpect expectedOutput $ Expectation (v + 1, verify o) - - writeIORef vRef i - writeIORef simStepCache v - return i - , signalPrint = Nothing - } - where - verify x y - | x == y = Nothing - | otherwise = Just $ "Expected " <> show x <> " but the output is " <> show y - - -matchIOGenN :: - (NFDataX i, BitPack i, KnownDomain dom, Eq o, Show o) => - TBSignal dom o -> Gen [(i, o)] -> TB (TBSignal dom i) -matchIOGenN expectedOutput gen = do - ST{..} <- get - - vRef <- liftIO $ newIORef [] - simStepCache <- liftIO (readIORef simStepRef >>= newIORef) - - mind SomeSignal $ IOInput - { signalId = NoID - , signalCurVal = do - v <- readIORef simStepRef - v' <- readIORef simStepCache - - if v == v' - then readIORef vRef >>= \case - (i, _) : _ -> return i - [] -> do - (i, o) : xr <- sample gen - writeIORef vRef ((i, o) : xr) - return i - else do - writeIORef simStepCache v - readIORef vRef >>= \case - _ : (i, o) : xr -> do - writeIORef vRef ((i, o) : xr) - signalExpect expectedOutput $ Expectation (v, verify o) - return i - _ -> do - (i, o) : xr <- sample gen - writeIORef vRef ((i, o) : xr) - signalExpect expectedOutput $ Expectation (v, verify o) - return i - , signalPrint = Nothing - } - where - verify x y - | x == y = Nothing - | otherwise = Just $ "Expected '" <> show x <> "' but the output is '" <> show y <> "'" - - +-- | Use a generator to create new signal data at every simulation +-- step. generate :: + forall dom a. (NFDataX a, BitPack a, KnownDomain dom) => a -> Gen a -> TB (TBSignal dom a) generate def gen = do - ST{..} <- get + TBDomain{..} <- tbDomain @dom vRef <- liftIO $ newIORef def simStepCache <- liftIO (readIORef simStepRef >>= newIORef) mind SomeSignal IOInput { signalId = NoID - , signalCurVal = do + , signalCurVal = const $ do v <- readIORef simStepRef v' <- readIORef simStepCache @@ -111,18 +48,23 @@ generate def gen = do , 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 - ST{..} <- get + TBDomain{..} <- tbDomain @dom vRef <- liftIO $ newIORef [def] simStepCache <- liftIO (readIORef simStepRef >>= newIORef) - mindSignal IOInput + mind SomeSignal IOInput { signalId = NoID - , signalCurVal = do + , signalCurVal = const $ do v <- readIORef simStepRef v' <- readIORef simStepCache @@ -147,3 +89,86 @@ generateN def gen = do , 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 expectedOutput gen = do + TBDomain{..} <- tbDomain @dom + + vRef <- liftIO $ newIORef undefined + simStepCache <- liftIO (readIORef simStepRef >>= newIORef) + + mind SomeSignal $ IOInput + { signalId = NoID + , signalCurVal = const $ do + global <- readIORef simStepRef + local <- readIORef simStepCache + + if local == global + then readIORef vRef + else do + (i, o) <- sample gen + signalExpect expectedOutput $ Expectation (global + 1, verify o) + + writeIORef vRef i + writeIORef simStepCache global + return i + , signalPrint = Nothing + } + where + verify x y + | x == y = Nothing + | otherwise = Just $ "Expected " <> show x <> " but the output is " <> show y + +-- | Extended version of 'matchIOGen', which allows to specify valid +-- IO behavior over a finite amount of simulation steps. The generator +-- is repeatedly called after all steps of a generation have been +-- verified. +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 expectedOutput gen = do + TBDomain{..} <- tbDomain @dom + + vRef <- liftIO $ newIORef [] + simStepCache <- liftIO (readIORef simStepRef >>= newIORef) + + mind SomeSignal $ IOInput + { signalId = NoID + , signalCurVal = const $ do + global <- readIORef simStepRef + local <- readIORef simStepCache + + if local == global + then readIORef vRef >>= \case + (i, _) : _ -> return i + [] -> do + (i, o) : xr <- sample gen + writeIORef vRef ((i, o) : xr) + Prelude.print $ (i, o) : xr + return i + else do + writeIORef simStepCache global + readIORef vRef >>= \case + _ : (i, o) : xr -> do + writeIORef vRef ((i, o) : xr) + signalExpect expectedOutput $ Expectation (global + 1, verify o) + return i + _ -> do + (i, o) : xr <- sample gen + Prelude.print $ (i, o) : xr + writeIORef vRef ((i, o) : xr) + signalExpect expectedOutput $ Expectation (global + 1, verify o) + return i + , signalPrint = Nothing + } + where + verify x y + | x == y = Nothing + | otherwise = Just $ "Expected '" <> show x <> "' but the output is '" <> show y <> "'" diff --git a/clash-testbench/src/Clash/Testbench/Input.hs b/clash-testbench/src/Clash/Testbench/Input.hs index 90acd740ad..5e970b2cbb 100644 --- a/clash-testbench/src/Clash/Testbench/Input.hs +++ b/clash-testbench/src/Clash/Testbench/Input.hs @@ -3,7 +3,8 @@ Copyright: (C) 2023 Google Inc. License: BSD2 (see the file LICENSE) Maintainer: QBayLogic B.V. -Input sources for simulating 'TB' defined testbenches. +Input sources for simulating 'Clash.Testbench.Simulate.TB' defined +test benches. -} module Clash.Testbench.Input ( fromList @@ -21,31 +22,32 @@ import Clash.Testbench.Internal.Signal hiding (TBSignal) import Clash.Testbench.Internal.Monad import Clash.Testbench.Internal.ID --- | Generates input that is 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 instead. -fromList - :: (KnownDomain dom, BitPack a, NFDataX a) => a -> [a] -> TB (TBSignal dom a) +-- | 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, Show a) => + a -> [a] -> TB (TBSignal dom a) fromList x xs = do - ST{..} <- get + TBDomain{..} <- tbDomain @dom listRef <- liftIO $ newIORef $ x : xs simStepCache <- liftIO (readIORef simStepRef >>= newIORef) - mindSignal $ IOInput + mind SomeSignal $ IOInput { signalId = NoID , signalPrint = Nothing - , signalCurVal = do + , signalCurVal = const $ do (r, rs) <- fromMaybe (x, []) . uncons <$> readIORef listRef - v <- readIORef simStepRef - v' <- readIORef simStepCache + global <- readIORef simStepRef + local <- readIORef simStepCache - if v == v' + if local == global then return r else do writeIORef listRef rs - writeIORef simStepCache v + writeIORef simStepCache global return $ case rs of [] -> x y:_ -> y diff --git a/clash-testbench/src/Clash/Testbench/Internal/Auto.hs b/clash-testbench/src/Clash/Testbench/Internal/Auto.hs deleted file mode 100644 index 2c5589a6af..0000000000 --- a/clash-testbench/src/Clash/Testbench/Internal/Auto.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Clash.Testbench.Internal.Auto where - -import Clash.Testbench.Signal -import Clash.Testbench.Internal.ID -import Clash.Testbench.Internal.Signal hiding (TBClock, TBReset, TBEnable) -import qualified Clash.Testbench.Internal.Signal as Internal - -import Clash.Prelude - ( KnownDomain(..), SDomainConfiguration(..) - , clockGen, resetGen, enableGen, ssymbolToString - ) - --- | 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 = case knownDomain @dom of - SDomainConfiguration domainName _ _ _ _ _ -> - Internal.TBClock - { clock = clockGen - , clockId = ClockID $ AutoDom $ ssymbolToString domainName - , clockSource = return clockGen - } - -instance KnownDomain dom => AutoTB (TBReset dom) where - auto = case knownDomain @dom of - SDomainConfiguration domainName _ _ _ _ _ -> - Internal.TBReset - { reset = resetGen - , resetId = ResetID $ AutoDom $ ssymbolToString domainName - , resetCurVal = return False - } - -instance KnownDomain dom => AutoTB (TBEnable dom) where - auto = case knownDomain @dom of - SDomainConfiguration domainName _ _ _ _ _ -> - Internal.TBEnable - { enable = enableGen - , enableId = EnableID $ AutoDom $ ssymbolToString domainName - , enableCurVal = return True - } diff --git a/clash-testbench/src/Clash/Testbench/Internal/ID.hs b/clash-testbench/src/Clash/Testbench/Internal/ID.hs index d835a38a9d..261000ff3c 100644 --- a/clash-testbench/src/Clash/Testbench/Internal/ID.hs +++ b/clash-testbench/src/Clash/Testbench/Internal/ID.hs @@ -1,217 +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 - ( Source(..) - , Stage(..) - , AnyStage - , SIGNAL - , CLOCK - , RESET - , ENABLE + ( SIGNAL + , DOMAIN , IDT - , IDSource , ID(..) + , MID(..) , idToInt - , isSignalID - , isClockID - , isResetID - , isEnableID - , isNoID ) where -import Clash.Prelude (Type) +import GHC.Arr (Ix(..)) --- | Source of identification -data Source = - AutoDom String - -- ^ Implicit source determined through the domain - -- (given in reified form here) - | UserDef Int - -- ^ User defined source that has some modeled given by the user - deriving (Eq, Ord) - -instance Show Source where - show = \case - AutoDom str -> '@' : str - UserDef i -> show i - -data Stage :: Type where - -- | The test bench is created in the USER stage. The elements of - -- the test bench are setup by the user inside the TB monad during - -- this stage. - USER :: 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. - FINAL :: Stage - --- | ID reference for the standard Clash 'Signal' type. +-- | ID reference for the standard Clash 'Clash.Signal.Signal' type. data SIGNAL --- | ID reference for the special Clash 'Clock' type. -data CLOCK --- | ID reference for the special Clash 'Reset' type. -data RESET --- | ID reference for the special Clash 'Enable' type. -data ENABLE +-- | 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 CLOCK = CLOCK - IDT RESET = RESET - IDT ENABLE = ENABLE + IDT DOMAIN = DOMAIN IDT a = SIGNAL --- | Closed type family, which determines the underlying ID type for --- each of the different stages. -type family IDSource (s :: Stage) a where - -- at the final stage all ids must be of type Int - IDSource 'FINAL a = Int - -- clocks, resets and enable signals may have been introduced on the - -- fly and still need to get some unique id during post-processing. - IDSource 'USER CLOCK = Source - IDSource 'USER RESET = Source - IDSource 'USER ENABLE = Source - -- everything has a known id already - IDSource s a = Int - -- | The ID data constructors for holding the different ID types. -data ID (stage :: Stage) a where - -- the pool of free IDs is only available a the USER stage and gets - -- closed at later stages - FreeID :: IDSource 'USER Int -> ID 'USER Int +data ID a where + -- the pool of free IDs + FreeID :: Int -> ID Int -- the different ID types - SignalID :: IDSource stage SIGNAL -> ID stage SIGNAL - ClockID :: IDSource stage CLOCK -> ID stage CLOCK - ResetID :: IDSource stage RESET -> ID stage RESET - EnableID :: IDSource stage ENABLE -> ID stage ENABLE - -- signals that result from higher order applications may not be - -- explicitly available - NoID :: ID stage SIGNAL + 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 cannot be passed around this way. - SomeID :: (a ~ IDT a) => ID stage a -> ID stage () - --- | This class collects some operations that are available during all --- stages. It is mostly used to defined the remaining type class --- instances of 'ID'. -class AnyStage (s :: Stage) where - mapID :: (Either Int Source -> b) -> ID s a -> b - -instance AnyStage 'USER where - mapID f = \case - FreeID x -> f $ Left x - SignalID x -> f $ Left x - ClockID x -> f $ Right x - ResetID x -> f $ Right x - EnableID x -> f $ Right x - NoID -> f $ Left (-1) - SomeID s -> mapID f s - -instance AnyStage 'FINAL where - mapID f = \case - SignalID x -> f $ Left x - ClockID x -> f $ Left x - ResetID x -> f $ Left x - EnableID x -> f $ Left x - NoID -> f $ Left (-1) - SomeID s -> mapID f s - -instance Num (ID 'USER Int) where + -- 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 AnyStage s => Eq (ID s a) where - x == y = mapID (mapID (==) x) y - -instance AnyStage s => Ord (ID s a) where - compare x = mapID (mapID compare x) - -instance Show (ID s Int) where - show (FreeID x) = show x - -instance Show (ID s SIGNAL) where + 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 -> "-" - -instance AnyStage s => Show (ID s CLOCK) where - show x = 'c' : mapID showEither x - -instance AnyStage s => Show (ID s RESET) where - show x = 'r' : mapID showEither x - -instance AnyStage s => Show (ID s ENABLE) where - show x = 'e' : mapID showEither x - -instance AnyStage s => Show (ID s ()) where - show (SomeID x) = case x of - SignalID{} -> show x - ClockID{} -> show x - ResetID{} -> show x - EnableID{} -> show x - NoID{} -> show x - -showEither :: (Show a, Show b) => Either a b -> String -showEither = \case - Left x -> show x - Right x -> show x - --- | At the final stage all IDs are of type Int. -idToInt :: ID 'FINAL a -> Int -idToInt = \case - SignalID x -> x - ClockID x -> x - ResetID x -> x - EnableID x -> x - NoID -> -1 - SomeID s -> idToInt s - --- | Checks whether the given ID is a signal identifier. -isSignalID :: ID s a -> Bool -isSignalID = \case - SignalID{} -> True - NoID{} -> True - SomeID s -> case s of - SignalID{} -> True - NoID{} -> True - _ -> False - _ -> False - -isNoID :: ID s a -> Bool -isNoID = \case - NoID{} -> True - SomeID s -> case s of - NoID{} -> True - _ -> False - _ -> False - --- | Checks whether the given ID is a clock identifier. -isClockID :: ID s a -> Bool -isClockID = \case - ClockID{} -> True - SomeID s -> case s of - ClockID{} -> True - _ -> False - _ -> False - --- | Checks whether the given ID is a reset identifier. -isResetID :: ID s a -> Bool -isResetID = \case - ResetID{} -> True - SomeID s -> case s of - ResetID{} -> True - _ -> False - _ -> False - --- | Checks whether the given ID is an enable identifier. -isEnableID :: ID s a -> Bool -isEnableID = \case - ResetID{} -> True - SomeID s -> case s of - ResetID{} -> True - _ -> False - _ -> False + 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 index 7a9760092e..5137614ec9 100644 --- a/clash-testbench/src/Clash/Testbench/Internal/Monad.hs +++ b/clash-testbench/src/Clash/Testbench/Internal/Monad.hs @@ -1,151 +1,173 @@ -module Clash.Testbench.Internal.Monad where - +{-| +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 #-} +module Clash.Testbench.Internal.Monad + ( KnownSignals + , KnownDomains + , Testbench(..) + , TB + , ST + , LiftAcc(..) + , ArgOf + , LiftTB(..) + , runTB + , tbDomain + , mind + ) where + +import Data.Bifunctor (bimap) +import Data.Function (on) +import Data.Type.Equality import Algebra.PartialOrd -import Control.Arrow (second) -import Control.Monad.State.Lazy (StateT, liftIO, get, gets, modify, forM, evalStateT) +import Control.Monad.State.Lazy (StateT, liftIO, get, gets, modify, evalStateT, forM_, void) import Data.Function ((&)) import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) -import Data.List (uncons, partition) -import Data.Maybe (catMaybes) +import Data.List (uncons, partition, sort, sortBy, groupBy) +import Data.Maybe (catMaybes, mapMaybe) + import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Array as A -import Clash.Signal.Internal (Signal(..), head#, tail#) import Clash.Prelude - ( KnownDomain(..), BitPack(..), NFDataX, Enable, Clock, Reset - , toEnable, unsafeToReset + ( 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 --- | Simulation mode -data Simulator = - Internal - -- ^ Internal pure Haskell based simulation - | External - -- ^ Co-Simulation using an external simulator - -data DomainSpecificIDSource = - DSClock { domainFromDS :: Int } - | DSReset { domainFromDS :: Int } - | DSEnable { domainFromDS :: Int } - -instance Eq DomainSpecificIDSource where - DSClock{} == DSClock{} = True - DSReset{} == DSReset{} = True - DSEnable{} == DSEnable{} = True - _ == _ = False - -instance Ord DomainSpecificIDSource where - compare DSClock{} DSClock{} = EQ - compare DSClock{} _ = GT - compare _ DSClock{} = LT - compare DSReset{} DSReset{} = EQ - compare DSEnable{} DSEnable{} = EQ - compare DSEnable{} _ = LT - compare _ DSEnable{} = GT - +-- | 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 - { idCount :: ID 'USER Int + { idSigCount :: ID Int + -- ^ Counter for generating free IDs to be assigned to signal + -- (functions) , signals :: KnownSignals 'USER - , monitors :: KnownSignals 'USER - , simStepRef :: IORef Int - , simMode :: IORef Simulator - , domIds :: M.Map String (S.Set DomainSpecificIDSource) - } - -data Testbench = - Testbench - { tbSignals :: [SomeSignal 'FINAL] - , tbLookupID :: ID 'FINAL () -> SomeSignal 'FINAL - , tbSimStepRef :: IORef Int - , tbSimMode :: IORef Simulator + -- ^ Captured signal (functions) + , idDomCount :: ID Int + -- ^ Counter for generating free IDs to be assigned to domains + , domains :: KnownDomains 'USER + -- ^ Captured domains } instance Show ST where show ST{..} = "ST {" - <> show idCount <> ", " - <> show (S.toAscList signals) + <> 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) + } +instance Show Testbench where + show Testbench{..} = + "Testbench {" + <> show tbSignals <> ", " + <> show tbDomains <> "}" + -- | The 'TB' monad defines the context in which the test bench gets --- be created by the user. To this end, the user can lift any Clash --- 'Clash.Signal.Signal' or signal function into 'TB' using the '@@' --- operator. The lifted signal / signal function then can be applied --- to 'IO' driven inputs or the outputs can be post-processed inside --- 'IO'. +-- 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. However, the test bench is --- not executed inside 'TB'. +-- to describe the test bench structure. The test bench is not +-- executed inside 'TB'. type TB a = StateT ST IO a -nextFreeID :: TB (ID 'USER Int) -nextFreeID = do - i <- gets idCount - modify $ \st -> st { idCount = i + 1 } - return i - -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 - FreeID i <- nextFreeID - let s' = s { signalId = 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 - -mindSignal :: - (KnownDomain dom, NFDataX a, BitPack a) => - TBSignal dom a -> - TB (TBSignal dom a) -mindSignal = mind SomeSignal - -monitor :: - KnownDomain dom => - TBSignal dom Bool -> - TB (TBSignal dom Bool) -monitor = mind SomeMonitor - +-- | 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) + , signalRef :: 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 / 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. + -- 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 - liftTB :: String -> [ID 'USER ()] - -> IO (IORef b, IO (ArgOf a, (ArgOf a -> ArgOf a) -> b -> b)) -> a - - -defTBLift :: (LiftTB a, a ~ (ArgOf a -> b)) => String -> ArgOf a -> b -defTBLift name x = - liftTB name [] ((\r -> (r, (,($)) <$> readIORef r)) <$> newIORef x) x + -- | Internal lift for traversing the arguments and the result of + -- the given signal function. + liftTB :: TB (LiftAcc (ArgOf a) b) -> a instance ( KnownDomain domA, KnownDomain domB @@ -153,44 +175,42 @@ instance , NFDataX a, BitPack a ) => LiftTB (Signal domA a -> TB (TBSignal domB a')) where - (@@) = defTBLift + (@@) = initializeLiftTB - liftTB signalName (reverse -> dependencies) exec origin = do - mode <- simMode <$> get + liftTB exec origin = do extVal <- liftIO $ newIORef Nothing expectations <- liftIO $ newIORef [] - ST{..} <- get - (signalRef, run) <- liftIO exec + LiftAcc{..} <- exec + TBDomain{..} <- tbDomain @domA simStepCache <- liftIO (readIORef simStepRef >>= newIORef) let - signalCurVal = do - readIORef mode >>= \case - Internal -> do - (head# -> x, step) <- run - local <- readIORef simStepRef - world <- readIORef simStepCache - -- THOUGHT: one could also use an individual simulation - -- counter per domain allowing for multiple steps to be - -- simulated at once, if necessary. - if local == world - then return x - else do - modifyIORef signalRef $ step tail# - writeIORef simStepCache world - return x - External -> readIORef extVal >>= \case - Nothing -> error "No Value" - Just x -> return x + signalCurVal = \case + Internal -> do + (head# -> x, step) <- cont + global <- readIORef simStepRef + local <- readIORef simStepCache + + if local == global + then return x + else do + modifyIORef signalRef $ step tail# + writeIORef simStepCache global + return x + External -> readIORef extVal >>= \case + Nothing -> error "No Value @Signal" + Just x -> return x mind SomeSignal $ Internal.SimSignal { signalId = NoID + , dependencies = reverse deps + , signalName = name , signalUpdate = Just (writeIORef extVal . Just) , signalExpect = modifyIORef expectations . (:) - , signalVerify = do + , signalVerify = \m -> do step <- readIORef simStepRef - value <- signalCurVal + value <- signalCurVal m expct <- readIORef expectations let @@ -199,8 +219,10 @@ instance writeIORef expectations later - return$ fmap fst $ uncons $ catMaybes - $ map ((value &) . snd . expectation) cur + return + $ fmap fst + $ uncons + $ mapMaybe ((value &) . snd . expectation) cur , signalPrint = Nothing , vpiInstance = Nothing @@ -212,134 +234,387 @@ instance , arg ~ TBSignal dom a ) => LiftTB ((Signal dom a -> b) -> arg -> c) where - (@@) = defTBLift - - liftTB name deps exec sf s = - flip (liftTB name (SomeID (signalId s) : deps)) (sf $ origin s) - $ (<$> exec) $ second $ (=<<) $ \(sf', cont) -> do - v <- signalCurVal s - return (sf' $ pure v, cont . (\f sf'' -> f . sf'' . (v :-))) + (@@) = initializeLiftTB + + liftTB a sf s = liftTB (upd <$> a) $ sf $ origin 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 - (@@) = defTBLift - - liftTB name deps exec sf c = - flip (liftTB name (SomeID (clockId c) : deps)) (sf $ clock c) - $ (<$> exec) $ second $ (=<<) $ \(sf', cont) -> - return (sf' $ clock c, cont . (.)) + (@@) = 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 - (@@) = defTBLift - - liftTB name deps exec sf r = - flip (liftTB name (SomeID (resetId r) : deps)) (sf $ reset r) - $ (<$> exec) $ second $ (=<<) $ \(sf', cont) -> do - v <- resetCurVal r - return (sf' $ unsafeToReset $ pure v, cont . (.)) + (@@) = 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 + simStepCache <- liftIO (readIORef simStepRef >>= newIORef) + + let + resetCurVal = \case + Internal -> do + s@(_ :- s') <- readIORef signalRef + global <- readIORef simStepRef + local <- readIORef simStepCache + + if local == global + then return $ head# s + else do + writeIORef signalRef s' + writeIORef simStepCache global + return $ head# s' + 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 - (@@) = defTBLift - - liftTB name deps exec sf e = - flip (liftTB name (SomeID (enableId e) : deps)) (sf $ enable e) - $ (<$> exec) $ second $ (=<<) $ \(sf', cont) -> do - v <- enableCurVal e - return (sf' $ toEnable $ pure v, cont . (.)) - -runTB :: Simulator -> TB a -> IO (a, Testbench) -runTB mode testbench = do - simStepRef <- newIORef 0 - simMode <- newIORef mode + (@@) = 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) + simStepCache <- liftIO (readIORef simStepRef >>= newIORef) + + let + enableCurVal = \case + Internal -> do + s@(_ :- s') <- readIORef signalRef + global <- readIORef simStepRef + local <- readIORef simStepCache + + if local == global + then return $ head# s + else do + writeIORef signalRef s' + writeIORef simStepCache global + return $ head# s' + 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 + signalRef <- liftIO $ newIORef x + return LiftAcc + { deps = [] + , cont = (,($)) <$> readIORef signalRef + , .. + } + +-- | 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 - { idCount = 0 - , signals = S.empty - , monitors = S.empty - , domIds = M.empty - , .. + { idSigCount = 1 + , signals = S.empty + , idDomCount = 0 + , domains = M.empty } where finalize r = do - ST { signals, simStepRef, simMode } <- get - tbSignals <- forM (S.toAscList signals) $ \case - SomeSignal s -> SomeSignal <$> finalizeSignal s - SomeMonitor s -> SomeMonitor <$> finalizeSignal s - - FreeID n <- gets idCount - let a :: A.Array Int (SomeSignal 'FINAL) - a = A.array (0, n-1) - $ map (\s -> ((idToInt . signalId) `onAllSignalTypes` s, s)) - tbSignals - - return - ( r - , Testbench - { tbSimStepRef = simStepRef - , tbSimMode = simMode - , tbLookupID = (a A.!) . idToInt - , .. - } - ) + -- 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, .. } <- 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 -> - TB (Internal.TBSignal 'FINAL dom a) - - finalizeSignal = \case - SimSignal{..} -> do - deps <- mapM fixAutoDomIds dependencies - return $ SimSignal - { signalId = case signalId of - NoID -> NoID - SignalID x -> SignalID x - , dependencies = deps + SomeSignal 'FINAL + finalizeSignal = SomeSignal . \case + SimSignal{..} -> + SimSignal + { signalCurVal = signalCurVal mode + , signalVerify = signalVerify mode , .. } IOInput{..} -> - return $ IOInput - { signalId = case signalId of - NoID -> NoID - SignalID x -> SignalID x + IOInput + { signalCurVal = signalCurVal mode , .. } - Internal.TBSignal{..} -> - return $ Internal.TBSignal - { signalId = case signalId of - NoID -> NoID - SignalID x -> SignalID x + TBSignal{..} -> + TBSignal + { signalCurVal = signalCurVal mode , .. } - fixAutoDomIds :: ID 'USER () -> TB (ID 'FINAL ()) - fixAutoDomIds (SomeID s) = case s of - NoID -> return $ SomeID $ NoID - SignalID x -> return $ SomeID $ SignalID x - ClockID x -> updAutoDom DSClock (SomeID . ClockID) x - ResetID x -> updAutoDom DSReset (SomeID . ResetID) x - EnableID x -> updAutoDom DSEnable (SomeID . EnableID) x - - updAutoDom ds c = \case - UserDef x -> return $ c x - AutoDom str -> do - sm <- gets domIds - case M.lookup str sm of - Just s -> case S.lookupIndex (ds 0) s of - Just i -> return $ c $ domainFromDS $ S.elemAt i s - Nothing -> nextAutoDomId ds c str sm (`S.insert` s) - Nothing -> nextAutoDomId ds c str sm S.singleton - - nextAutoDomId ds c str sm upd = do - FreeID x <- nextFreeID - modify $ \st -> st { domIds = M.insert str (upd $ ds x) sm } - return $ c x + 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 index e8a476d57c..88884e8b26 100644 --- a/clash-testbench/src/Clash/Testbench/Internal/Signal.hs +++ b/clash-testbench/src/Clash/Testbench/Internal/Signal.hs @@ -1,10 +1,19 @@ +{-| +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 Data.Function (on) +import Data.IORef (IORef) import Clash.Prelude - ( KnownDomain(..), BitPack(..), SDomainConfiguration(..), NFDataX + ( KnownDomain(..), BitPack(..), SDomainConfiguration(..), NFDataX, Type , Domain, Signal, Clock, Reset, Enable , ssymbolToString ) @@ -13,6 +22,35 @@ 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. + +-- | The supported simulation modes sources. +data SimMode where + Internal :: SimMode + -- ^ Internal pure Haskell based simulation + External :: SimMode + -- ^ 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 VPIPort = VPIPort { port :: Port @@ -22,53 +60,58 @@ data VPIPort = , portDirection :: Direction } +-- | Clash-FFI Module connector. data VPIInstance = VPIInstance { vpiModule :: Module - , vpiInputPort :: ID 'FINAL () -> VPIPort + , vpiInputPort :: ID () -> VPIPort -- TODO: multiple port support vie Bundle/Unbundle , vpiOutputPort :: VPIPort } +-- | Expectations on certain outputs at the given simulation step. newtype Expectation a = Expectation { expectation :: (Int, a -> Maybe String) } --- | Expectations cannot be compared, hence they are always unequal +-- | Expectations cannot be compared: they are always unequal. instance Eq (Expectation a) where _ == _ = False --- | Expectations enjoy some partial order via the simulation step at +-- | 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 lifted 'Clash.Signal.Signal' type to be used in +-- 'Clash.Testbench.Internal.Monad.TB'. data TBSignal (s :: Stage) (dom :: Domain) a = - -- | Signal that can be simulated + -- | A signal that can be simulated. SimSignal - { signalId :: ID s SIGNAL - , signalCurVal :: IO a + { signalId :: ID SIGNAL + , signalCurVal :: SimModeDependent s (IO a) , signalPrint :: Maybe (a -> String) , origin :: Signal dom a - , dependencies :: [ID s ()] + , dependencies :: [ID ()] , signalName :: String , signalUpdate :: Maybe (a -> IO ()) , signalExpect :: Expectation a -> IO () - , signalVerify :: IO (Maybe String) + , signalVerify :: SimModeDependent s (IO (Maybe String)) , vpiInstance :: Maybe VPIInstance } - -- | Signal + -- | A signal that receives its content from IO. | IOInput - { signalId :: ID s SIGNAL - , signalCurVal :: IO a + { signalId :: ID SIGNAL + , signalCurVal :: SimModeDependent s (IO a) , signalPrint :: Maybe (a -> String) } + -- | A signal that results from composition. | TBSignal - { signalId :: ID s SIGNAL - , signalCurVal :: IO a + { signalId :: ID SIGNAL + , signalCurVal :: SimModeDependent s (IO a) , signalPrint :: Maybe (a -> String) } -instance (KnownDomain dom, AnyStage s) => Show (TBSignal s dom a) where +instance KnownDomain dom => Show (TBSignal s dom a) where show = case knownDomain @dom of SDomainConfiguration domainName _ _ _ _ _ -> \case SimSignal{..} -> @@ -82,20 +125,21 @@ instance (KnownDomain dom, AnyStage s) => Show (TBSignal s dom a) where TBSignal{} -> "TS" -instance AnyStage s => Eq (TBSignal s dom a) where +instance Eq (TBSignal s dom a) where (==) = (==) `on` signalId -instance AnyStage s => Ord (TBSignal s dom a) where +instance Ord (TBSignal s dom a) where compare = compare `on` signalId instance Functor (TBSignal 'USER dom) where fmap f s = TBSignal { signalId = NoID - , signalCurVal = f <$> signalCurVal s + , signalCurVal = fmap f . signalCurVal s -- we lose printing abilities at this point. This is fine, -- since printing capabilities are recovered automatically - -- once the new signal requires printing capabilities again. + -- once the mapped signal requires printing capabilities + -- again. , signalPrint = Nothing } @@ -103,98 +147,170 @@ instance Applicative (TBSignal 'USER dom) where pure x = TBSignal { signalId = NoID - , signalCurVal = pure x + , signalCurVal = const $ pure x , signalPrint = Nothing } f <*> s = TBSignal { signalId = NoID - , signalCurVal = signalCurVal f <*> signalCurVal s + , signalCurVal = \m -> signalCurVal f m <*> signalCurVal s m , signalPrint = Nothing } -data TBClock (s :: Stage) (dom :: Domain) = - TBClock - { clock :: Clock dom - , clockId :: ID s CLOCK - , clockSource :: IO (Clock dom) - } - -instance (KnownDomain dom, AnyStage s) => Show (TBClock s dom) where - show TBClock{..} = case knownDomain @dom of +-- | 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 <> " " - <> show clockId - -instance AnyStage s => Eq (TBClock s dom) where - (==) = (==) `on` clockId - -instance AnyStage s => Ord (TBClock s dom) where - compare = compare `on` clockId - -data TBReset (s :: Stage) (dom :: Domain) = - TBReset - { reset :: Reset dom - , resetId :: ID s RESET - , resetCurVal :: IO Bool - } - -instance (KnownDomain dom, AnyStage s)=> Show (TBReset s dom) where - show TBReset{..} = case knownDomain @dom of + "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 <> " " - <> show resetId - -instance AnyStage s => Eq (TBReset s dom) where - (==) = (==) `on` resetId - -instance AnyStage s => Ord (TBReset s dom) where - compare = compare `on` resetId - -data TBEnable (s :: Stage) (dom :: Domain) = - TBEnable - { enable :: Enable dom - , enableId :: ID s ENABLE - , enableCurVal :: IO Bool - } - -instance (KnownDomain dom, AnyStage s) => Show (TBEnable s dom) where - show TBEnable{..} = case knownDomain @dom of + "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 <> " " - <> show enableId - -instance AnyStage s => Eq (TBEnable s dom) where - (==) = (==) `on` enableId - -instance AnyStage s => Ord (TBEnable s dom) where - compare = compare `on` enableId - + "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 - SomeMonitor :: - forall s dom. - KnownDomain dom => - TBSignal s dom Bool -> - SomeSignal s -instance AnyStage s => Eq (SomeSignal s) where +instance Eq (SomeSignal s) where (==) = (==) `on` (signalId `onAllSignalTypes`) -instance AnyStage s => Ord (SomeSignal s) where +instance Ord (SomeSignal s) where compare = compare `on` (signalId `onAllSignalTypes`) -instance AnyStage s => Show (SomeSignal s) where +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. @@ -205,4 +321,43 @@ onAllSignalTypes :: b onAllSignalTypes f = \case SomeSignal s -> f s - SomeMonitor 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 index 5b876413e3..a42a02720b 100644 --- a/clash-testbench/src/Clash/Testbench/Output.hs +++ b/clash-testbench/src/Clash/Testbench/Output.hs @@ -4,7 +4,7 @@ License: BSD2 (see the file LICENSE) Maintainer: QBayLogic B.V. Output processors for post-processing output that results from -simulating 'TB' defined testbenches. +simulating 'Clash.Testbench.Simulate.TB' defined test benches. -} module Clash.Testbench.Output ( watch @@ -27,9 +27,9 @@ watch :: watch = watchWith show -- | Output the values of the given signal to @stdout@ during --- simulation using the provided 'String'-converter for @a@. +-- 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 $ mindSignal tbs { signalPrint = Just toStr } + 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 index 9968094a33..550a09b0c2 100644 --- a/clash-testbench/src/Clash/Testbench/Signal.hs +++ b/clash-testbench/src/Clash/Testbench/Signal.hs @@ -3,27 +3,47 @@ Copyright: (C) 2023 Google Inc. License: BSD2 (see the file LICENSE) Maintainer: QBayLogic B.V. -'Clash.Testbench.Simulate.TB' lifted signals. +'Clash.Testbench.Simulate.TB' lifted signals (internal). -} - module Clash.Testbench.Signal ( TBSignal , TBClock , TBReset , TBEnable + , AutoTB(..) ) where -import Clash.Testbench.Internal.ID (Stage(..)) +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 'USER dom +-- | 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 --- | A 'Clash.Signal.Clock' signal that has been lifted into the 'Clash.Testbench.Simulate.TB' context. -type TBClock dom = Internal.TBClock 'USER dom +instance KnownDomain dom => AutoTB (TBClock dom) where + auto = Internal.AutoClock --- | A 'Clash.Signal.Reset' signal that has been lifted into the 'Clash.Testbench.Simulate.TB' context. -type TBReset dom = Internal.TBReset 'USER dom +instance KnownDomain dom => AutoTB (TBReset dom) where + auto = Internal.AutoReset --- | An 'Clash.Signal.Enable' signal that has been lifted into the 'Clash.Testbench.Simulate.TB' context. -type TBEnable dom = Internal.TBEnable 'USER dom +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 index 65868ff1a6..c3feca719a 100644 --- a/clash-testbench/src/Clash/Testbench/Simulate.hs +++ b/clash-testbench/src/Clash/Testbench/Simulate.hs @@ -9,7 +9,6 @@ from Clash circuitry. module Clash.Testbench.Simulate ( TB , LiftTB((@@)) - , AutoTB(..) , simulate , simulateFFI ) where @@ -21,10 +20,10 @@ import Control.Monad.IO.Class import Control.Monad.State.Lazy hiding (lift) import Data.Proxy +import Data.Array ((!)) import Data.Coerce (Coercible) import Data.IORef import Data.Bits (complement) -import Data.Maybe (catMaybes) import Data.Typeable (Typeable) import Foreign.C.String (newCString) import Foreign.Marshal.Alloc (free) @@ -32,6 +31,7 @@ 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 @@ -50,10 +50,9 @@ import Clash.FFI.VPI.Port import Clash.Testbench.Internal.ID import Clash.Testbench.Internal.Signal import Clash.Testbench.Internal.Monad -import Clash.Testbench.Internal.Auto -- | @simulate n testbench@ simulates the @testbench@, created in the --- 'TB' context, for @n@ simulation steps. +-- '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'. @@ -61,31 +60,33 @@ simulate :: Int -> TB a -> IO a simulate steps testbench = do (r, Testbench{..}) <- runTB Internal testbench replicateM_ (steps + 1) $ do - forM_ tbSignals $ onAllSignalTypes $ \s -> do - v <- signalCurVal s - i <- readIORef tbSimStepRef - when (i > 0) $ case signalPrint s of - Nothing -> return () - Just toStr -> Prelude.putStrLn . (<> toStr v) $ case s of - IOInput{} -> "I " - SimSignal{} -> "O " - TBSignal{} -> "O " - - modifyIORef tbSimStepRef (+ 1) + forM_ tbDomains $ \(d, map (tbSignalLookup !) -> xs) -> + (`onAllDomainTypes` d) $ \(TBDomain{..} :: TBDomain 'FINAL dom) -> do + i <- readIORef simStepRef + when (i > 0) $ forM_ xs $ onAllSignalTypes $ \s -> do + v <- signalCurVal s + case signalPrint s of + Nothing -> return () + Just toStr -> Prelude.putStrLn . (<> toStr v) $ case s of + IOInput{} -> "I " + SimSignal{} -> "O " + TBSignal{} -> "S " + modifyIORef simStepRef (+ 1) forM_ tbSignals $ onAllSignalTypes $ \case - SimSignal{..} -> signalVerify >>= \case - Nothing -> Prelude.putStrLn "✓" - Just msg -> Prelude.putStrLn $ "✗ " <> msg + SimSignal{..} -> do + signalVerify >>= \case + Nothing -> Prelude.putStrLn "✓" + Just msg -> Prelude.putStrLn $ "✗ " <> msg _ -> return () return r data VPIState = VPIState - { vpiSignal :: ID 'FINAL () -> SomeSignal 'FINAL - , vpiSignals :: [SomeSignal 'FINAL] - , vpiStepRef :: IORef Int + { testbench :: Testbench + -- multiple clocks are not supported yet, currently all clocks + -- are synchronously executed. , vpiClock :: Bit , vpiSimSteps :: Int , vpiInit :: Bool @@ -98,12 +99,12 @@ data VPIState = -- Note that this function is not executable in a standard Haskell -- environment, but must to be bound to some @ffiMain@ foreign call -- that is shipped via a shared library and executed by an external --- simulator. See Clash-FFI for more details. +-- simulator. See Clash-FFI for more details on this. simulateFFI :: Int -> TB a -> IO a -simulateFFI steps testbench = do - (r, Testbench{..}) <- runTB External testbench +simulateFFI steps tb = do + (r, testbench@Testbench{..}) <- runTB External tb - let ?signalFromID = tbLookupID + let ?testbench = testbench runSimAction $ do -- print simulator info @@ -125,31 +126,28 @@ simulateFFI steps testbench = do -- analyzing the architecture upfront. For long-term references to -- be reusable during simulation, the objects should be queried via -- their architectural name reference instead. - tops <- mapM findTopModule topNames + topM <- M.fromList + <$> mapM (\x -> (B.unpack x, ) <$> findTopModule x) topNames - -- match top modules with the signals -- + -- add the VPI module references to the signals vpiSignals <- - fmap ((<>) (filter (not . isSimSignal) tbSignals) . catMaybes) - $ mapM matchModule - $ M.toAscList - $ M.unionWith (\(x,_) (_,y) -> (x,y)) - ( M.fromList - $ map (\s -> (signalName `onAllSignalTypes` s, (Just s, Nothing))) - $ filter isSimSignal tbSignals - ) - ( M.fromList - $ zip (map B.unpack topNames) - $ map (\t -> (Nothing, Just t)) tops - ) + 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 = VPIState - { vpiStepRef = tbSimStepRef - , vpiClock = low + { vpiClock = low , vpiSimSteps = steps - , vpiSignal = createIDMap vpiSignals , vpiInit = True + , testbench = testbench + { tbSignals = map snd vpiSignals + , tbSignalLookup = A.array (A.bounds tbSignalLookup) vpiSignals + } , .. } @@ -160,24 +158,16 @@ simulateFFI steps testbench = do return r - where - createIDMap a b = - let f = flip M.lookup $ M.fromAscList $ map (\x -> (SomeID (signalId `onAllSignalTypes` x), x)) a in case f b of - Just x -> x - Nothing -> error $ show b - - isSimSignal = \case - SomeSignal SimSignal{} -> True - _ -> False - assignInputs :: (?state :: VPIState) => SimAction () assignInputs = do -- SimTime time <- receiveTime Sim (Nothing @Object) -- putStrLn $ "assignInputs " <> show (time, vpiClock, vpiInit) - forM_ vpiSignals $ onAllSignalTypes $ \case - SimSignal{..} -> mapM_ (assignModuleInputs vpiInstance) dependencies - _ -> return () + forM_ tbDomains $ \(d, map (tbSignalLookup !) -> xs) -> + (`onAllDomainTypes` d) $ const $ do + forM_ xs $ onAllSignalTypes $ \case + SimSignal{..} -> mapM_ (assignModuleInputs vpiInstance) dependencies + _ -> return () let ?state = ?state { vpiClock = complement vpiClock @@ -190,21 +180,22 @@ assignInputs = do where VPIState{..} = ?state + Testbench{..} = testbench - assignModuleInputs :: Typeable b => Maybe VPIInstance -> ID 'FINAL () -> SimCont b () + assignModuleInputs :: Typeable b => Maybe VPIInstance -> ID () -> SimCont b () assignModuleInputs = \case Nothing -> const $ return () Just VPIInstance{..} -> \sid@(SomeID x) -> let VPIPort{..} = vpiInputPort sid in case x of - NoID -> return () - ClockID _TODO -> sendV port vpiClock - ResetID _TODO -> sendV port $ boolToBit vpiInit - EnableID _TODO -> sendV port high - SignalID _TODO + 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` vpiSignal sid) $ \s -> + (`onAllSignalTypes` (tbSignalLookup ! i)) $ \s -> liftIO (signalCurVal s) >>= \v -> do sendV port v @@ -217,30 +208,31 @@ readOutputs = do -- SimTime time <- receiveTime Sim (Nothing @Object) -- putStrLn $ "readOutputs " <> show time - forM_ vpiSignals $ onAllSignalTypes $ \case - SimSignal{..} -> case vpiInstance of - Nothing -> error "Cannot read from module" - Just VPIInstance{..} -> - receiveValue VectorFmt (port vpiOutputPort) >>= \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 - i <- liftIO $ readIORef vpiStepRef - when (i > 0) $ forM_ vpiSignals $ onAllSignalTypes $ \s -> do - v <- liftIO $ signalCurVal s - case signalPrint s of - Nothing -> return () - Just toStr -> putStrLn . (<> toStr v) $ case s of - IOInput{} -> "I " - SimSignal{} -> "O " - TBSignal{} -> "S " - - -- proceed time for all instances not running trough Clash-FFI - liftIO $ modifyIORef vpiStepRef (+ 1) + forM_ tbDomains $ \(d, map (tbSignalLookup !) -> xs) -> + (`onAllDomainTypes` d) $ \(TBDomain{..} :: TBDomain 'FINAL dom) -> do + -- receive the outputs + forM_ xs $ onAllSignalTypes $ \case + SimSignal{..} -> case vpiInstance of + Nothing -> error "Cannot read from module" + Just VPIInstance{..} -> + receiveValue VectorFmt (port vpiOutputPort) >>= \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 + i <- liftIO $ readIORef simStepRef + when (i > 0) $ forM_ xs $ onAllSignalTypes $ \s -> do + v <- liftIO $ signalCurVal s + case signalPrint s of + Nothing -> return () + Just toStr -> putStrLn . (<> toStr v) $ case s of + IOInput{} -> "I " + SimSignal{} -> "O " + TBSignal{} -> "S " + -- proceed time for all instances not running trough Clash-FFI + liftIO $ modifyIORef simStepRef (+ 1) if vpiSimSteps > 0 then do let ?state = ?state { vpiSimSteps = vpiSimSteps - 1 } @@ -254,25 +246,12 @@ readOutputs = do where VPIState{..} = ?state + Testbench{..} = testbench matchModule :: - (?signalFromID :: ID 'FINAL () -> SomeSignal 'FINAL, Typeable b) => - (String, (Maybe (SomeSignal 'FINAL), Maybe Module)) -> - SimCont b (Maybe (SomeSignal 'FINAL)) -matchModule = \case - (_, (Just s, Just m)) -> case s of - SomeSignal s' -> Just . SomeSignal <$> vpiInst m s' - SomeMonitor s' -> Just . SomeMonitor <$> vpiInst m s' - (name, (_, Nothing)) -> - error $ "No module matches \"" <> name <> "\"" - (name, (Nothing, _)) -> do - putStrLn $ "Module not required: \"" <> name <> "\" (ignoring)" - return Nothing - -vpiInst :: - (?signalFromID :: ID 'FINAL () -> SomeSignal 'FINAL, KnownDomain dom, BitPack a, Typeable b) => + (?testbench :: Testbench, KnownDomain dom, BitPack a, Typeable b) => Module -> TBSignal 'FINAL dom a -> SimCont b (TBSignal 'FINAL dom a) -vpiInst vpiModule = \case +matchModule vpiModule = \case tbs@SimSignal{..} -> do ports <- modulePorts vpiModule dirs <- mapM direction ports @@ -316,8 +295,8 @@ vpiInst vpiModule = \case _ -> False matchPort :: - (?signalFromID :: ID 'FINAL () -> SomeSignal 'FINAL, Typeable b) => - Module -> (ID 'FINAL (), Maybe Port) -> SimCont b (ID 'FINAL (), VPIPort) + (?testbench :: Testbench, Typeable b) => + Module -> (ID (), Maybe Port) -> SimCont b (ID (), VPIPort) matchPort m = \case (_, Nothing) -> error "Not enough ports" (sid, Just p) -> do @@ -327,20 +306,28 @@ matchPort m = \case portDirection <- direction p let portName = B.unpack portNameBS - - if - | isSignalID sid -> (`onAllSignalTypes` ?signalFromID sid) $ \s -> - checkPort (toInteger portSize) s portDirection - | isClockID sid && portSize /= 1 -> error $ "Not a clock port: " <> portName - | isResetID sid && portSize /= 1 -> error $ "Not a reset port: " <> portName - | isEnableID sid && portSize /= 1 -> error $ "Not a enable port: " <> portName - | otherwise -> return () + checkID portName portSize portDirection sid -- Get a long-term reference via direct name access. Iterator - -- references may not be persitent. + -- references may not be persistent. port <- getByName (Just m) portNameBS return (sid, VPIPort{..}) + where + 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. From 34a8a1897aa981021fa838a985feace2bd96c7e5 Mon Sep 17 00:00:00 2001 From: Felix Klein Date: Wed, 31 May 2023 16:08:55 +0200 Subject: [PATCH 6/9] Hedgehog Integration (WIP) --- .../src/Clash/Testbench/Generate.hs | 89 +++++----- clash-testbench/src/Clash/Testbench/Input.hs | 61 +++++-- .../src/Clash/Testbench/Internal/Monad.hs | 164 +++++++++++------- .../src/Clash/Testbench/Internal/Signal.hs | 22 +-- .../src/Clash/Testbench/Simulate.hs | 41 +++-- 5 files changed, 234 insertions(+), 143 deletions(-) diff --git a/clash-testbench/src/Clash/Testbench/Generate.hs b/clash-testbench/src/Clash/Testbench/Generate.hs index 755e4b62ee..e3b5159d52 100644 --- a/clash-testbench/src/Clash/Testbench/Generate.hs +++ b/clash-testbench/src/Clash/Testbench/Generate.hs @@ -10,7 +10,7 @@ module Clash.Testbench.Generate where import Hedgehog import Hedgehog.Gen -import Control.Monad.State.Lazy (liftIO) +import Control.Monad.State.Lazy (liftIO, when, modify) import Data.IORef (newIORef, readIORef, writeIORef) import Clash.Prelude (KnownDomain(..), BitPack(..), NFDataX) @@ -101,34 +101,39 @@ matchIOGen expectedOutput gen = do TBDomain{..} <- tbDomain @dom vRef <- liftIO $ newIORef undefined - simStepCache <- liftIO (readIORef simStepRef >>= newIORef) + checkForProgress <- progressCheck simStepRef False mind SomeSignal $ IOInput { signalId = NoID , signalCurVal = const $ do - global <- readIORef simStepRef - local <- readIORef simStepCache + progress <- checkForProgress - if local == global - then readIORef vRef - else do + if progress + then do (i, o) <- sample gen - signalExpect expectedOutput $ Expectation (global + 1, verify o) - + curStep <- readIORef simStepRef + signalExpect expectedOutput $ Expectation (curStep, verify o) writeIORef vRef i - writeIORef simStepCache global + return i + else + readIORef vRef , signalPrint = Nothing } + where - verify x y - | x == y = Nothing - | otherwise = Just $ "Expected " <> show x <> " but the output is " <> show y + verify x y = do + when (x /= y) + $ footnote + $ "Expected '" <> show x <> "' but the output is '" <> show y <> "'" + x === x -- | Extended version of 'matchIOGen', which allows to specify valid --- IO behavior over a finite amount of simulation steps. The generator --- is repeatedly called after all steps of a generation have been --- verified. +-- 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) => @@ -136,39 +141,45 @@ matchIOGenN :: matchIOGenN expectedOutput gen = do TBDomain{..} <- tbDomain @dom - vRef <- liftIO $ newIORef [] - simStepCache <- liftIO (readIORef simStepRef >>= newIORef) + xs <- liftIO $ sample gen + modify $ \st@ST{..} -> st { simSteps = max simSteps $ length xs } + + vRef <- liftIO $ newIORef xs + checkForProgress <- progressCheck simStepRef False mind SomeSignal $ IOInput - { signalId = NoID + { signalId = NoID , signalCurVal = const $ do - global <- readIORef simStepRef - local <- readIORef simStepCache + progress <- checkForProgress - if local == global - then readIORef vRef >>= \case - (i, _) : _ -> return i - [] -> do - (i, o) : xr <- sample gen - writeIORef vRef ((i, o) : xr) - Prelude.print $ (i, o) : xr - return i - else do - writeIORef simStepCache global - readIORef vRef >>= \case + readIORef vRef >>= + if progress + then \case _ : (i, o) : xr -> do writeIORef vRef ((i, o) : xr) - signalExpect expectedOutput $ Expectation (global + 1, verify o) + curStep <- readIORef simStepRef + signalExpect expectedOutput $ Expectation (curStep, verify o) return i _ -> do (i, o) : xr <- sample gen - Prelude.print $ (i, o) : xr + writeIORef vRef ((i, o) : xr) - signalExpect expectedOutput $ Expectation (global + 1, verify o) + curStep <- readIORef simStepRef + signalExpect expectedOutput $ Expectation (curStep, verify o) return i - , signalPrint = Nothing + else \case + (i, _) : _ -> return i + [] -> do + (i, o) : xr <- sample gen + writeIORef vRef ((i, o) : xr) + Prelude.print $ (i, o) : xr + return i + , signalPrint = Nothing } + where - verify x y - | x == y = Nothing - | otherwise = Just $ "Expected '" <> show x <> "' but the output is '" <> show y <> "'" + verify x y = do + when (x /= y) + $ footnote + $ "Expected '" <> show x <> "' but the output is '" <> show y <> "'" + x === x diff --git a/clash-testbench/src/Clash/Testbench/Input.hs b/clash-testbench/src/Clash/Testbench/Input.hs index 5e970b2cbb..b58d30ec71 100644 --- a/clash-testbench/src/Clash/Testbench/Input.hs +++ b/clash-testbench/src/Clash/Testbench/Input.hs @@ -12,8 +12,6 @@ module Clash.Testbench.Input import Control.Monad.State.Lazy import Data.IORef -import Data.Maybe (fromMaybe) -import Data.List (uncons) import Clash.Prelude (KnownDomain(..), BitPack(..), NFDataX) @@ -22,33 +20,58 @@ 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, Show a) => - a -> [a] -> TB (TBSignal dom a) -fromList x xs = do + (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 - listRef <- liftIO $ newIORef $ x : xs - simStepCache <- liftIO (readIORef simStepRef >>= newIORef) + vRef <- liftIO $ newIORef xs + checkForProgress <- progressCheck simStepRef False mind SomeSignal $ IOInput { signalId = NoID , signalPrint = Nothing , signalCurVal = const $ do - (r, rs) <- fromMaybe (x, []) . uncons <$> readIORef listRef - global <- readIORef simStepRef - local <- readIORef simStepCache - - if local == global - then return r - else do - writeIORef listRef rs - writeIORef simStepCache global - return $ case rs of - [] -> x - y:_ -> y + readIORef vRef >>= \case + [] -> case mode of + Repeat -> do + let (x : xr) = xs + writeIORef vRef xr + return x + Default v -> + return v + IsInfinite -> + error $ "Clash.Testbench.Input.fromList: " + <> "End of list reached." + x : xr -> do + progress <- checkForProgress + + when progress $ + writeIORef vRef xr + + return x } diff --git a/clash-testbench/src/Clash/Testbench/Internal/Monad.hs b/clash-testbench/src/Clash/Testbench/Internal/Monad.hs index 5137614ec9..b6db9bf9e0 100644 --- a/clash-testbench/src/Clash/Testbench/Internal/Monad.hs +++ b/clash-testbench/src/Clash/Testbench/Internal/Monad.hs @@ -14,25 +14,26 @@ module Clash.Testbench.Internal.Monad , KnownDomains , Testbench(..) , TB - , ST + , ST(..) , LiftAcc(..) , ArgOf , LiftTB(..) , runTB , tbDomain , mind + , progressCheck ) where import Data.Bifunctor (bimap) import Data.Function (on) import Data.Type.Equality import Algebra.PartialOrd -import Control.Monad.State.Lazy (StateT, liftIO, get, gets, modify, evalStateT, forM_, void) +import Control.Monad.State.Lazy + (StateT, liftIO, get, gets, modify, evalStateT, forM_, void, when) import Data.Function ((&)) import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) -import Data.List (uncons, partition, sort, sortBy, groupBy) -import Data.Maybe (catMaybes, mapMaybe) - +import Data.List (partition, sort, sortBy, groupBy) +import Data.Maybe (catMaybes) import qualified Data.Map as M import qualified Data.Set as S @@ -71,12 +72,14 @@ data ST = { idSigCount :: ID Int -- ^ Counter for generating free IDs to be assigned to signal -- (functions) - , signals :: KnownSignals 'USER + , signals :: KnownSignals 'USER -- ^ Captured signal (functions) , idDomCount :: ID Int -- ^ Counter for generating free IDs to be assigned to domains - , domains :: KnownDomains 'USER + , domains :: KnownDomains 'USER -- ^ Captured domains + , simSteps :: Int + -- ^ Simulation step preset } instance Show ST where @@ -101,6 +104,8 @@ data Testbench = -- 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{..} = @@ -148,7 +153,7 @@ data LiftAcc a b = -- ^ the name of the lifted signal (function) , deps :: [ID ()] -- ^ the dependencies of the lifted signal (function) - , signalRef :: IORef b + , 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 @@ -177,55 +182,58 @@ instance where (@@) = initializeLiftTB - liftTB exec origin = do + liftTB exec signalOrigin = do extVal <- liftIO $ newIORef Nothing expectations <- liftIO $ newIORef [] LiftAcc{..} <- exec TBDomain{..} <- tbDomain @domA - simStepCache <- liftIO (readIORef simStepRef >>= newIORef) + -- 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. + checkForProgress <- progressCheck simStepRef True + vRef <- liftIO $ newIORef undefined let signalCurVal = \case Internal -> do - (head# -> x, step) <- cont - global <- readIORef simStepRef - local <- readIORef simStepCache - - if local == global - then return x - else do - modifyIORef signalRef $ step tail# - writeIORef simStepCache global + progress <- checkForProgress + + if progress + then do + (head# -> x, step) <- cont + writeIORef vRef x + modifyIORef sfRef $ step tail# return x + else + readIORef vRef + External -> readIORef extVal >>= \case Nothing -> error "No Value @Signal" Just x -> return x mind SomeSignal $ Internal.SimSignal - { signalId = NoID - , dependencies = reverse deps - , signalName = name + { signalId = NoID + , signalDeps = reverse deps + , signalName = name , signalUpdate = Just (writeIORef extVal . Just) , signalExpect = modifyIORef expectations . (:) - , signalVerify = \m -> do - step <- readIORef simStepRef - value <- signalCurVal m - expct <- readIORef expectations + , signalVerify = \mode -> do + curStep <- liftIO $ readIORef simStepRef + value <- liftIO $ signalCurVal mode + expct <- liftIO $ readIORef expectations let - (cur, later) = - partition (flip leq $ Expectation (step + 1, undefined)) expct - - writeIORef expectations later + (current, later) = + partition (`leq` Expectation (curStep + 1, undefined)) expct - return - $ fmap fst - $ uncons - $ mapMaybe ((value &) . snd . expectation) cur + liftIO $ writeIORef expectations later + mapM_ ((value &) . snd . expectation) current - , signalPrint = Nothing - , vpiInstance = Nothing + , signalPrint = Nothing + , signalVPI = Nothing , .. } @@ -236,7 +244,7 @@ instance where (@@) = initializeLiftTB - liftTB a sf s = liftTB (upd <$> a) $ sf $ origin s + liftTB a sf s = liftTB (upd <$> a) $ sf $ signalOrigin s where upd acc@LiftAcc{..} = acc { deps = SomeID (signalId s) : deps @@ -299,21 +307,21 @@ instance resetId <- nextFreeID ResetID extVal <- liftIO $ newIORef Nothing signalRef <- liftIO $ newIORef $ unsafeFromReset reset - simStepCache <- liftIO (readIORef simStepRef >>= newIORef) + checkForProgress <- progressCheck simStepRef False let resetCurVal = \case Internal -> do - s@(_ :- s') <- readIORef signalRef - global <- readIORef simStepRef - local <- readIORef simStepCache - - if local == global - then return $ head# s - else do - writeIORef signalRef s' - writeIORef simStepCache global - return $ head# s' + x :- xr <- readIORef signalRef + progress <- checkForProgress + + if progress + then do + writeIORef signalRef xr + return $ head# xr + else + return x + External -> readIORef extVal >>= \case Nothing -> error "No Value @Reset" Just x -> return x @@ -355,21 +363,21 @@ instance enableId <- nextFreeID EnableID extVal <- liftIO $ newIORef Nothing signalRef <- liftIO $ newIORef (fromEnable enable) - simStepCache <- liftIO (readIORef simStepRef >>= newIORef) + checkForProgress <- progressCheck simStepRef False let enableCurVal = \case Internal -> do - s@(_ :- s') <- readIORef signalRef - global <- readIORef simStepRef - local <- readIORef simStepCache - - if local == global - then return $ head# s - else do - writeIORef signalRef s' - writeIORef simStepCache global - return $ head# s' + x :- xr <- readIORef signalRef + progress <- checkForProgress + + if progress + then do + writeIORef signalRef xr + return $ head# xr + else + return x + External -> readIORef extVal >>= \case Nothing -> error "No Value @Enable" Just x -> return x @@ -401,13 +409,39 @@ initializeLiftTB :: (LiftTB a, a ~ (ArgOf a -> b)) => String -> ArgOf a -> b initializeLiftTB name x = liftTB accInit x where accInit = do - signalRef <- liftIO $ newIORef x + sfRef <- liftIO $ newIORef x return LiftAcc { deps = [] - , cont = (,($)) <$> readIORef signalRef + , 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 + + -- | Some generalized extender for the accumulated continuation. extendVia :: Monad m => @@ -427,7 +461,6 @@ extendVia contAcc valueM f g = do (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) @@ -518,6 +551,7 @@ runTB mode testbench = , signals = S.empty , idDomCount = 0 , domains = M.empty + , simSteps = 0 } where finalize r = do @@ -540,7 +574,11 @@ runTB mode testbench = void $ tbDomain @dom -- all of the internal state is final at this point - ST { idSigCount = FreeID n, idDomCount = FreeID m, .. } <- get + ST { idSigCount = FreeID n + , idDomCount = FreeID m + , simSteps = tbSimSteps + , .. + } <- get let -- finalize the domains diff --git a/clash-testbench/src/Clash/Testbench/Internal/Signal.hs b/clash-testbench/src/Clash/Testbench/Internal/Signal.hs index 88884e8b26..03c404f3df 100644 --- a/clash-testbench/src/Clash/Testbench/Internal/Signal.hs +++ b/clash-testbench/src/Clash/Testbench/Internal/Signal.hs @@ -11,6 +11,8 @@ module Clash.Testbench.Internal.Signal where import Algebra.PartialOrd import Data.Function (on) +import Hedgehog (PropertyT) + import Data.IORef (IORef) import Clash.Prelude ( KnownDomain(..), BitPack(..), SDomainConfiguration(..), NFDataX, Type @@ -70,7 +72,7 @@ data VPIInstance = } -- | Expectations on certain outputs at the given simulation step. -newtype Expectation a = Expectation { expectation :: (Int, a -> Maybe String) } +newtype Expectation a = Expectation { expectation :: (Int, a -> PropertyT IO ()) } -- | Expectations cannot be compared: they are always unequal. instance Eq (Expectation a) where @@ -90,13 +92,13 @@ data TBSignal (s :: Stage) (dom :: Domain) a = { signalId :: ID SIGNAL , signalCurVal :: SimModeDependent s (IO a) , signalPrint :: Maybe (a -> String) - , origin :: Signal dom a - , dependencies :: [ID ()] + , signalOrigin :: Signal dom a + , signalDeps :: [ID ()] , signalName :: String , signalUpdate :: Maybe (a -> IO ()) , signalExpect :: Expectation a -> IO () - , signalVerify :: SimModeDependent s (IO (Maybe String)) - , vpiInstance :: Maybe VPIInstance + , signalVerify :: SimModeDependent s (PropertyT IO ()) + , signalVPI :: Maybe VPIInstance } -- | A signal that receives its content from IO. | IOInput @@ -119,7 +121,7 @@ instance KnownDomain dom => Show (TBSignal s dom a) where <> signalName <> "\" @" <> ssymbolToString domainName <> " " <> show signalId <> " " - <> show dependencies + <> show signalDeps IOInput{..} -> "Input " <> show signalId TBSignal{} -> @@ -326,10 +328,10 @@ onAllSignalTypes f = \case -- 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 + { domainClock :: Maybe (TBClock s dom) + , domainReset :: Maybe (TBReset s dom) + , domainEnable :: Maybe (TBEnable s dom) + , simStepRef :: IORef Int } -- | Existential data type wrapper for 'TBDomain'. diff --git a/clash-testbench/src/Clash/Testbench/Simulate.hs b/clash-testbench/src/Clash/Testbench/Simulate.hs index c3feca719a..53563c8758 100644 --- a/clash-testbench/src/Clash/Testbench/Simulate.hs +++ b/clash-testbench/src/Clash/Testbench/Simulate.hs @@ -11,6 +11,7 @@ module Clash.Testbench.Simulate , LiftTB((@@)) , simulate , simulateFFI + , tbProperty ) where import Prelude hiding (putStrLn) @@ -20,6 +21,8 @@ import Control.Monad.IO.Class import Control.Monad.State.Lazy hiding (lift) import Data.Proxy +import qualified Hedgehog (Property, property) + import Data.Array ((!)) import Data.Coerce (Coercible) import Data.IORef @@ -62,8 +65,8 @@ simulate steps testbench = do replicateM_ (steps + 1) $ do forM_ tbDomains $ \(d, map (tbSignalLookup !) -> xs) -> (`onAllDomainTypes` d) $ \(TBDomain{..} :: TBDomain 'FINAL dom) -> do - i <- readIORef simStepRef - when (i > 0) $ forM_ xs $ onAllSignalTypes $ \s -> do +-- i <- readIORef simStepRef + forM_ xs $ onAllSignalTypes $ \s -> do v <- signalCurVal s case signalPrint s of Nothing -> return () @@ -73,15 +76,29 @@ simulate steps testbench = do TBSignal{} -> "S " modifyIORef simStepRef (+ 1) - forM_ tbSignals $ onAllSignalTypes $ \case - SimSignal{..} -> do - signalVerify >>= \case - Nothing -> Prelude.putStrLn "✓" - Just msg -> Prelude.putStrLn $ "✗ " <> msg - _ -> return () +-- forM_ tbSignals $ onAllSignalTypes $ \case +-- SimSignal{..} -> do +-- signalVerify >>= \case +-- Nothing -> Prelude.putStrLn "✓" +-- Just msg -> error $ "✗ " <> msg +-- _ -> return () return r +tbProperty :: TB () -> Hedgehog.Property +tbProperty testbench = Hedgehog.property $ do + (_, 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 +-- void $ liftIO $ signalCurVal s + case s of + SimSignal{..} -> signalVerify + _ -> return () + + liftIO $ modifyIORef simStepRef (+ 1) + data VPIState = VPIState { testbench :: Testbench @@ -166,7 +183,7 @@ assignInputs = do forM_ tbDomains $ \(d, map (tbSignalLookup !) -> xs) -> (`onAllDomainTypes` d) $ const $ do forM_ xs $ onAllSignalTypes $ \case - SimSignal{..} -> mapM_ (assignModuleInputs vpiInstance) dependencies + SimSignal{..} -> mapM_ (assignModuleInputs signalVPI) signalDeps _ -> return () @@ -212,7 +229,7 @@ readOutputs = do (`onAllDomainTypes` d) $ \(TBDomain{..} :: TBDomain 'FINAL dom) -> do -- receive the outputs forM_ xs $ onAllSignalTypes $ \case - SimSignal{..} -> case vpiInstance of + SimSignal{..} -> case signalVPI of Nothing -> error "Cannot read from module" Just VPIInstance{..} -> receiveValue VectorFmt (port vpiOutputPort) >>= \case @@ -263,7 +280,7 @@ matchModule vpiModule = \case vpiInputPort <- (M.!) . M.fromList <$> ( mapM (matchPort vpiModule) - $ zip dependencies + $ zip signalDeps $ map Just inputPorts <> repeat Nothing ) @@ -282,7 +299,7 @@ matchModule vpiModule = \case return $ VPIPort{..} _ -> error "TODO: later / " - return tbs { vpiInstance = Just VPIInstance{..} } + return tbs { signalVPI = Just VPIInstance{..} } _ -> error "Unfiltered TBS" where From 810392d4240b06b1ee25bfe849ac935d126b3a60 Mon Sep 17 00:00:00 2001 From: Felix Klein Date: Thu, 1 Jun 2023 16:19:20 +0200 Subject: [PATCH 7/9] Hedgehog Integration (WIP) --- .../src/Clash/Testbench/Generate.hs | 114 ++++++++++++------ clash-testbench/src/Clash/Testbench/Input.hs | 41 ++++--- .../src/Clash/Testbench/Internal/Monad.hs | 87 +++++++++++-- .../src/Clash/Testbench/Internal/Signal.hs | 91 +++++++++++--- .../src/Clash/Testbench/Simulate.hs | 59 +++++---- 5 files changed, 274 insertions(+), 118 deletions(-) diff --git a/clash-testbench/src/Clash/Testbench/Generate.hs b/clash-testbench/src/Clash/Testbench/Generate.hs index e3b5159d52..f4ab03b16b 100644 --- a/clash-testbench/src/Clash/Testbench/Generate.hs +++ b/clash-testbench/src/Clash/Testbench/Generate.hs @@ -6,6 +6,8 @@ Maintainer: QBayLogic B.V. Use generators to create signal data. -} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} module Clash.Testbench.Generate where import Hedgehog @@ -25,27 +27,29 @@ import Clash.Testbench.Internal.Monad generate :: forall dom a. (NFDataX a, BitPack a, KnownDomain dom) => - a -> Gen a -> TB (TBSignal dom a) -generate def gen = do + Gen a -> TB (TBSignal dom a) +generate gen = do TBDomain{..} <- tbDomain @dom - vRef <- liftIO $ newIORef def - simStepCache <- liftIO (readIORef simStepRef >>= newIORef) + vRef <- liftIO $ newIORef undefined + checkForProgress <- progressCheck simStepRef True + signalHistory <- newHistory mind SomeSignal IOInput { signalId = NoID , signalCurVal = const $ do - v <- readIORef simStepRef - v' <- readIORef simStepCache + progress <- checkForProgress - if v == v' - then readIORef vRef - else do + if progress + then do x <- sample gen writeIORef vRef x - writeIORef simStepCache v + memorize signalHistory x return x + else + readIORef vRef , signalPrint = Nothing + ,.. } -- | Extended version of 'generate', which allows to generate a finite @@ -60,32 +64,33 @@ generateN def gen = do TBDomain{..} <- tbDomain @dom vRef <- liftIO $ newIORef [def] - simStepCache <- liftIO (readIORef simStepRef >>= newIORef) + checkForProgress <- progressCheck simStepRef False + signalHistory <- newHistory mind SomeSignal IOInput { signalId = NoID , signalCurVal = const $ do - v <- readIORef simStepRef - v' <- readIORef simStepCache - - if v == v' - then readIORef vRef >>= \case - x : _ -> return x - [] -> do - x : xr <- sample gen - writeIORef vRef (x : xr) - return x + progress <- checkForProgress - else do - writeIORef simStepCache v + if progress + then readIORef vRef >>= \case - _ : x : xr -> do + h : x : xr -> do + memorize signalHistory h writeIORef vRef (x : xr) return x - _ -> do + [h] -> do + memorize signalHistory h x : xr <- sample gen writeIORef vRef (x : xr) return x + _ -> error "unreachable" + else readIORef vRef >>= \case + x : _ -> return x + [] -> do + x : xr <- sample gen + writeIORef vRef (x : xr) + return x , signalPrint = Nothing , .. } @@ -102,6 +107,7 @@ matchIOGen expectedOutput gen = do vRef <- liftIO $ newIORef undefined checkForProgress <- progressCheck simStepRef False + signalHistory <- newHistory mind SomeSignal $ IOInput { signalId = NoID @@ -119,6 +125,7 @@ matchIOGen expectedOutput gen = do else readIORef vRef , signalPrint = Nothing + , .. } where @@ -138,16 +145,18 @@ 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 expectedOutput gen = do +matchIOGenN checkedOutput gen = mdo TBDomain{..} <- tbDomain @dom xs <- liftIO $ sample gen modify $ \st@ST{..} -> st { simSteps = max simSteps $ length xs } + liftIO $ Prelude.print xs vRef <- liftIO $ newIORef xs checkForProgress <- progressCheck simStepRef False + signalHistory <- newHistory - mind SomeSignal $ IOInput + s <- mind SomeSignal $ IOInput { signalId = NoID , signalCurVal = const $ do progress <- checkForProgress @@ -155,18 +164,21 @@ matchIOGenN expectedOutput gen = do readIORef vRef >>= if progress then \case - _ : (i, o) : xr -> do + (h, _) : (i, o) : xr -> do + memorize signalHistory h writeIORef vRef ((i, o) : xr) curStep <- readIORef simStepRef - signalExpect expectedOutput $ Expectation (curStep, verify o) + signalExpect checkedOutput $ Expectation (curStep, verify s i o) return i - _ -> do + [(h, _)] -> do + memorize signalHistory h (i, o) : xr <- sample gen writeIORef vRef ((i, o) : xr) curStep <- readIORef simStepRef - signalExpect expectedOutput $ Expectation (curStep, verify o) + signalExpect checkedOutput $ Expectation (curStep, verify s i o) return i + _ -> error "unreachable" else \case (i, _) : _ -> return i [] -> do @@ -175,11 +187,41 @@ matchIOGenN expectedOutput gen = do Prelude.print $ (i, o) : xr return i , signalPrint = Nothing + , .. } + return s + where - verify x y = do - when (x /= y) - $ footnote - $ "Expected '" <> show x <> "' but the output is '" <> show y <> "'" - x === x + verify generatedInput currentInput expectedOutput observedOutput = do + when (expectedOutput /= observedOutput) $ 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 + + footnote $ 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 + ] + + failure diff --git a/clash-testbench/src/Clash/Testbench/Input.hs b/clash-testbench/src/Clash/Testbench/Input.hs index b58d30ec71..764ed4eb70 100644 --- a/clash-testbench/src/Clash/Testbench/Input.hs +++ b/clash-testbench/src/Clash/Testbench/Input.hs @@ -51,27 +51,30 @@ fromList mode xs = do 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 - , signalCurVal = const $ do - readIORef vRef >>= \case - [] -> case mode of - Repeat -> do - let (x : xr) = xs - writeIORef vRef xr - return x - Default v -> - return v - IsInfinite -> - error $ "Clash.Testbench.Input.fromList: " - <> "End of list reached." - x : xr -> do - progress <- checkForProgress - - when progress $ - writeIORef vRef xr - - return x + , .. } diff --git a/clash-testbench/src/Clash/Testbench/Internal/Monad.hs b/clash-testbench/src/Clash/Testbench/Internal/Monad.hs index b6db9bf9e0..c1a5830790 100644 --- a/clash-testbench/src/Clash/Testbench/Internal/Monad.hs +++ b/clash-testbench/src/Clash/Testbench/Internal/Monad.hs @@ -9,6 +9,7 @@ bench creation (internal module). {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} module Clash.Testbench.Internal.Monad ( KnownSignals , KnownDomains @@ -17,20 +18,26 @@ module Clash.Testbench.Internal.Monad , 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.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) @@ -80,6 +87,9 @@ data ST = -- ^ 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 @@ -150,13 +160,13 @@ type family ArgOf a where data LiftAcc a b = LiftAcc { name :: String - -- ^ the name of the lifted signal (function) + -- ^ The name of the lifted signal (function) , deps :: [ID ()] - -- ^ the dependencies of the lifted signal (function) + -- ^ The dependencies of the lifted signal (function) , sfRef :: IORef b - -- ^ some IO reference to the lifted signal (function) + -- ^ Some IO reference to the lifted signal (function) , cont :: IO (a, (a -> a) -> b -> b) - -- ^ the continuation transformation of the lifted signal + -- ^ The continuation transformation of the lifted signal -- (function) } @@ -174,11 +184,18 @@ class LiftTB a where -- the given signal function. liftTB :: TB (LiftAcc (ArgOf a) b) -> a -instance +-- | '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 - ) => LiftTB (Signal domA a -> TB (TBSignal domB a')) + ) + +instance + LiftTBSignalConstraints domA domB a a' => + LiftTB (Signal domA a -> TB (TBSignal domB a')) where (@@) = initializeLiftTB @@ -195,6 +212,7 @@ instance -- values. checkForProgress <- progressCheck simStepRef True vRef <- liftIO $ newIORef undefined + signalHistory <- newHistory let signalCurVal = \case @@ -203,9 +221,14 @@ instance if progress then do + -- progress on the signal (head# -> x, step) <- cont writeIORef vRef x modifyIORef sfRef $ step tail# + + -- update the history + memorize signalHistory x + return x else readIORef vRef @@ -233,7 +256,7 @@ instance mapM_ ((value &) . snd . expectation) current , signalPrint = Nothing - , signalVPI = Nothing + , signalPlug = Nothing , .. } @@ -442,6 +465,45 @@ progressCheck simStepRef initialProgress = do | otherwise = id +newHistory :: + TB (History a) +newHistory = do + size <- gets defaultHistorySize + historySize <- liftIO $ newIORef size + historyBufferPos <- liftIO $ newIORef 0 + historyBuffer <- liftIO $ newIORef Nothing + return History{..} + +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 + +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 => @@ -547,11 +609,12 @@ updDomain domain = case knownDomain @dom of 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 + { idSigCount = 1 + , signals = S.empty + , idDomCount = 0 + , domains = M.empty + , simSteps = 0 + , defaultHistorySize = 100 } where finalize r = do diff --git a/clash-testbench/src/Clash/Testbench/Internal/Signal.hs b/clash-testbench/src/Clash/Testbench/Internal/Signal.hs index 03c404f3df..23517cbf71 100644 --- a/clash-testbench/src/Clash/Testbench/Internal/Signal.hs +++ b/clash-testbench/src/Clash/Testbench/Internal/Signal.hs @@ -13,6 +13,7 @@ import Data.Function (on) import Hedgehog (PropertyT) +import Data.Array.IO (IOArray) import Data.IORef (IORef) import Clash.Prelude ( KnownDomain(..), BitPack(..), SDomainConfiguration(..), NFDataX, Type @@ -53,8 +54,8 @@ type family SimModeDependent (s :: Stage) a where SimModeDependent 'FINAL a = a -- | Clash-FFI Port connector. -data VPIPort = - VPIPort +data PortInterface = + PortInterface { port :: Port , portName :: String , portSize :: Int @@ -63,12 +64,19 @@ data VPIPort = } -- | Clash-FFI Module connector. -data VPIInstance = - VPIInstance - { vpiModule :: Module - , vpiInputPort :: ID () -> VPIPort +data ModuleInterface = + ModuleInterface + { module_ :: Module + , inputPort :: ID () -> PortInterface -- TODO: multiple port support vie Bundle/Unbundle - , vpiOutputPort :: VPIPort + , outputPort :: PortInterface + } + +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. @@ -87,32 +95,71 @@ instance PartialOrd (Expectation a) where -- | 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 can be simulated. + -- | A signal that is simulated SimSignal - { signalId :: ID SIGNAL + { signalId :: ID SIGNAL + -- ^ Some unique signal ID , signalCurVal :: SimModeDependent s (IO a) - , signalPrint :: Maybe (a -> String) + -- ^ 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 - , signalDeps :: [ID ()] - , signalName :: String - , signalUpdate :: Maybe (a -> IO ()) + -- ^ 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 (PropertyT IO ()) - , signalVPI :: Maybe VPIInstance + -- ^ 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 from IO. + -- | A signal that receives its content via some IO | IOInput - { signalId :: ID SIGNAL + { signalId :: ID SIGNAL + -- ^ Some unique signal ID , signalCurVal :: SimModeDependent s (IO a) - , signalPrint :: Maybe (a -> String) + -- ^ 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. + -- | A signal that results from composition | TBSignal - { signalId :: ID SIGNAL + { 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) - , signalPrint :: Maybe (a -> String) + -- ^ 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 @@ -127,9 +174,13 @@ instance KnownDomain dom => Show (TBSignal s dom a) where 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 diff --git a/clash-testbench/src/Clash/Testbench/Simulate.hs b/clash-testbench/src/Clash/Testbench/Simulate.hs index 53563c8758..c2bb2c7b4a 100644 --- a/clash-testbench/src/Clash/Testbench/Simulate.hs +++ b/clash-testbench/src/Clash/Testbench/Simulate.hs @@ -76,26 +76,19 @@ simulate steps testbench = do TBSignal{} -> "S " modifyIORef simStepRef (+ 1) --- forM_ tbSignals $ onAllSignalTypes $ \case --- SimSignal{..} -> do --- signalVerify >>= \case --- Nothing -> Prelude.putStrLn "✓" --- Just msg -> error $ "✗ " <> msg --- _ -> return () - return r +-- | Turns a test bench design into a 'Hedghog.Property' using +-- internal simulation. tbProperty :: TB () -> Hedgehog.Property tbProperty testbench = Hedgehog.property $ do (_, 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 --- void $ liftIO $ signalCurVal s - case s of - SimSignal{..} -> signalVerify - _ -> return () + forM_ xs $ onAllSignalTypes $ \case + SimSignal{..} -> signalVerify + _ -> return () liftIO $ modifyIORef simStepRef (+ 1) @@ -183,7 +176,7 @@ assignInputs = do forM_ tbDomains $ \(d, map (tbSignalLookup !) -> xs) -> (`onAllDomainTypes` d) $ const $ do forM_ xs $ onAllSignalTypes $ \case - SimSignal{..} -> mapM_ (assignModuleInputs signalVPI) signalDeps + SimSignal{..} -> mapM_ (assignModuleInputs signalPlug) signalDeps _ -> return () @@ -191,7 +184,7 @@ assignInputs = do , vpiInit = False } - if vpiClock == low || vpiInit + if vpiClock == high || vpiInit then nextCB ReadWriteSynch 1 assignInputs else nextCB ReadOnlySynch 1 readOutputs @@ -199,11 +192,15 @@ assignInputs = do VPIState{..} = ?state Testbench{..} = testbench - assignModuleInputs :: Typeable b => Maybe VPIInstance -> ID () -> SimCont b () + assignModuleInputs :: + Typeable b => + Maybe ModuleInterface -> + ID () -> + SimCont b () assignModuleInputs = \case - Nothing -> const $ return () - Just VPIInstance{..} -> \sid@(SomeID x) -> - let VPIPort{..} = vpiInputPort sid + Nothing -> const $ return () + Just ModuleInterface{..} -> \sid@(SomeID x) -> + let PortInterface{..} = inputPort sid in case x of NoID -> return () ClockID _TODO -> sendV port vpiClock @@ -229,10 +226,10 @@ readOutputs = do (`onAllDomainTypes` d) $ \(TBDomain{..} :: TBDomain 'FINAL dom) -> do -- receive the outputs forM_ xs $ onAllSignalTypes $ \case - SimSignal{..} -> case signalVPI of + SimSignal{..} -> case signalPlug of Nothing -> error "Cannot read from module" - Just VPIInstance{..} -> - receiveValue VectorFmt (port vpiOutputPort) >>= \case + 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" @@ -268,23 +265,23 @@ readOutputs = do matchModule :: (?testbench :: Testbench, KnownDomain dom, BitPack a, Typeable b) => Module -> TBSignal 'FINAL dom a -> SimCont b (TBSignal 'FINAL dom a) -matchModule vpiModule = \case +matchModule module_ = \case tbs@SimSignal{..} -> do - ports <- modulePorts vpiModule + 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 - vpiInputPort <- + inputPort <- (M.!) . M.fromList - <$> ( mapM (matchPort vpiModule) + <$> ( mapM (matchPort module_) $ zip signalDeps $ map Just inputPorts <> repeat Nothing ) - vpiOutputPort <- case outputPorts of + outputPort <- case outputPorts of [p] -> do portNameBS <- receiveProperty Name p portSize <- fromEnum <$> getProperty Size p @@ -292,14 +289,14 @@ matchModule vpiModule = \case portDirection <- direction p let portName = B.unpack portNameBS - port <- getByName (Just vpiModule) portNameBS + port <- getByName (Just module_) portNameBS checkPort (toInteger portSize) tbs portDirection - return $ VPIPort{..} + return $ PortInterface{..} _ -> error "TODO: later / " - return tbs { signalVPI = Just VPIInstance{..} } + return tbs { signalPlug = Just ModuleInterface{..} } _ -> error "Unfiltered TBS" where @@ -313,7 +310,7 @@ matchModule vpiModule = \case matchPort :: (?testbench :: Testbench, Typeable b) => - Module -> (ID (), Maybe Port) -> SimCont b (ID (), VPIPort) + Module -> (ID (), Maybe Port) -> SimCont b (ID (), PortInterface) matchPort m = \case (_, Nothing) -> error "Not enough ports" (sid, Just p) -> do @@ -329,7 +326,7 @@ matchPort m = \case -- references may not be persistent. port <- getByName (Just m) portNameBS - return (sid, VPIPort{..}) + return (sid, PortInterface{..}) where Testbench{..} = ?testbench From cb513f994ce143ca85c91384dc4cc2f94f0ef955 Mon Sep 17 00:00:00 2001 From: Felix Klein Date: Fri, 2 Jun 2023 14:47:17 +0200 Subject: [PATCH 8/9] Hedgehog Integration (WIP) --- .../src/Clash/Testbench/Generate.hs | 79 +++--- .../src/Clash/Testbench/Internal/Monad.hs | 18 +- .../src/Clash/Testbench/Internal/Signal.hs | 61 +++-- .../src/Clash/Testbench/Simulate.hs | 236 ++++++++++-------- 4 files changed, 236 insertions(+), 158 deletions(-) diff --git a/clash-testbench/src/Clash/Testbench/Generate.hs b/clash-testbench/src/Clash/Testbench/Generate.hs index f4ab03b16b..6ba21426d2 100644 --- a/clash-testbench/src/Clash/Testbench/Generate.hs +++ b/clash-testbench/src/Clash/Testbench/Generate.hs @@ -12,6 +12,7 @@ module Clash.Testbench.Generate where import Hedgehog import Hedgehog.Gen +import Control.Monad.IO.Class (MonadIO) import Control.Monad.State.Lazy (liftIO, when, modify) import Data.IORef (newIORef, readIORef, writeIORef) @@ -102,7 +103,7 @@ 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 expectedOutput gen = do +matchIOGen checkedOutput gen = do TBDomain{..} <- tbDomain @dom vRef <- liftIO $ newIORef undefined @@ -116,12 +117,11 @@ matchIOGen expectedOutput gen = do if progress then do - (i, o) <- sample gen + (input, expectedOutput) <- sample gen curStep <- readIORef simStepRef - signalExpect expectedOutput $ Expectation (curStep, verify o) - writeIORef vRef i - - return i + signalExpect checkedOutput $ Expectation (curStep, verifier expectedOutput) + writeIORef vRef input + return input else readIORef vRef , signalPrint = Nothing @@ -129,11 +129,18 @@ matchIOGen expectedOutput gen = do } where - verify x y = do - when (x /= y) - $ footnote - $ "Expected '" <> show x <> "' but the output is '" <> show y <> "'" - x === x + 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 @@ -168,7 +175,7 @@ matchIOGenN checkedOutput gen = mdo memorize signalHistory h writeIORef vRef ((i, o) : xr) curStep <- readIORef simStepRef - signalExpect checkedOutput $ Expectation (curStep, verify s i o) + signalExpect checkedOutput $ Expectation (curStep, verifier s i o) return i [(h, _)] -> do memorize signalHistory h @@ -176,7 +183,7 @@ matchIOGenN checkedOutput gen = mdo writeIORef vRef ((i, o) : xr) curStep <- readIORef simStepRef - signalExpect checkedOutput $ Expectation (curStep, verify s i o) + signalExpect checkedOutput $ Expectation (curStep, verifier s i o) return i _ -> error "unreachable" else \case @@ -193,8 +200,14 @@ matchIOGenN checkedOutput gen = mdo return s where - verify generatedInput currentInput expectedOutput observedOutput = do - when (expectedOutput /= observedOutput) $ do + 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) @@ -207,21 +220,21 @@ matchIOGenN checkedOutput gen = mdo iLen = maximum $ (length iHeading :) $ fmap (length . show . fst) xs oLen = maximum $ (length oHeading :) $ fmap (length . show . snd) xs - footnote $ 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 - ] - - failure + 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/Internal/Monad.hs b/clash-testbench/src/Clash/Testbench/Internal/Monad.hs index c1a5830790..057be20f1c 100644 --- a/clash-testbench/src/Clash/Testbench/Internal/Monad.hs +++ b/clash-testbench/src/Clash/Testbench/Internal/Monad.hs @@ -42,7 +42,7 @@ import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) import Data.List (partition, sort, sortBy, groupBy) import Data.Maybe (catMaybes) -import qualified Data.Map as M +import qualified Data.Map.Strict as M import qualified Data.Set as S import qualified Data.Array as A @@ -243,9 +243,9 @@ instance , signalName = name , signalUpdate = Just (writeIORef extVal . Just) , signalExpect = modifyIORef expectations . (:) - , signalVerify = \mode -> do + , signalVerify = \sMode -> Verifier $ \vMode -> do curStep <- liftIO $ readIORef simStepRef - value <- liftIO $ signalCurVal mode + value <- liftIO $ signalCurVal sMode expct <- liftIO $ readIORef expectations let @@ -253,8 +253,7 @@ instance partition (`leq` Expectation (curStep + 1, undefined)) expct liftIO $ writeIORef expectations later - mapM_ ((value &) . snd . expectation) current - + mapM_ ((`verifier` vMode) . (value &) . snd . expectation) current , signalPrint = Nothing , signalPlug = Nothing , .. @@ -449,7 +448,6 @@ initializeLiftTB name x = liftTB accInit x 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 @@ -458,13 +456,12 @@ progressCheck simStepRef initialProgress = do writeIORef simStepCache globalRef return $ globalRef > localRef - where offset | initialProgress = (+ (-1)) | otherwise = id - +-- | Creates a new 'History' container. newHistory :: TB (History a) newHistory = do @@ -474,6 +471,7 @@ newHistory = do 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 @@ -490,6 +488,8 @@ memorize History{..} value = 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 -> @@ -499,11 +499,9 @@ history s = liftIO $ readIORef historyBuffer >>= \case 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 => diff --git a/clash-testbench/src/Clash/Testbench/Internal/Signal.hs b/clash-testbench/src/Clash/Testbench/Internal/Signal.hs index 23517cbf71..2e270b2ae8 100644 --- a/clash-testbench/src/Clash/Testbench/Internal/Signal.hs +++ b/clash-testbench/src/Clash/Testbench/Internal/Signal.hs @@ -9,12 +9,12 @@ Lifted signal types and internal data structures for 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 Data.Array.IO (IOArray) -import Data.IORef (IORef) import Clash.Prelude ( KnownDomain(..), BitPack(..), SDomainConfiguration(..), NFDataX, Type , Domain, Signal, Clock, Reset, Enable @@ -23,6 +23,7 @@ import Clash.Prelude import Clash.FFI.VPI.Module (Module) import Clash.FFI.VPI.Port (Port, Direction) + import Clash.Testbench.Internal.ID -- | Test bench design stages @@ -38,12 +39,12 @@ data Stage :: Type where -- successfully. Post-processing also introduces the switch from -- 'USER' to 'FINAL' on the type level. --- | The supported simulation modes sources. -data SimMode where - Internal :: SimMode - -- ^ Internal pure Haskell based simulation - External :: SimMode - -- ^ Co-Simulation via Clash-FFI +-- | 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 @@ -53,7 +54,7 @@ type family SimModeDependent (s :: Stage) a where SimModeDependent 'USER a = SimMode -> a SimModeDependent 'FINAL a = a --- | Clash-FFI Port connector. +-- | Clash-FFI port connector data PortInterface = PortInterface { port :: Port @@ -63,24 +64,25 @@ data PortInterface = , portDirection :: Direction } --- | Clash-FFI Module connector. +-- | Clash-FFI module connector data ModuleInterface = ModuleInterface - { module_ :: Module + { 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 + { historySize :: IORef Int , historyBufferPos :: IORef Int - , historyBuffer :: IORef (Maybe (IOArray Int (Maybe a))) + , historyBuffer :: IORef (Maybe (IOArray Int (Maybe a))) } --- | Expectations on certain outputs at the given simulation step. -newtype Expectation a = Expectation { expectation :: (Int, a -> PropertyT IO ()) } +-- | 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 @@ -92,6 +94,31 @@ 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 = @@ -116,7 +143,7 @@ data TBSignal (s :: Stage) (dom :: Domain) a = , signalExpect :: Expectation a -> IO () -- ^ Registers an expectation on the content of this signal to -- be verified during simulation - , signalVerify :: SimModeDependent s (PropertyT IO ()) + , signalVerify :: SimModeDependent s Verifier -- ^ The expectation verifier , signalHistory :: History a -- ^ Bounded history of signal values diff --git a/clash-testbench/src/Clash/Testbench/Simulate.hs b/clash-testbench/src/Clash/Testbench/Simulate.hs index c2bb2c7b4a..7debd7fb4f 100644 --- a/clash-testbench/src/Clash/Testbench/Simulate.hs +++ b/clash-testbench/src/Clash/Testbench/Simulate.hs @@ -6,6 +6,7 @@ Maintainer: QBayLogic B.V. All it needs for building and running test benches that are created from Clash circuitry. -} +{-# LANGUAGE OverloadedStrings #-} module Clash.Testbench.Simulate ( TB , LiftTB((@@)) @@ -54,34 +55,52 @@ 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) + + -- | @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 :: Int -> TB a -> IO a -simulate steps testbench = do - (r, Testbench{..}) <- runTB Internal testbench - replicateM_ (steps + 1) $ do +simulate :: (MonadIO m, Verify m) => SimSettings -> TB a -> m a +simulate SimSettings{..} testbench = do + (r, Testbench{..}) <- liftIO $ runTB Internal testbench + replicateM_ (tbSimSteps + 1) $ do forM_ tbDomains $ \(d, map (tbSignalLookup !) -> xs) -> (`onAllDomainTypes` d) $ \(TBDomain{..} :: TBDomain 'FINAL dom) -> do -- i <- readIORef simStepRef forM_ xs $ onAllSignalTypes $ \s -> do - v <- signalCurVal s - case signalPrint s of + when validate $ case s of + SimSignal{..} -> verify signalVerify + _ -> return () + v <- liftIO $ signalCurVal s + when (not quietRun) $ case signalPrint s of Nothing -> return () - Just toStr -> Prelude.putStrLn . (<> toStr v) $ case s of + Just toStr -> liftIO $ Prelude.putStrLn . (<> toStr v) $ case s of IOInput{} -> "I " SimSignal{} -> "O " TBSignal{} -> "S " - modifyIORef simStepRef (+ 1) - + liftIO $ modifyIORef simStepRef (+ 1) return r --- | Turns a test bench design into a 'Hedghog.Property' using --- internal simulation. +-- | Turns a test bench design into a 'Hedgehog.Property' according to +-- the given simulation mode. tbProperty :: TB () -> Hedgehog.Property -tbProperty testbench = Hedgehog.property $ do +tbProperty = Hedgehog.property . simulate + SimSettings + { quietRun = True + , validate = True + } + +{- + (_, Testbench{..}) <- liftIO $ runTB Internal testbench replicateM_ tbSimSteps $ do forM_ tbDomains $ \(d, map (tbSignalLookup !) -> xs) -> @@ -91,7 +110,7 @@ tbProperty testbench = Hedgehog.property $ do _ -> return () liftIO $ modifyIORef simStepRef (+ 1) - +-} data VPIState = VPIState { testbench :: Testbench @@ -100,6 +119,7 @@ data VPIState = , vpiClock :: Bit , vpiSimSteps :: Int , vpiInit :: Bool + , simSettings :: SimSettings } -- | @simulate n testbench@ simulates the @testbench@, created in the @@ -110,65 +130,66 @@ data VPIState = -- environment, but must to be bound to some @ffiMain@ foreign call -- that is shipped via a shared library and executed by an external -- simulator. See Clash-FFI for more details on this. -simulateFFI :: Int -> TB a -> IO a -simulateFFI steps tb = do - (r, testbench@Testbench{..}) <- runTB External tb - - let ?testbench = testbench - - runSimAction $ do - -- print simulator info - putStrLn "[ Simulator Info ]" - Info{..} <- receiveSimulatorInfo - simPutStrLn infoProduct - simPutStrLn infoVersion - putStrLn "" - - -- print top modules - putStrLn "[ Top Modules ]" - tops' <- topModules - topNames <- mapM (receiveProperty Name) tops' - mapM_ simPutStrLn 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 = - VPIState - { vpiClock = low - , vpiSimSteps = steps - , vpiInit = True - , testbench = testbench - { tbSignals = map snd vpiSignals - , tbSignalLookup = A.array (A.bounds tbSignalLookup) vpiSignals - } - , .. - } - - putStrLn "[ Simulation start ]" - putStrLn "" - - nextCB ReadWriteSynch 0 assignInputs +simulateFFI :: MonadIO m => SimSettings -> TB a -> m a +simulateFFI simSettings tb = do + (r, testbench@Testbench{..}) <- liftIO $ runTB External tb + + let + vpiClock = low + vpiSimSteps = tbSimSteps + vpiInit = True + + let + ?state = VPIState{..} + + -- print simulator info + putStrLn "[ Simulator Info ]" + Info{..} <- liftIO $ runSimAction $ receiveSimulatorInfo + putStrLn infoProduct + putStrLn infoVersion + putStrLn "" + + -- print top modules + putStrLn "[ Top Modules ]" + tops' <- liftIO $ runSimAction $ topModules + topNames <- liftIO $ runSimAction $ 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 <- liftIO $ runSimAction $ 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 return r -assignInputs :: (?state :: VPIState) => SimAction () +assignInputs :: MonadIO m => (?state :: VPIState) => m () assignInputs = do -- SimTime time <- receiveTime Sim (Nothing @Object) -- putStrLn $ "assignInputs " <> show (time, vpiClock, vpiInit) @@ -193,10 +214,10 @@ assignInputs = do Testbench{..} = testbench assignModuleInputs :: - Typeable b => + MonadIO m => Maybe ModuleInterface -> ID () -> - SimCont b () + m () assignModuleInputs = \case Nothing -> const $ return () Just ModuleInterface{..} -> \sid@(SomeID x) -> @@ -213,11 +234,13 @@ assignInputs = do liftIO (signalCurVal s) >>= \v -> do sendV port v - sendV :: (BitPack a, Typeable b) => Port -> a -> SimCont b () - sendV port v = do - sendValue port (BitVectorVal SNat $ pack v) $ InertialDelay $ SimTime 0 + sendV :: (BitPack a, MonadIO m) => Port -> a -> m () + sendV port v = + liftIO $ runSimAction $ + sendValue port (BitVectorVal SNat $ pack v) + $ InertialDelay $ SimTime 0 -readOutputs :: (?state :: VPIState) => SimAction () +readOutputs :: (?state :: VPIState, MonadIO m, Verify m) => m () readOutputs = do -- SimTime time <- receiveTime Sim (Nothing @Object) -- putStrLn $ "readOutputs " <> show time @@ -229,19 +252,23 @@ readOutputs = do 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" + liftIO $ runSimAction $ + 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 i <- liftIO $ readIORef simStepRef when (i > 0) $ forM_ xs $ onAllSignalTypes $ \s -> do + when validate $ case s of + SimSignal{..} -> verify signalVerify + _ -> return () v <- liftIO $ signalCurVal s - case signalPrint s of + when (not quietRun) $ case signalPrint s of Nothing -> return () - Just toStr -> putStrLn . (<> toStr v) $ case s of + Just toStr -> putStrLn . B.pack . (<> toStr v) $ case s of IOInput{} -> "I " SimSignal{} -> "O " TBSignal{} -> "S " @@ -260,15 +287,16 @@ readOutputs = do where VPIState{..} = ?state + SimSettings{..} = simSettings Testbench{..} = testbench matchModule :: - (?testbench :: Testbench, KnownDomain dom, BitPack a, Typeable b) => - Module -> TBSignal 'FINAL dom a -> SimCont b (TBSignal 'FINAL dom a) + (?state :: VPIState, KnownDomain dom, BitPack a, MonadIO m) => + Module -> TBSignal 'FINAL dom a -> m (TBSignal 'FINAL dom a) matchModule module_ = \case tbs@SimSignal{..} -> do - ports <- modulePorts module_ - dirs <- mapM direction ports + ports <- liftIO $ runSimAction $ modulePorts module_ + dirs <- liftIO $ runSimAction $ mapM direction ports let inputPorts = map fst $ filter (isInput . snd) $ zip ports dirs @@ -282,7 +310,7 @@ matchModule module_ = \case ) outputPort <- case outputPorts of - [p] -> do + [p] -> liftIO $ runSimAction $ do portNameBS <- receiveProperty Name p portSize <- fromEnum <$> getProperty Size p portIndex <- fromEnum <$> getProperty PortIndex p @@ -309,11 +337,11 @@ matchModule module_ = \case _ -> False matchPort :: - (?testbench :: Testbench, Typeable b) => - Module -> (ID (), Maybe Port) -> SimCont b (ID (), PortInterface) + (?state :: VPIState, MonadIO m) => + Module -> (ID (), Maybe Port) -> m (ID (), PortInterface) matchPort m = \case - (_, Nothing) -> error "Not enough ports" - (sid, Just p) -> do + (_, 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 @@ -328,7 +356,8 @@ matchPort m = \case return (sid, PortInterface{..}) where - Testbench{..} = ?testbench + VPIState{..} = ?state + Testbench{..} = testbench match :: forall b. Int -> Int -> String -> String -> SimCont b () match n k tName pName = @@ -367,22 +396,33 @@ getByName m name = do --putStr :: String -> SimCont a () --putStr = simPutStr . B.pack -putStrLn :: String -> SimCont a () -putStrLn = simPutStrLn . B.pack +putStrLn :: (?state :: VPIState, MonadIO m) => B.ByteString -> m () +putStrLn = liftIO . when (not quietRun) . runSimAction . simPutStrLn + where + VPIState{..} = ?state + SimSettings{..} = simSettings --print :: Show a => a -> SimCont b () --print = simPutStrLn . B.pack . show nextCB :: + MonadIO m => (Maybe Object -> Time -> CallbackReason) -> Int64 -> - SimAction () -> - SimAction () + IO () -> + m () nextCB reason time action = - void $ registerCallback + void $ liftIO $ runSimAction $ registerCallback CallbackInfo { cbReason = reason Nothing (SimTime time) - , cbRoutine = const (runSimAction action >> return 0) + , cbRoutine = const (action >> return 0) , cbIndex = 0 , cbData = B.empty } + +tbPropertyFFI :: TB () -> Hedgehog.Property +tbPropertyFFI = Hedgehog.property . simulate + SimSettings + { quietRun = True + , validate = True + } From ad42dc5f92f7cee6529e8e2b7e8db8555840d5c1 Mon Sep 17 00:00:00 2001 From: Felix Klein Date: Thu, 29 Jun 2023 14:43:47 +0200 Subject: [PATCH 9/9] Hedgehog Integration (WIP) --- clash-testbench/clash-testbench.cabal | 1 + clash-testbench/example/Main.hs | 64 ++++- clash-testbench/example/Register.hs | 15 ++ clash-testbench/example/RegisterFail.hs | 31 +++ clash-testbench/example/cabal.project | 3 + .../example/clash-testbench-example.cabal | 8 +- clash-testbench/example/run-iverilog.sh | 6 +- .../src/Clash/Testbench/Generate.hs | 112 ++++---- .../src/Clash/Testbench/Internal/Monad.hs | 60 ++--- .../src/Clash/Testbench/Simulate.hs | 251 +++++++++++------- clash-testbench/src/Control/Monad/Extra.hs | 24 ++ 11 files changed, 375 insertions(+), 200 deletions(-) create mode 100644 clash-testbench/example/Register.hs create mode 100644 clash-testbench/example/RegisterFail.hs create mode 100644 clash-testbench/src/Control/Monad/Extra.hs diff --git a/clash-testbench/clash-testbench.cabal b/clash-testbench/clash-testbench.cabal index b7ada3abd4..95c8162b1d 100644 --- a/clash-testbench/clash-testbench.cabal +++ b/clash-testbench/clash-testbench.cabal @@ -43,6 +43,7 @@ library Clash.Testbench.Internal.ID Clash.Testbench.Internal.Signal Clash.Testbench.Internal.Monad + Control.Monad.Extra build-depends: base, mtl, diff --git a/clash-testbench/example/Main.hs b/clash-testbench/example/Main.hs index 6798f1b021..d088d0d7a3 100644 --- a/clash-testbench/example/Main.hs +++ b/clash-testbench/example/Main.hs @@ -1,21 +1,28 @@ {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} module Main where import Data.Bool (bool) -import Clash.Prelude (Signed) +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 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 @@ -43,17 +50,62 @@ genIO = do myTestbench :: TB () myTestbench = mdo --- input <- fromList Pop [Imm 1, Push, Imm 2, Push, Pop, Pop, Pop, ADD] - input <- matchIOGenN output genIO + 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 38 myTestbench +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 = simulateFFI 38 myTestbench +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/cabal.project b/clash-testbench/example/cabal.project index 7c3861ca2f..220cf06d39 100644 --- a/clash-testbench/example/cabal.project +++ b/clash-testbench/example/cabal.project @@ -1,3 +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 index 2aa14f9163..00163139ee 100644 --- a/clash-testbench/example/clash-testbench-example.cabal +++ b/clash-testbench/example/clash-testbench-example.cabal @@ -14,7 +14,7 @@ category: Hardware common basic-config default-language: Haskell2010 ghc-options: - -Wall -Wcompat + -Wall -Wcompat -threaded -fplugin GHC.TypeLits.Extra.Solver -fplugin GHC.TypeLits.Normalise -fplugin GHC.TypeLits.KnownNat.Solver @@ -39,13 +39,19 @@ 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 index 1c746448ba..8b19ff42b4 100755 --- a/clash-testbench/example/run-iverilog.sh +++ b/clash-testbench/example/run-iverilog.sh @@ -26,9 +26,11 @@ VVP=vvp ${CABAL} build clash-testbench-example || exit $? ${CLASH} --verilog Calculator.hs || exit $? -${IVERILOG} verilog/Calculator.topEntity/topEntity.v -o Calculator.vvp \ +${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 Calculator.vvp +${VVP} -Mlib -mlibsimulate-ffi Register.vvp diff --git a/clash-testbench/src/Clash/Testbench/Generate.hs b/clash-testbench/src/Clash/Testbench/Generate.hs index 6ba21426d2..a3b48ac66e 100644 --- a/clash-testbench/src/Clash/Testbench/Generate.hs +++ b/clash-testbench/src/Clash/Testbench/Generate.hs @@ -12,6 +12,7 @@ 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) @@ -33,24 +34,21 @@ generate gen = do TBDomain{..} <- tbDomain @dom vRef <- liftIO $ newIORef undefined - checkForProgress <- progressCheck simStepRef True + ifProgress <- progressCheck simStepRef True signalHistory <- newHistory mind SomeSignal IOInput { signalId = NoID - , signalCurVal = const $ do - progress <- checkForProgress - - if progress - then do + , signalCurVal = const $ ifProgress + do x <- sample gen writeIORef vRef x memorize signalHistory x return x - else + <:> readIORef vRef , signalPrint = Nothing - ,.. + , .. } -- | Extended version of 'generate', which allows to generate a finite @@ -65,28 +63,24 @@ generateN def gen = do TBDomain{..} <- tbDomain @dom vRef <- liftIO $ newIORef [def] - checkForProgress <- progressCheck simStepRef False + ifProgress <- progressCheck simStepRef False signalHistory <- newHistory mind SomeSignal IOInput { signalId = NoID - , signalCurVal = const $ do - progress <- checkForProgress - - if progress - then - 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" - else readIORef vRef >>= \case + , 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 @@ -107,22 +101,19 @@ matchIOGen checkedOutput gen = do TBDomain{..} <- tbDomain @dom vRef <- liftIO $ newIORef undefined - checkForProgress <- progressCheck simStepRef False + ifProgress <- progressCheck simStepRef False signalHistory <- newHistory mind SomeSignal $ IOInput { signalId = NoID - , signalCurVal = const $ do - progress <- checkForProgress - - if progress - then do + , signalCurVal = const $ ifProgress + do (input, expectedOutput) <- sample gen curStep <- readIORef simStepRef signalExpect checkedOutput $ Expectation (curStep, verifier expectedOutput) writeIORef vRef input return input - else + <:> readIORef vRef , signalPrint = Nothing , .. @@ -157,42 +148,37 @@ matchIOGenN checkedOutput gen = mdo xs <- liftIO $ sample gen modify $ \st@ST{..} -> st { simSteps = max simSteps $ length xs } - liftIO $ Prelude.print xs vRef <- liftIO $ newIORef xs - checkForProgress <- progressCheck simStepRef False + ifProgress <- progressCheck simStepRef False signalHistory <- newHistory s <- mind SomeSignal $ IOInput { signalId = NoID - , signalCurVal = const $ do - progress <- checkForProgress - - readIORef vRef >>= - if progress - then \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" - else \case - (i, _) : _ -> return i - [] -> do - (i, o) : xr <- sample gen - writeIORef vRef ((i, o) : xr) - Prelude.print $ (i, o) : xr - return i + , 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 , .. } diff --git a/clash-testbench/src/Clash/Testbench/Internal/Monad.hs b/clash-testbench/src/Clash/Testbench/Internal/Monad.hs index 057be20f1c..265c90e4d5 100644 --- a/clash-testbench/src/Clash/Testbench/Internal/Monad.hs +++ b/clash-testbench/src/Clash/Testbench/Internal/Monad.hs @@ -33,6 +33,7 @@ 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) @@ -191,6 +192,7 @@ type LiftTBSignalConstraints domA domB a a' = ( KnownDomain domA, KnownDomain domB , domA ~ domB, a ~ a' , NFDataX a, BitPack a + , Show a ) instance @@ -210,18 +212,14 @@ instance -- first call to `signalCurVal`, which is required for the first -- continuation transformation to be applied on the initial -- values. - checkForProgress <- progressCheck simStepRef True + ifProgress <- progressCheck simStepRef True vRef <- liftIO $ newIORef undefined signalHistory <- newHistory let signalCurVal = \case - Internal -> do - progress <- checkForProgress - - if progress - then do - -- progress on the signal + Internal -> ifProgress + do (head# -> x, step) <- cont writeIORef vRef x modifyIORef sfRef $ step tail# @@ -230,12 +228,14 @@ instance memorize signalHistory x return x - else + <:> readIORef vRef External -> readIORef extVal >>= \case Nothing -> error "No Value @Signal" - Just x -> return x + Just x -> ifProgress + memorize signalHistory x >> return x + <:> return x mind SomeSignal $ Internal.SimSignal { signalId = NoID @@ -246,13 +246,13 @@ instance , signalVerify = \sMode -> Verifier $ \vMode -> do curStep <- liftIO $ readIORef simStepRef value <- liftIO $ signalCurVal sMode - expct <- liftIO $ readIORef expectations + expcts <- liftIO $ readIORef expectations - let - (current, later) = - partition (`leq` Expectation (curStep + 1, undefined)) expct + let sepAt n = partition (`leq` Expectation (n, undefined)) + (xs, later) = sepAt curStep expcts + (_, current) = sepAt (curStep - 1) xs - liftIO $ writeIORef expectations later + liftIO $ writeIORef expectations (current <> later) mapM_ ((`verifier` vMode) . (value &) . snd . expectation) current , signalPrint = Nothing , signalPlug = Nothing @@ -329,20 +329,18 @@ instance resetId <- nextFreeID ResetID extVal <- liftIO $ newIORef Nothing signalRef <- liftIO $ newIORef $ unsafeFromReset reset - checkForProgress <- progressCheck simStepRef False + ifProgress <- progressCheck simStepRef False let resetCurVal = \case Internal -> do x :- xr <- readIORef signalRef - progress <- checkForProgress - - if progress - then do - writeIORef signalRef xr - return $ head# xr - else - return x + ifProgress + do + writeIORef signalRef xr + return $ head# xr + <:> + return x External -> readIORef extVal >>= \case Nothing -> error "No Value @Reset" @@ -385,20 +383,18 @@ instance enableId <- nextFreeID EnableID extVal <- liftIO $ newIORef Nothing signalRef <- liftIO $ newIORef (fromEnable enable) - checkForProgress <- progressCheck simStepRef False + ifProgress <- progressCheck simStepRef False let enableCurVal = \case Internal -> do x :- xr <- readIORef signalRef - progress <- checkForProgress - - if progress - then do - writeIORef signalRef xr - return $ head# xr - else - return x + ifProgress + do + writeIORef signalRef xr + return $ head# xr + <:> + return x External -> readIORef extVal >>= \case Nothing -> error "No Value @Enable" diff --git a/clash-testbench/src/Clash/Testbench/Simulate.hs b/clash-testbench/src/Clash/Testbench/Simulate.hs index 7debd7fb4f..b8f6f36a29 100644 --- a/clash-testbench/src/Clash/Testbench/Simulate.hs +++ b/clash-testbench/src/Clash/Testbench/Simulate.hs @@ -6,23 +6,30 @@ Maintainer: QBayLogic B.V. All it needs for building and running test benches that are created from Clash circuitry. -} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Clash.Testbench.Simulate ( TB , LiftTB((@@)) + , SimSettings(..) , simulate , simulateFFI , tbProperty + , tbPropertyFFI + , ffiCheckGroup + , ffiHedgehog ) where -import Prelude hiding (putStrLn) -import qualified Prelude (putStrLn) +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, property) +import qualified Hedgehog (Property, Group, property, checkSequential) import Data.Array ((!)) import Data.Coerce (Coercible) @@ -44,9 +51,9 @@ import Clash.Prelude import Clash.FFI.Monad import Clash.FFI.VPI.Info -import Clash.FFI.VPI.IO 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 @@ -63,6 +70,36 @@ data SimSettings = } 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. @@ -70,12 +107,12 @@ data SimSettings = -- 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{..} testbench = do +simulate simSettings@SimSettings{..} testbench = do + let ?settings = simSettings (r, Testbench{..}) <- liftIO $ runTB Internal testbench - replicateM_ (tbSimSteps + 1) $ do + replicateM_ tbSimSteps $ do forM_ tbDomains $ \(d, map (tbSignalLookup !) -> xs) -> (`onAllDomainTypes` d) $ \(TBDomain{..} :: TBDomain 'FINAL dom) -> do --- i <- readIORef simStepRef forM_ xs $ onAllSignalTypes $ \s -> do when validate $ case s of SimSignal{..} -> verify signalVerify @@ -83,15 +120,15 @@ simulate SimSettings{..} testbench = do v <- liftIO $ signalCurVal s when (not quietRun) $ case signalPrint s of Nothing -> return () - Just toStr -> liftIO $ Prelude.putStrLn . (<> toStr v) $ case s of + 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' according to --- the given simulation mode. +-- | Turns a test bench design into a 'Hedgehog.Property' to be +-- simulated with Haskell. tbProperty :: TB () -> Hedgehog.Property tbProperty = Hedgehog.property . simulate SimSettings @@ -99,18 +136,6 @@ tbProperty = Hedgehog.property . simulate , validate = True } -{- - - (_, Testbench{..}) <- liftIO $ runTB Internal testbench - replicateM_ tbSimSteps $ do - forM_ tbDomains $ \(d, map (tbSignalLookup !) -> xs) -> - (`onAllDomainTypes` d) $ \(TBDomain{..} :: TBDomain 'FINAL dom) -> do - forM_ xs $ onAllSignalTypes $ \case - SimSignal{..} -> signalVerify - _ -> return () - - liftIO $ modifyIORef simStepRef (+ 1) --} data VPIState = VPIState { testbench :: Testbench @@ -119,40 +144,77 @@ data VPIState = , vpiClock :: Bit , vpiSimSteps :: Int , vpiInit :: Bool - , simSettings :: SimSettings + , 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 some @ffiMain@ foreign call --- that is shipped via a shared library and executed by an external --- simulator. See Clash-FFI for more details on this. -simulateFFI :: MonadIO m => SimSettings -> TB a -> m a -simulateFFI simSettings tb = do +-- 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 () - let - vpiClock = low - vpiSimSteps = tbSimSteps - vpiInit = True + return r - let - ?state = VPIState{..} +-- | 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{..} <- liftIO $ runSimAction $ receiveSimulatorInfo + Info{..} <- receiveSimulatorInfo putStrLn infoProduct putStrLn infoVersion putStrLn "" -- print top modules putStrLn "[ Top Modules ]" - tops' <- liftIO $ runSimAction $ topModules - topNames <- liftIO $ runSimAction $ mapM (receiveProperty Name) tops' + tops' <- topModules + topNames <- mapM (receiveProperty Name) tops' mapM_ putStrLn topNames putStrLn "" @@ -161,7 +223,7 @@ simulateFFI simSettings tb = do -- 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 <- liftIO $ runSimAction $ M.fromList + topM <- M.fromList <$> mapM (\x -> (B.unpack x, ) <$> findTopModule x) topNames -- add the VPI module references to the signals @@ -176,7 +238,7 @@ simulateFFI simSettings tb = do let ?state = ?state - { testbench = testbench + { testbench = testbench { tbSignals = map snd vpiSignals , tbSignalLookup = A.array (A.bounds tbSignalLookup) vpiSignals } @@ -186,10 +248,11 @@ simulateFFI simSettings tb = do putStrLn "" nextCB ReadWriteSynch 0 assignInputs + where + VPIState{..} = ?state + Testbench{..} = testbench - return r - -assignInputs :: MonadIO m => (?state :: VPIState) => m () +assignInputs :: (?state :: VPIState, ?settings :: SimSettings) => SimAction () assignInputs = do -- SimTime time <- receiveTime Sim (Nothing @Object) -- putStrLn $ "assignInputs " <> show (time, vpiClock, vpiInit) @@ -200,12 +263,11 @@ assignInputs = do SimSignal{..} -> mapM_ (assignModuleInputs signalPlug) signalDeps _ -> return () - let ?state = ?state { vpiClock = complement vpiClock , vpiInit = False } - if vpiClock == high || vpiInit + if vpiClock == high then nextCB ReadWriteSynch 1 assignInputs else nextCB ReadOnlySynch 1 readOutputs @@ -214,10 +276,9 @@ assignInputs = do Testbench{..} = testbench assignModuleInputs :: - MonadIO m => + Typeable b => Maybe ModuleInterface -> - ID () -> - m () + ID () -> SimCont b () assignModuleInputs = \case Nothing -> const $ return () Just ModuleInterface{..} -> \sid@(SomeID x) -> @@ -234,37 +295,38 @@ assignInputs = do liftIO (signalCurVal s) >>= \v -> do sendV port v - sendV :: (BitPack a, MonadIO m) => Port -> a -> m () + 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, MonadIO m, Verify m) => m () +readOutputs :: (?state :: VPIState, ?settings :: SimSettings) => SimAction () readOutputs = do -- SimTime time <- receiveTime Sim (Nothing @Object) -- putStrLn $ "readOutputs " <> show time - forM_ tbDomains $ \(d, map (tbSignalLookup !) -> xs) -> + 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{..} -> - liftIO $ runSimAction $ - 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" + 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 - i <- liftIO $ readIORef simStepRef - when (i > 0) $ forM_ xs $ onAllSignalTypes $ \s -> do - when validate $ case s of - SimSignal{..} -> verify signalVerify - _ -> return () + 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 () @@ -272,31 +334,48 @@ readOutputs = do IOInput{} -> "I " SimSignal{} -> "O " TBSignal{} -> "S " + return failure -- proceed time for all instances not running trough Clash-FFI - liftIO $ modifyIORef simStepRef (+ 1) + unless failure + $ liftIO $ modifyIORef simStepRef (+ 1) + return failure + + if failure then do + putStrLn "" + putStrLn "[ Simulation failed ]" - if vpiSimSteps > 0 then do + 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{..} = simSettings + SimSettings{..} = ?settings Testbench{..} = testbench matchModule :: - (?state :: VPIState, KnownDomain dom, BitPack a, MonadIO m) => - Module -> TBSignal 'FINAL dom a -> m (TBSignal 'FINAL dom a) + ( ?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 <- liftIO $ runSimAction $ modulePorts module_ - dirs <- liftIO $ runSimAction $ mapM direction ports + ports <- modulePorts module_ + dirs <- mapM direction ports let inputPorts = map fst $ filter (isInput . snd) $ zip ports dirs @@ -310,7 +389,7 @@ matchModule module_ = \case ) outputPort <- case outputPorts of - [p] -> liftIO $ runSimAction $ do + [p] -> do portNameBS <- receiveProperty Name p portSize <- fromEnum <$> getProperty Size p portIndex <- fromEnum <$> getProperty PortIndex p @@ -337,8 +416,8 @@ matchModule module_ = \case _ -> False matchPort :: - (?state :: VPIState, MonadIO m) => - Module -> (ID (), Maybe Port) -> m (ID (), PortInterface) + (?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 @@ -393,36 +472,16 @@ getByName m name = do liftIO $ free ref return obj ---putStr :: String -> SimCont a () ---putStr = simPutStr . B.pack - -putStrLn :: (?state :: VPIState, MonadIO m) => B.ByteString -> m () -putStrLn = liftIO . when (not quietRun) . runSimAction . simPutStrLn - where - VPIState{..} = ?state - SimSettings{..} = simSettings - ---print :: Show a => a -> SimCont b () ---print = simPutStrLn . B.pack . show - nextCB :: - MonadIO m => (Maybe Object -> Time -> CallbackReason) -> Int64 -> - IO () -> - m () + SimAction () -> + SimAction () nextCB reason time action = void $ liftIO $ runSimAction $ registerCallback CallbackInfo { cbReason = reason Nothing (SimTime time) - , cbRoutine = const (action >> return 0) + , cbRoutine = const (runSimAction action >> return 0) , cbIndex = 0 , cbData = B.empty } - -tbPropertyFFI :: TB () -> Hedgehog.Property -tbPropertyFFI = Hedgehog.property . simulate - SimSettings - { quietRun = True - , validate = True - } 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) +(<:>) = (,)