From 20bd0d1d0ae28818f7a796b635fc80f7a463b80f Mon Sep 17 00:00:00 2001 From: Felix Klein Date: Fri, 24 Feb 2023 11:37:49 +0100 Subject: [PATCH 1/5] Make clash-ffi a haskell library --- clash-ffi/clash-ffi.cabal | 48 +++++--------------------------- clash-ffi/src/Clash/FFI/Monad.hs | 2 +- 2 files changed, 8 insertions(+), 42 deletions(-) diff --git a/clash-ffi/clash-ffi.cabal b/clash-ffi/clash-ffi.cabal index a4a7e5a919..29ecb46fe9 100644 --- a/clash-ffi/clash-ffi.cabal +++ b/clash-ffi/clash-ffi.cabal @@ -11,11 +11,9 @@ author: QBayLogic B.V. maintainer: devops@qbaylogic.com copyright: Copyright © 2022, QBayLogic B.V. category: Hardware -build-type: Custom -common basic-config +library default-language: Haskell2010 - default-extensions: BangPatterns DeriveAnyClass @@ -24,13 +22,8 @@ common basic-config GeneralizedNewtypeDeriving ScopedTypeVariables TypeApplications - - include-dirs: - include - ghc-options: -Wall -Wcompat - build-depends: base >= 4.11 && < 4.17, bytestring >= 0.10 && < 0.12, @@ -39,22 +32,13 @@ common basic-config derive-storable >= 0.3 && < 0.4, derive-storable-plugin >= 0.2 && < 0.3, mtl >= 2.2 && < 2.3, - - other-modules: + hs-source-dirs: src + include-dirs: include + includes: vpi_user.h + c-sources: cbits/entry_vpi.c + exposed-modules: Clash.FFI.Monad Clash.FFI.View - -common vpi-config - includes: - vpi_user.h - - c-sources: - cbits/entry_vpi.c - - cpp-options: - -DVERILOG=1 - - other-modules: Clash.FFI.VPI.Callback Clash.FFI.VPI.Callback.Reason Clash.FFI.VPI.Control @@ -80,26 +64,8 @@ common vpi-config Clash.FFI.VPI.Port Clash.FFI.VPI.Port.Direction Clash.FFI.VPI.Reg - -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, - --- To accomodate differences between different simulators when defining the --- generic interface, different foreign libraries are produced for each tool. --- The code is shared between all simulators and each library defines it's name --- and includes the source files it needs for it's interface. - -foreign-library clash-iverilog-vpi - import: basic-config, vpi-config - type: native-shared - lib-version-info: 0:1:0 - hs-source-dirs: src - cpp-options: + -DVERILOG=1 -DIVERILOG=1 -DVERILOG_2001=1 -DVERILOG_2005=1 diff --git a/clash-ffi/src/Clash/FFI/Monad.hs b/clash-ffi/src/Clash/FFI/Monad.hs index 5fa9154f9c..a764a19764 100644 --- a/clash-ffi/src/Clash/FFI/Monad.hs +++ b/clash-ffi/src/Clash/FFI/Monad.hs @@ -69,7 +69,7 @@ same way, e.g. -- 'runSimAction'. -- newtype SimCont o i = SimCont (ContT o IO i) - deriving newtype (Applicative, Functor, Monad, MonadCont, MonadIO) + deriving newtype (Applicative, Functor, Monad, MonadCont, MonadIO, MonadFail) -- | The type of an VPI "main" action run in @clash-ffi@. For the more general -- type of FFI computations, use 'SimCont'. From ef30b98015e07c1137d917821de37cdc6a8075e0 Mon Sep 17 00:00:00 2001 From: Felix Klein Date: Mon, 27 Feb 2023 08:24:28 +0100 Subject: [PATCH 2/5] Document clash-ffi usage as haskell library --- clash-ffi/README.md | 56 +++++++++++++++++++++++++++++++++++++-------- 1 file changed, 46 insertions(+), 10 deletions(-) diff --git a/clash-ffi/README.md b/clash-ffi/README.md index 365816f4ae..6c34b3aae9 100644 --- a/clash-ffi/README.md +++ b/clash-ffi/README.md @@ -9,16 +9,51 @@ a standard interface (e.g. VPI / VHPI / FLI). Currently only VPI is supported. All interaction with a simulator follows the same general process: - * the Haskell code performing the FFI is compiled as a shared library. Any - libraries specified as `foreign-library` in `clash-ffi.cabal` are copied - into a `lib/` directory in the project on successful build. Haskell FFI - code *must* export the entry point + * The Haskell code performing the FFI is compiled as a foreign + shared library. To this end, your project's cabal must be extended + by a `foreign-library` section, e.g., + + ```cabal + foreign-library + default-language: Haskell2010 + includes: vpi_user.h + include-dirs: + build-depends: clash-ffi, + ... + type: native-shared + lib-version-info: 0:1:0 + cpp-options: -DVERILOG=1 -DIVERILOG=1 -DVERILOG_2001=1 -DVERILOG_2005=1 -DVPI_VECVAL=1 + ... + ``` - ```c - void clash_ffi_main(void); + See `vpi_user.h` for more details on the possible + `cpp-options`. You can either use the `vpi_user.h`, which is + shipped with this project, (see the `include` directory) or the + one that's usually provided by the simulator. Note that + `clash-ffi` gets included just like any other standard Haskell + library to your project at this point. + + * Cabal creates libraries in some hard to access nested + sub-directory with a file ending that depends on your operating + systems, which is not well suited for the usage in the context of + VPI. To get around this, we recommend adding a custom setup to + your cabal file: + + ```cabal + custom-setup + setup-depends: base, Cabal, directory, filepath ``` - This requires a foreign export in user code, i.e. + that uses the `Setup.hs` of this project (copied to your project's + root). This custom setup places the created foreign library into a + `lib` folder created under your project's root and renames the + file accordingly. It is important that the library has a `.vpl` + ending to be used by a VPI simulator in the end. + + * From this point on, development of your `foreign-library` works + like for a normal Haskell library. For interfacing with the + simulator, you just need to have one exposed module within your + setup that exports the Clash FFI entry point: ```haskell foreign export ccall "clash_ffi_main" @@ -28,9 +63,10 @@ All interaction with a simulator follows the same general process: ffiMain = -- Some FFI code ``` - This main action is run during the start-of-simulation callback from VPI. - This means while it can register new callbacks, it should not run forever - as doing so would mean control is never returned to the simulator. + This main action is run during the start-of-simulation callback of + the simulator. This means while it can register new callbacks, it + should not run forever as doing so would mean control is never + returned to the simulator. * The simulator is started with flags which load the library. For instance, with `iverilog` the simulator is invoked with a command similar to From e0fa88ddb1fd16f907461e10af70723b7aecc670 Mon Sep 17 00:00:00 2001 From: Felix Klein Date: Sat, 25 Feb 2023 06:27:25 +0100 Subject: [PATCH 3/5] Fix time value calculation --- clash-ffi/src/Clash/FFI/VPI/Object/Time.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/clash-ffi/src/Clash/FFI/VPI/Object/Time.hs b/clash-ffi/src/Clash/FFI/VPI/Object/Time.hs index a6ceda1fea..0d877bde5f 100644 --- a/clash-ffi/src/Clash/FFI/VPI/Object/Time.hs +++ b/clash-ffi/src/Clash/FFI/VPI/Object/Time.hs @@ -20,7 +20,7 @@ module Clash.FFI.VPI.Object.Time ) where import Control.Exception (Exception) -import Data.Bits ((.|.), unsafeShiftL, unsafeShiftR) +import Data.Bits ((.|.), (.&.), unsafeShiftL, unsafeShiftR) import Data.Int (Int64) import Foreign.C.Types (CDouble(..), CInt(..), CUInt(..)) import Foreign.Storable.Generic (GStorable) @@ -111,8 +111,8 @@ type instance CRepr Time = CTime instance Send Time where send = \case SimTime int -> - let high = fromIntegral ((int `unsafeShiftR` 32) .|. 0xffffffff) - low = fromIntegral (int .|. 0xffffffff) + let high = fromIntegral ((int `unsafeShiftR` 32) .&. 0xffffffff) + low = fromIntegral (int .&. 0xffffffff) in CTime <$> send Sim <*> pure high <*> pure low <*> pure 0.0 RealTime real -> From e0a0a428c13baed9104a4d030069265f45fe4ce8 Mon Sep 17 00:00:00 2001 From: Felix Klein Date: Mon, 27 Feb 2023 15:40:16 +0100 Subject: [PATCH 4/5] Add clash-ffi example project --- .ci/gitlab/test.yml | 6 + clash-ffi/README.md | 18 +- clash-ffi/example/LICENSE | 22 ++ clash-ffi/{ => example}/Setup.hs | 0 clash-ffi/example/Simulate.hs | 258 ++++++++++++++++++++++ clash-ffi/example/cabal.project | 1 + clash-ffi/example/clash-ffi-example.cabal | 60 +++++ clash-ffi/example/run-iverilog.sh | 36 +++ 8 files changed, 396 insertions(+), 5 deletions(-) create mode 100644 clash-ffi/example/LICENSE rename clash-ffi/{ => example}/Setup.hs (100%) create mode 100644 clash-ffi/example/Simulate.hs create mode 100644 clash-ffi/example/cabal.project create mode 100644 clash-ffi/example/clash-ffi-example.cabal create mode 100755 clash-ffi/example/run-iverilog.sh diff --git a/.ci/gitlab/test.yml b/.ci/gitlab/test.yml index 6976374fb7..ca5e9d61be 100644 --- a/.ci/gitlab/test.yml +++ b/.ci/gitlab/test.yml @@ -133,6 +133,12 @@ suite:cores: - local - vivado-2022.1-standard +ffi:example: + extends: .test-cache-local + script: + - cabal build clash # ensure clash has been built (avoids some legacy cabal issue) + - cd clash-ffi/example && ./run-iverilog.sh + # Tests run on local fast machines with Vivado installed. We only run these at night # to save resources - as Vivado is quite slow to execute. diff --git a/clash-ffi/README.md b/clash-ffi/README.md index 6c34b3aae9..2b2bc13bae 100644 --- a/clash-ffi/README.md +++ b/clash-ffi/README.md @@ -44,11 +44,12 @@ All interaction with a simulator follows the same general process: setup-depends: base, Cabal, directory, filepath ``` - that uses the `Setup.hs` of this project (copied to your project's - root). This custom setup places the created foreign library into a - `lib` folder created under your project's root and renames the - file accordingly. It is important that the library has a `.vpl` - ending to be used by a VPI simulator in the end. + using the `Setup.hs` of the example project in the `example` + folder (copied to your project's root). This custom setup places + the created foreign library into a `lib` folder created under your + project's root and renames the file accordingly. It is important + that the library has a `.vpl` ending to be used by a VPI simulator + in the end. * From this point on, development of your `foreign-library` works like for a normal Haskell library. For interfacing with the @@ -75,6 +76,13 @@ All interaction with a simulator follows the same general process: vvp -L lib -l libclashffi-iverilog-vpi MODULE.vvp ``` + * The `example` folder contains a minimalistic project utilizing + `clash-ffi`. Check the `run-iverilog.sh` script in the folder for + a quick overview of how to use `clash-ffi`. The script may be + executed within the `examples` folder. If it does not work for you + out-of-the-box, feel free to adapted it according to your local + setup. + ## Supported API Functions ### VPI diff --git a/clash-ffi/example/LICENSE b/clash-ffi/example/LICENSE new file mode 100644 index 0000000000..6ee2532a74 --- /dev/null +++ b/clash-ffi/example/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2022 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-ffi/Setup.hs b/clash-ffi/example/Setup.hs similarity index 100% rename from clash-ffi/Setup.hs rename to clash-ffi/example/Setup.hs diff --git a/clash-ffi/example/Simulate.hs b/clash-ffi/example/Simulate.hs new file mode 100644 index 0000000000..86e12cebf7 --- /dev/null +++ b/clash-ffi/example/Simulate.hs @@ -0,0 +1,258 @@ +module Simulate where + +import Prelude hiding (Word, print, putStr, putStrLn) + +import Data.Int (Int64) +import Data.Coerce (Coercible) +import Data.Typeable (Typeable) +import Data.Bits (complement) +import Data.List (intercalate, zip5) +import Control.Monad (when, void) +import Control.Monad.IO.Class (liftIO) +import Foreign.C.String (newCString) +import Foreign.Marshal.Alloc (free) + +import qualified Data.ByteString.Char8 as B + +import Clash.Prelude + ( Lift, Generic, BitPack, Signed, Bit, SNat(..) + , low, high, pack, unpack, resize + ) + +import Clash.FFI.Monad +import Clash.FFI.VPI.Info +import Clash.FFI.VPI.IO +import Clash.FFI.VPI.Callback +import Clash.FFI.VPI.Module +import Clash.FFI.VPI.Object +import Clash.FFI.VPI.Port + +type Word = Signed 4 +data OPC a = ADD | MUL | Imm a | Pop | Push + deriving (Show, Lift, Generic, BitPack) + +data State = + State + { top :: Module + , clkIn :: Port + , rstIn :: Port + , enbIn :: Port + , dataIn :: Port + , dataOut :: Port + , steps :: Int + , clock :: Bit + } + +foreign export ccall "clash_ffi_main" + ffiMain :: IO () + +ffiMain :: IO () +ffiMain = 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. + top <- getByName (Nothing @Object) $ head topNames + + ----------------- + -- print ports -- + ----------------- + putStrLn "[ Ports ]" + ports <- modulePorts top + -- Note that values of composed types, like `String`/`CString`, must + -- be "received", while value of core types, such as `Int`/`CInt`, + -- can by "get". The reason is that "receivable" types need to be + -- memory copied on the heap, while "gettable" types live on the + -- stack. Clash-FFI only offers to either "receive" or to "get" + -- values for supported types at the moment, so take care that the + -- right methodology is used. + names <- mapM (receiveProperty Name) ports + sizes <- mapM (getProperty Size) ports + indices <- mapM (getProperty PortIndex) ports + dirs <- mapM (getProperty Direction) ports + let realNames = [ "CLK", "RST", "ENB", "OPC", "RESULT" ] + mapM_ printPort $ zip5 (map B.unpack names) sizes indices dirs realNames + putStrLn "" + + -- get long-term references for all input and output ports + [ clkIn, rstIn, enbIn, dataIn, dataOut ] <- mapM (getByName $ Just top) names + + let ?state = State {steps = 7, clock = low, ..} + + --------------------------------- + -- start the actual simulation -- + --------------------------------- + putStrLn "[ Simulation start ]" + putStrLn "" + putStrLn " STEP ; CLK ; RST ; ENB ; OPC ; RESULT" + putStrLn "------;------;------;------;----------------------;----------------------" + + void $ registerCallback + CallbackInfo + { cbReason = EndOfSimulation + , cbRoutine = const $ do + runSimAction (putStrLn "" >> putStrLn "[ Simulation done ]") + return 0 + , cbIndex = 0 + , cbData = B.empty + } + + nextCB ReadWriteSynch 0 assignInputs + + where + printPort (n, s, i, d, r) = + let str = show i <> ": " <> n <> "[" <> show (s - 1) <> ":0]" + in putStrLn $ str <> replicate (14 - length str) ' ' <> printDir d <> " " <> r + + printDir = \case + 1 -> "<=" -- input + 2 -> "=>" -- output + 3 -> "<=>" -- inout + 4 -> "<=>" -- mixed input-output + _ -> "x" -- no direction + +assignInputs :: (?state :: State) => SimAction +assignInputs = do + SimTime time <- receiveTime Sim $ Just top + + clkUpd <- sendV clkIn clock + + (rstUpd, enbUpd) <- + if clock == low && steps == 7 + then (,) <$> sendV rstIn low <*> sendV enbIn high + else (,) <$> return Nothing <*> return Nothing + + inUpd <- + if clock == low + then case steps of + 7 -> sendV dataIn (Imm 1) + 6 -> sendV dataIn Push + 5 -> sendV dataIn (Imm 2) + 4 -> sendV dataIn Push + 3 -> sendV dataIn Pop + 2 -> sendV dataIn Pop + 1 -> sendV dataIn Pop + 0 -> sendV dataIn ADD + _ -> return Nothing + else + return Nothing + + print updates { time, clkUpd, rstUpd, enbUpd, inUpd } + + let ?state = ?state { clock = complement clock } + + if clock == low + then nextCB ReadWriteSynch 1 assignInputs + else nextCB ReadOnlySynch 1 readOutputs + + where + State{..} = ?state + + sendV port v = do + sendValue port (BitVectorVal SNat $ pack v) $ InertialDelay $ SimTime 0 + return $ Just v + +readOutputs :: (?state :: State) => SimAction +readOutputs = do + SimTime time <- receiveTime Sim $ Just top + receiveValue VectorFmt dataOut >>= \case + BitVectorVal SNat v -> + print updates + { time + , outUpd = Just $ unpack $ resize v + } + _ -> return () + + when (steps > 0) $ do + let ?state = ?state { steps = steps - 1 } + nextCB ReadWriteSynch 1 assignInputs + + where + State{..} = ?state + +data Updates = + Updates + { time :: Int64 + , clkUpd :: Maybe Bit + , rstUpd :: Maybe Bit + , enbUpd :: Maybe Bit + , inUpd :: Maybe (OPC Word) + , outUpd :: Maybe (Maybe Word) + } + +instance Show Updates where + show Updates{..} = + intercalate ";" + [ " " <> (if time < 10 then " " else "") <> show time <> " " + , maybe (replicate 6 ' ') printBit clkUpd + , maybe (replicate 6 ' ') printBit rstUpd + , maybe (replicate 6 ' ') printBit enbUpd + , maybe (replicate 22 ' ') (printValue 22 " <= ") inUpd + , maybe (replicate 22 ' ') (printValue 22 " => ") outUpd + ] + where + printBit b + | b == high = " <= 1 " + | otherwise = " <= 0 " + + printValue n dir x = + let + s1 = show x <> ": " + s2 = show (pack x) <> " " + m = n - length s1 - length s2 - 4 + in + dir <> s1 <> replicate m ' ' <> s2 + +updates :: Updates +updates = Updates 0 Nothing Nothing Nothing Nothing Nothing + +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 + } + +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 -> SimAction +putStr = simPutStr . B.pack + +putStrLn :: String -> SimAction +putStrLn = simPutStrLn . B.pack + +print :: Show a => a -> SimAction +print = simPutStrLn . B.pack . show diff --git a/clash-ffi/example/cabal.project b/clash-ffi/example/cabal.project new file mode 100644 index 0000000000..875b5fa393 --- /dev/null +++ b/clash-ffi/example/cabal.project @@ -0,0 +1 @@ +packages: . .. ../../clash-ghc ../../clash-lib ../../clash-prelude diff --git a/clash-ffi/example/clash-ffi-example.cabal b/clash-ffi/example/clash-ffi-example.cabal new file mode 100644 index 0000000000..05e0e633c2 --- /dev/null +++ b/clash-ffi/example/clash-ffi-example.cabal @@ -0,0 +1,60 @@ +cabal-version: 2.4 +name: clash-ffi-example +version: 0.1.0.0 +synopsis: Example Clash-FFI project +description: Example Clash-FFI project +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 + +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, + +foreign-library clash-ffi-example + default-language: Haskell2010 + other-modules: Simulate + includes: vpi_user.h + include-dirs: ../include + type: native-shared + lib-version-info: 0:1:0 + default-extensions: + DataKinds + DeriveAnyClass + DeriveGeneric + DeriveLift + FlexibleContexts + ImplicitParams + LambdaCase + NamedFieldPuns + RecordWildCards + TupleSections + TypeApplications + ViewPatterns + NoImplicitPrelude + ghc-options: + -Wall -Wcompat + -fplugin GHC.TypeLits.Extra.Solver + -fplugin GHC.TypeLits.Normalise + -fplugin GHC.TypeLits.KnownNat.Solver + build-depends: + base, + bytestring, + clash-ffi, + clash-prelude, + ghc-typelits-extra, + ghc-typelits-knownnat, + ghc-typelits-natnormalise, + cpp-options: + -DVERILOG=1 + -DIVERILOG=1 + -DVERILOG_2001=1 + -DVERILOG_2005=1 + -DVPI_VECVAL=1 diff --git a/clash-ffi/example/run-iverilog.sh b/clash-ffi/example/run-iverilog.sh new file mode 100755 index 0000000000..a3734a3b0c --- /dev/null +++ b/clash-ffi/example/run-iverilog.sh @@ -0,0 +1,36 @@ +#!/bin/sh + +# This is just a minimalistic script for demonstrating the process of +# running the clash-ffi example using the Icarus Verilog VVP runtime +# engine. The script is not designed to work in any possible system +# environment and may not work immediatly for you. It is intended to +# serve as an easy starter instead. Adapt it too you needs if it's not +# working out-of-the-box for you. + +############################### + +# adapt 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 +# Clash examples folder +# https://github.com/clash-lang/clash-compiler/tree/master/examples +EXAMPLES=../../examples + +############################### + +${CABAL} build clash-ffi-example +${CLASH} --verilog -i${EXAMPLES} ${EXAMPLES}/Calculator.hs +${IVERILOG} verilog/Calculator.topEntity/topEntity.v -o Calculator.vvp +echo "" +echo "Running Icarus Verilog VVP runtime engine:" +echo "" +${VVP} -Mlib -mlibclash-ffi-example Calculator.vvp From cce665feb23fc9ec0494ff01701da71db0f6f34d Mon Sep 17 00:00:00 2001 From: Felix Klein Date: Fri, 17 Mar 2023 16:04:18 +0100 Subject: [PATCH 5/5] Add Clash FFI interface tests & bugfixes --- .ci/gitlab/test.yml | 5 + clash-ffi/clash-ffi.cabal | 64 +- clash-ffi/example/run-iverilog.sh | 6 +- clash-ffi/src/Clash/FFI/Monad.hs | 22 +- .../src/Clash/FFI/VPI/Callback/Reason.hs | 4 +- clash-ffi/src/Clash/FFI/VPI/Error.hs | 2 +- clash-ffi/src/Clash/FFI/VPI/IO.hs | 4 +- clash-ffi/src/Clash/FFI/VPI/Info.hs | 21 +- clash-ffi/src/Clash/FFI/VPI/Module.hs | 4 +- clash-ffi/src/Clash/FFI/VPI/Object/Value.hs | 4 +- .../src/Clash/FFI/VPI/Object/Value/Parse.hs | 43 +- .../src/Clash/FFI/VPI/Object/Value/Scalar.hs | 2 +- .../src/Clash/FFI/VPI/Object/Value/Vector.hs | 97 +- clash-ffi/src/Clash/FFI/VPI/Port/Direction.hs | 7 + clash-ffi/src/Clash/FFI/View.hs | 83 +- clash-ffi/tests/Clash/FFI/Test.hs | 240 ++++ clash-ffi/tests/Clash/FFI/Test/Instances.hs | 534 +++++++++ clash-ffi/tests/Main.hs | 387 ++++++ clash-ffi/tests/cbits/Pipe.c | 47 + clash-ffi/tests/cbits/Pipe.h | 34 + clash-ffi/tests/cbits/Print.c | 734 ++++++++++++ clash-ffi/tests/cbits/Print.h | 100 ++ clash-ffi/tests/cbits/Test.c | 53 + clash-ffi/tests/cbits/Test.h | 54 + clash-ffi/tests/cbits/VPI.c | 1055 +++++++++++++++++ 25 files changed, 3477 insertions(+), 129 deletions(-) create mode 100644 clash-ffi/tests/Clash/FFI/Test.hs create mode 100644 clash-ffi/tests/Clash/FFI/Test/Instances.hs create mode 100644 clash-ffi/tests/Main.hs create mode 100644 clash-ffi/tests/cbits/Pipe.c create mode 100644 clash-ffi/tests/cbits/Pipe.h create mode 100644 clash-ffi/tests/cbits/Print.c create mode 100644 clash-ffi/tests/cbits/Print.h create mode 100644 clash-ffi/tests/cbits/Test.c create mode 100644 clash-ffi/tests/cbits/Test.h create mode 100644 clash-ffi/tests/cbits/VPI.c diff --git a/.ci/gitlab/test.yml b/.ci/gitlab/test.yml index ca5e9d61be..153fe1c060 100644 --- a/.ci/gitlab/test.yml +++ b/.ci/gitlab/test.yml @@ -133,6 +133,11 @@ suite:cores: - local - vivado-2022.1-standard +ffi:interface-tests: + extends: .test-cache-local + script: + - ./dist-newstyle/build/*/*/clash-ffi-*/x/ffi-interface-tests/build/ffi-interface-tests/ffi-interface-tests --smallcheck-max-count 2000 + ffi:example: extends: .test-cache-local script: diff --git a/clash-ffi/clash-ffi.cabal b/clash-ffi/clash-ffi.cabal index 29ecb46fe9..9a5583fd53 100644 --- a/clash-ffi/clash-ffi.cabal +++ b/clash-ffi/clash-ffi.cabal @@ -12,14 +12,9 @@ maintainer: devops@qbaylogic.com copyright: Copyright © 2022, QBayLogic B.V. category: Hardware -library +common common-options default-language: Haskell2010 default-extensions: - BangPatterns - DeriveAnyClass - DeriveGeneric - DerivingStrategies - GeneralizedNewtypeDeriving ScopedTypeVariables TypeApplications ghc-options: @@ -29,12 +24,28 @@ library bytestring >= 0.10 && < 0.12, clash-prelude >= 1.2 && < 1.8, deepseq >= 1.4 && < 1.5, + include-dirs: include + includes: vpi_user.h + cpp-options: + -DVERILOG=1 + -DIVERILOG=1 + -DVERILOG_2001=1 + -DVERILOG_2005=1 + -DVPI_VECVAL=1 + +library + import: common-options + default-extensions: + BangPatterns + DeriveAnyClass + DeriveGeneric + DerivingStrategies + GeneralizedNewtypeDeriving + build-depends: derive-storable >= 0.3 && < 0.4, derive-storable-plugin >= 0.2 && < 0.3, mtl >= 2.2 && < 2.3, hs-source-dirs: src - include-dirs: include - includes: vpi_user.h c-sources: cbits/entry_vpi.c exposed-modules: Clash.FFI.Monad @@ -64,9 +75,34 @@ library Clash.FFI.VPI.Port Clash.FFI.VPI.Port.Direction Clash.FFI.VPI.Reg - cpp-options: - -DVERILOG=1 - -DIVERILOG=1 - -DVERILOG_2001=1 - -DVERILOG_2005=1 - -DVPI_VECVAL=1 + +executable ffi-interface-tests + import: common-options + default-extensions: + DataKinds + RankNTypes + LambdaCase + ViewPatterns + TupleSections + ImplicitParams + FlexibleContexts + FlexibleInstances + MultiParamTypeClasses + ExistentialQuantification + hs-source-dirs: tests + main-is: Main.hs + other-modules: + Clash.FFI.Test + Clash.FFI.Test.Instances + include-dirs: tests/cbits + c-sources: + tests/cbits/VPI.c + tests/cbits/Test.c + tests/cbits/Pipe.c + tests/cbits/Print.c + build-depends: + , clash-ffi + , smallcheck + , tasty + , tasty-hunit + , tasty-smallcheck diff --git a/clash-ffi/example/run-iverilog.sh b/clash-ffi/example/run-iverilog.sh index a3734a3b0c..4f57015876 100755 --- a/clash-ffi/example/run-iverilog.sh +++ b/clash-ffi/example/run-iverilog.sh @@ -3,13 +3,13 @@ # This is just a minimalistic script for demonstrating the process of # running the clash-ffi example using the Icarus Verilog VVP runtime # engine. The script is not designed to work in any possible system -# environment and may not work immediatly for you. It is intended to -# serve as an easy starter instead. Adapt it too you needs if it's not +# 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. ############################### -# adapt these variables, if the tools are not in your PATH already +# Adjust these variables if the tools are not in your PATH already # Cabal # https://www.haskell.org/cabal diff --git a/clash-ffi/src/Clash/FFI/Monad.hs b/clash-ffi/src/Clash/FFI/Monad.hs index a764a19764..a687e2f6ad 100644 --- a/clash-ffi/src/Clash/FFI/Monad.hs +++ b/clash-ffi/src/Clash/FFI/Monad.hs @@ -4,6 +4,8 @@ License: BSD2 (see the file LICENSE) Maintainer: QBayLogic B.V. -} +{-# LANGUAGE CPP #-} + module Clash.FFI.Monad ( SimCont , SimAction @@ -33,6 +35,15 @@ import Foreign.Storable (Storable) import qualified Foreign.Storable as FFI (peek) import GHC.Stack (HasCallStack) +#if MIN_VERSION_base(4,9,0) +#ifdef MIN_VERSION_GLASGOW_HASKELL +#if MIN_VERSION_GLASGOW_HASKELL(8,8,4,0) +#else +import Control.Monad.Fail (MonadFail) +#endif +#endif +#endif + {- NOTE [continuation-based API] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -69,17 +80,22 @@ same way, e.g. -- 'runSimAction'. -- newtype SimCont o i = SimCont (ContT o IO i) - deriving newtype (Applicative, Functor, Monad, MonadCont, MonadIO, MonadFail) + deriving newtype + ( Applicative, Functor, Monad, MonadCont, MonadIO +#if MIN_VERSION_base(4,9,0) + , MonadFail +#endif + ) -- | The type of an VPI "main" action run in @clash-ffi@. For the more general -- type of FFI computations, use 'SimCont'. -- -type SimAction = SimCont () () +type SimAction a = SimCont a a -- | Run a VPI "main" action. See 'SimAction' and 'SimCont' for more -- information. -- -runSimAction :: SimAction -> IO () +runSimAction :: SimAction a -> IO a runSimAction (SimCont cont) = Cont.runContT cont pure -- | Lift a continuation into a simulation FFI action. diff --git a/clash-ffi/src/Clash/FFI/VPI/Callback/Reason.hs b/clash-ffi/src/Clash/FFI/VPI/Callback/Reason.hs index 7a3c803b89..ca22553c87 100644 --- a/clash-ffi/src/Clash/FFI/VPI/Callback/Reason.hs +++ b/clash-ffi/src/Clash/FFI/VPI/Callback/Reason.hs @@ -218,7 +218,7 @@ instance UnsafeSend CallbackReason where AfterDelay mObject time -> do let object = maybe nullObject coerce mObject ctime <- pokeSend time - pure (7, object, ctime, FFI.nullPtr) + pure (9, object, ctime, FFI.nullPtr) EndOfCompile -> pure (10, nullObject, FFI.nullPtr, FFI.nullPtr) @@ -303,7 +303,7 @@ instance UnsafeSend CallbackReason where NbaSynch mObject time -> do let object = maybe nullObject coerce mObject ctime <- pokeSend time - pure (31, object, ctime, FFI.nullPtr) + pure (30, object, ctime, FFI.nullPtr) AtEndOfSimTime mObject time -> do let object = maybe nullObject coerce mObject diff --git a/clash-ffi/src/Clash/FFI/VPI/Error.hs b/clash-ffi/src/Clash/FFI/VPI/Error.hs index 80d82250c6..4ef5316e59 100644 --- a/clash-ffi/src/Clash/FFI/VPI/Error.hs +++ b/clash-ffi/src/Clash/FFI/VPI/Error.hs @@ -87,7 +87,7 @@ instance UnsafeReceive ErrorInfo where instance Receive ErrorInfo where receive cerror = do state <- receive (cerrorState cerror) - level <- receive (cerrorState cerror) + level <- receive (cerrorLevel cerror) msg <- receive (cerrorMessage cerror) prod <- receive (cerrorProduct cerror) code <- receive (cerrorCode cerror) diff --git a/clash-ffi/src/Clash/FFI/VPI/IO.hs b/clash-ffi/src/Clash/FFI/VPI/IO.hs index 80e577fd1d..f761da7882 100644 --- a/clash-ffi/src/Clash/FFI/VPI/IO.hs +++ b/clash-ffi/src/Clash/FFI/VPI/IO.hs @@ -22,7 +22,7 @@ import GHC.Stack (CallStack, HasCallStack, callStack, prettyCallStack) import Clash.FFI.Monad (SimCont) import qualified Clash.FFI.Monad as Sim (throw) -import Clash.FFI.View (unsafeSend) +import Clash.FFI.View (unsafeSend, ensureNullTerminated) foreign import ccall "vpi_user.h vpi_printf" c_vpi_printf :: CString -> IO CInt @@ -37,7 +37,7 @@ simPutStr => ByteString -> SimCont o () simPutStr = - unsafeSend >=> IO.liftIO . Monad.void . c_vpi_printf + (unsafeSend >=> IO.liftIO . Monad.void . c_vpi_printf) . ensureNullTerminated -- | A version of 'putStrLn' which outputs to the handle used by the simulator. -- When running a VPI callback, the normal functions provided in @base@ may diff --git a/clash-ffi/src/Clash/FFI/VPI/Info.hs b/clash-ffi/src/Clash/FFI/VPI/Info.hs index 40aaa0b30e..d6106d4024 100644 --- a/clash-ffi/src/Clash/FFI/VPI/Info.hs +++ b/clash-ffi/src/Clash/FFI/VPI/Info.hs @@ -5,6 +5,7 @@ Maintainer: QBayLogic B.V. -} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecordWildCards #-} -- Used to improve the performance of derived instances. {-# OPTIONS_GHC -fplugin=Foreign.Storable.Generic.Plugin #-} @@ -51,7 +52,7 @@ data CInfo = CInfo -- | Information about the simulator connected to over VPI. This includes the -- command line used to start the simulation tool. Depending on the simulator --- this may include / remove arguments recognised by the simulator (i.e. it +-- this may include / remove arguments recognized by the simulator (i.e. it -- will only contain other flags like RTS flags). -- data Info = Info @@ -64,20 +65,20 @@ data Info = Info type instance CRepr Info = CInfo instance UnsafeReceive Info where - unsafeReceive cinfo = do + unsafeReceive CInfo{..} = do -- When passing +RTS to some simulators, they may replace the whole - -- argument with NULL, so we check for that instead of using argc. - args <- unsafeReceiveArray0 FFI.nullPtr (cinfoArgv cinfo) - prod <- unsafeReceive (cinfoProduct cinfo) - ver <- unsafeReceive (cinfoVersion cinfo) + -- argument with NULL, so we check in addition to argc. + args <- unsafeReceiveArray0 (fromEnum cinfoArgc) FFI.nullPtr cinfoArgv + prod <- unsafeReceive cinfoProduct + ver <- unsafeReceive cinfoVersion pure (Info args prod ver) instance Receive Info where - receive cinfo = do - args <- receiveArray0 FFI.nullPtr (cinfoArgv cinfo) - prod <- receive (cinfoProduct cinfo) - ver <- receive (cinfoVersion cinfo) + receive CInfo{..} = do + args <- receiveArray0 (fromEnum cinfoArgc) FFI.nullPtr cinfoArgv + prod <- receive cinfoProduct + ver <- receive cinfoVersion pure (Info args prod ver) diff --git a/clash-ffi/src/Clash/FFI/VPI/Module.hs b/clash-ffi/src/Clash/FFI/VPI/Module.hs index 81d5a0f0e6..d016241964 100644 --- a/clash-ffi/src/Clash/FFI/VPI/Module.hs +++ b/clash-ffi/src/Clash/FFI/VPI/Module.hs @@ -19,6 +19,7 @@ import Data.ByteString (ByteString) import Foreign.Storable (Storable) import GHC.Stack (HasCallStack) +import Clash.FFI.View (ensureNullTerminated) import Clash.FFI.Monad (SimCont) import Clash.FFI.VPI.Iterator import Clash.FFI.VPI.Object @@ -49,7 +50,8 @@ topModules = iterateAll @_ @Object ObjModule Nothing -- exception if no top-level module with the given name is found in the design. -- findTopModule :: HasCallStack => ByteString -> SimCont o Module -findTopModule name = unsafeSendChildRef @_ @Object name Nothing +findTopModule name = + unsafeSendChildRef @_ @Object (ensureNullTerminated name) Nothing -- | Iterate all the nets in a module. This will iterate all nets at once, for -- large designs it may be more efficient to use diff --git a/clash-ffi/src/Clash/FFI/VPI/Object/Value.hs b/clash-ffi/src/Clash/FFI/VPI/Object/Value.hs index 1507d93a61..8a68c122f7 100644 --- a/clash-ffi/src/Clash/FFI/VPI/Object/Value.hs +++ b/clash-ffi/src/Clash/FFI/VPI/Object/Value.hs @@ -207,7 +207,7 @@ instance UnsafeSend Value where #endif StringVal size str -> do - cvalue <- CStringVal <$> unsafeSend str + cvalue <- CStringVal <$> unsafeSend (ensureNullTerminated str) pure (CValueSized cvalue (snatToNum size)) TimeVal time -> do @@ -241,7 +241,7 @@ instance Send Value where #endif StringVal size str -> do - cvalue <- CStringVal <$> send str + cvalue <- CStringVal <$> send (ensureNullTerminated str) pure (CValueSized cvalue (snatToNum size)) TimeVal time -> do diff --git a/clash-ffi/src/Clash/FFI/VPI/Object/Value/Parse.hs b/clash-ffi/src/Clash/FFI/VPI/Object/Value/Parse.hs index 6f3209a9b1..221ae734ec 100644 --- a/clash-ffi/src/Clash/FFI/VPI/Object/Value/Parse.hs +++ b/clash-ffi/src/Clash/FFI/VPI/Object/Value/Parse.hs @@ -19,10 +19,11 @@ module Clash.FFI.VPI.Object.Value.Parse import Control.Exception (Exception) import qualified Control.Monad as Monad (foldM) import qualified Control.Monad.IO.Class as IO (liftIO) +import Data.Bits (shiftL) import Data.Char (toLower) +import Data.Function (fix) import Data.Typeable (Typeable) import Foreign.C.String (CString) -import qualified Foreign.C.String as FFI (peekCString) import Foreign.C.Types (CInt) import GHC.Stack (CallStack, HasCallStack, callStack, prettyCallStack) import GHC.TypeNats (KnownNat) @@ -32,6 +33,7 @@ import Clash.Class.BitPack import Clash.Sized.BitVector (BitVector) import Clash.XException (deepErrorX) +import Clash.FFI.View (peekCStringBound) import Clash.FFI.Monad (SimCont) import qualified Clash.FFI.Monad as Sim import Clash.FFI.VPI.Object.Value.Format (ValueFormat(..)) @@ -64,9 +66,9 @@ parseBinStr => CInt -> CString -> SimCont o (BitVector n) -parseBinStr size bin = do - str <- IO.liftIO (FFI.peekCString bin) - let is = [size - 1, size - 2 .. 0] +parseBinStr bitSize bin = do + let is = [bitSize - 1, bitSize - 2 .. 0] + str <- IO.liftIO $ peekCStringBound (fromEnum bitSize) bin let go acc (i, x) = case x of @@ -126,9 +128,10 @@ parseOctStr => CInt -> CString -> SimCont o (BitVector n) -parseOctStr size oct = do - str <- IO.liftIO (FFI.peekCString oct) - let is = [0, 3 .. size - 1] +parseOctStr bitSize oct = do + let bound = bitSize `div` 3 + if bitSize `mod` 3 == 0 then 0 else 1 + is = [0, 3 .. bitSize - 1] + str <- IO.liftIO $ peekCStringBound (fromEnum bound) oct let go acc (i, x) = case x of @@ -152,10 +155,10 @@ parseOctStr size oct = do parse str where replaceSlice ~(x, y, z) i - | i == size - 1 + | i == bitSize - 1 = replaceBit i z - | i == size - 2 + | i == bitSize - 2 = replaceBit (i + 1) y . replaceBit i z | otherwise @@ -168,12 +171,17 @@ parseDecStr => CInt -> CString -> SimCont o (BitVector n) -parseDecStr _ dec = do - str <- IO.liftIO (FFI.peekCString dec) +parseDecStr bitSize dec = do + let bound = fromInteger + $ fix (\f a x -> if x < 10 then a else f (a + 1) $ div x 10) 1 + $ shiftL (1 :: Integer) + $ fromEnum bitSize + str <- IO.liftIO $ peekCStringBound bound dec -- I don't think you can have X or Z in the decimal strings, although the -- standard doesn't mention you can have x or z here either... case str of + "" -> pure (fromInteger 0) "x" -> pure (deepErrorX "parseDecStr: x") "z" -> pure (deepErrorX "parseDecStr: z") _ -> maybe @@ -189,9 +197,10 @@ parseHexStr => CInt -> CString -> SimCont o (BitVector n) -parseHexStr size hex = do - str <- IO.liftIO (FFI.peekCString hex) - let is = [0, 4 .. size - 1] +parseHexStr bitSize hex = do + let bound = bitSize `div` 4 + if bitSize `mod` 4 == 0 then 0 else 1 + is = [0, 4 .. bitSize - 1] + str <- IO.liftIO $ peekCStringBound (fromEnum bound) hex let go acc (i, x) = case toLower x of @@ -226,13 +235,13 @@ parseHexStr size hex = do parse str where replaceSlice ~(w, x, y, z) i - | i == size - 1 + | i == bitSize - 1 = replaceBit i z - | i == size - 2 + | i == bitSize - 2 = replaceBit (i + 1) y . replaceBit i z - | i == size - 3 + | i == bitSize - 3 = replaceBit (i + 2) x . replaceBit (i + 1) y . replaceBit i z | otherwise diff --git a/clash-ffi/src/Clash/FFI/VPI/Object/Value/Scalar.hs b/clash-ffi/src/Clash/FFI/VPI/Object/Value/Scalar.hs index f32820e954..53a74d2e02 100644 --- a/clash-ffi/src/Clash/FFI/VPI/Object/Value/Scalar.hs +++ b/clash-ffi/src/Clash/FFI/VPI/Object/Value/Scalar.hs @@ -44,7 +44,7 @@ data Scalar | SH -- Weak 1 | SL -- Weak 0 | S_ -- Don't care - deriving stock (Show) + deriving stock (Show, Eq) type instance CRepr Scalar = CInt diff --git a/clash-ffi/src/Clash/FFI/VPI/Object/Value/Vector.hs b/clash-ffi/src/Clash/FFI/VPI/Object/Value/Vector.hs index 11e67063ce..55fe25f497 100644 --- a/clash-ffi/src/Clash/FFI/VPI/Object/Value/Vector.hs +++ b/clash-ffi/src/Clash/FFI/VPI/Object/Value/Vector.hs @@ -8,6 +8,7 @@ Maintainer: QBayLogic B.V. #if defined(VERILOG_2005) && defined(VPI_VECVAL) {-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} @@ -23,11 +24,12 @@ Maintainer: QBayLogic B.V. module Clash.FFI.VPI.Object.Value.Vector ( CVector(..) + , bitVectorToVector + , vectorToBitVector ) where import qualified Control.Monad.IO.Class as IO (liftIO) import Data.Bits (clearBit, setBit, testBit) -import qualified Data.List as List (replicate) import Data.Proxy import Foreign.C.Types (CInt) import qualified Foreign.Marshal.Array as FFI (peekArray) @@ -75,43 +77,36 @@ vectorToCVectorList => KnownNat n => Vec n Scalar -> [CVector] -vectorToCVectorList vec = - let - size = fromIntegral (natVal (Proxy @n)) - len = div (size - 1) 32 + 1 - in - -- Default to all bits being undefined. - go (List.replicate len (CVector (-1) (-1))) (size - 1) vec +vectorToCVectorList vec = go [] 0 where - go :: forall m. [CVector] -> Int -> Vec m Scalar -> [CVector] - go acc n = \case - Nil -> - acc - - Cons x xs -> - go (replaceScalar n x acc) (n - 1) xs - - replaceScalar :: HasCallStack => Int -> Scalar -> [CVector] -> [CVector] - replaceScalar ix s [CVector as bs] - | ix < 32 - = let (f, g) = case s of - S0 -> (clearBit, clearBit) - S1 -> (setBit, clearBit) - SZ -> (clearBit, setBit) - SX -> (setBit, setBit) - SH -> (setBit, clearBit) - SL -> (clearBit, clearBit) - S_ -> (setBit, setBit) - in [CVector (f as ix) (g bs ix)] - - | otherwise - = error "replaceScalar: Index out of range" - - replaceScalar ix s (x:xs) = - x : replaceScalar (ix - 32) s xs - - replaceScalar _ _ _ = - error "replaceScalar: Index and list not consistent" + size :: Int + size = fromIntegral $ natVal (Proxy @n) + + replaceScalar :: Int -> Scalar -> CVector -> CVector + replaceScalar ix s (CVector as bs) = + let + (aMod, bMod) = + case s of + S0 -> (clearBit, clearBit) + SL -> (clearBit, clearBit) + S1 -> ( setBit, clearBit) + SH -> ( setBit, clearBit) + SZ -> (clearBit, setBit) + SX -> ( setBit, setBit) + S_ -> ( setBit, setBit) + in + CVector (aMod as ix) (bMod bs ix) + + go :: [CVector] -> Int -> [CVector] + go a i = + let + new = CVector (-1) (-1) + upd = replaceScalar (i `mod` 32) (vec Vec.!! (size - i - 1)) + in if + | i >= size -> reverse a + | i `mod` 32 == 0 -> go (upd new : a ) $ i + 1 + | x:xr <- a -> go (upd x : xr) $ i + 1 + | otherwise -> error "vectorToCVectorList" type instance CRepr (Vec _ Scalar) = CRepr [CVector] @@ -127,24 +122,18 @@ cvectorListToVector => KnownNat n => [CVector] -> Vec n Scalar -cvectorListToVector = - let size = fromIntegral (natVal (Proxy @n)) - in go (Vec.repeat SX) size 0 +cvectorListToVector = go (Vec.repeat SX) 0 where - go :: Vec n Scalar -> Int -> Int -> [CVector] -> Vec n Scalar - go acc size ix arr - | size == ix - = acc - - | ix < 32 - , [x] <- arr - = go (Vec.replace ix (getScalar ix x) acc) size (ix + 1) arr - - | (_:xs) <- arr - = go acc (size - 32) 0 xs - - | otherwise - = error "cvectorListToVector: Array is not the specified size" + size :: Int + size = fromIntegral $ natVal (Proxy @n) + + go :: Vec n Scalar -> Int -> [CVector] -> Vec n Scalar + go acc ix arr + | ix >= size && length arr <= 1 = acc + | x:xr <- arr = + go (Vec.replace ix (getScalar (ix `mod` 32) x) acc) (ix + 1) + $ if (ix + 1) `mod` 32 == 0 then xr else x:xr + | otherwise = error "cvectorListToVector: Array is not the specified size" getScalar :: Int -> CVector -> Scalar getScalar ix (CVector as bs) = diff --git a/clash-ffi/src/Clash/FFI/VPI/Port/Direction.hs b/clash-ffi/src/Clash/FFI/VPI/Port/Direction.hs index 65f2e47d2e..ca8bdc6631 100644 --- a/clash-ffi/src/Clash/FFI/VPI/Port/Direction.hs +++ b/clash-ffi/src/Clash/FFI/VPI/Port/Direction.hs @@ -31,6 +31,11 @@ data Direction -- ^ An output port. | InOut -- ^ A bidirectional port. + | MixedIO + -- ^ A mixed IO port. + | NoDirection + -- ^ No direction. + deriving stock (Show) -- | An exception thrown when decoding a port direction if an invalid value is -- given for the C enum that specifies the constructor of 'Direction'. @@ -55,4 +60,6 @@ instance Receive Direction where 1 -> pure Input 2 -> pure Output 3 -> pure InOut + 4 -> pure MixedIO + 5 -> pure NoDirection n -> Sim.throw (UnknownDirection n callStack) diff --git a/clash-ffi/src/Clash/FFI/View.hs b/clash-ffi/src/Clash/FFI/View.hs index 97c1c0c69e..1203372fd6 100644 --- a/clash-ffi/src/Clash/FFI/View.hs +++ b/clash-ffi/src/Clash/FFI/View.hs @@ -27,22 +27,25 @@ module Clash.FFI.View , unsafeSendString , sendString , receiveString + , peekCStringBound + , ensureNullTerminated ) where import qualified Control.Monad.IO.Class as IO (liftIO) import Data.ByteString (ByteString) -import qualified Data.ByteString as BS (length, packCString) +import qualified Data.ByteString as BS (length, packCString, null, last, snoc) import qualified Data.ByteString.Unsafe as BS import Data.Typeable (Typeable) import Foreign.C.String (CString) import qualified Foreign.C.String as FFI +import Foreign.C.Types (CChar) import qualified Foreign.Marshal.Alloc as FFI (mallocBytes) import qualified Foreign.Marshal.Array as FFI import qualified Foreign.Marshal.Utils as FFI (copyBytes) import Foreign.Ptr (Ptr) import qualified Foreign.Ptr as FFI (nullPtr) -import Foreign.Storable (Storable) -import qualified Foreign.Storable as FFI (peek, poke) +import Foreign.Storable (Storable, sizeOf) +import qualified Foreign.Storable as FFI (peek, poke, peekElemOff) import GHC.Stack (HasCallStack) import Clash.FFI.Monad (SimCont) @@ -212,32 +215,74 @@ peekReceive peekReceive ptr = IO.liftIO (FFI.peek ptr) >>= receive --- | Unsafely receive an array of values, with the end of the array marked by --- the given final element. Each element of the array is unsafely received. --- +-- | Unsafely receive an array of values, with the end of the array +-- marked by the given final element. The search for the marker is +-- bounded by 'bound'. Each element of the array is unsafely received. unsafeReceiveArray0 :: (UnsafeReceive a, Eq (CRepr a), Storable (CRepr a), Typeable b) - => CRepr a + => Int + -> CRepr a -> Ptr (CRepr a) -> SimCont b [a] -unsafeReceiveArray0 end ptr = - IO.liftIO (FFI.peekArray0 end ptr) >>= traverse unsafeReceive +unsafeReceiveArray0 bound end ptr = + IO.liftIO (boundedPeekArray0 bound end ptr) >>= traverse unsafeReceive --- | Safely receive an array of values, with the end of the array marked by --- the given final element. The caller is responsible for deallocating the +-- | Safely receive an array of values, with the end of the array +-- marked by the given final element. The search for the marker is +-- bounded by 'bound'. The caller is responsible for deallocating the -- elements of the array if necessary. --- receiveArray0 :: (Receive a, Eq (CRepr a), Storable (CRepr a), Typeable b) - => CRepr a + => Int + -> CRepr a -> Ptr (CRepr a) -> SimCont b [a] -receiveArray0 end ptr = - IO.liftIO (FFI.peekArray0 end ptr) >>= traverse receive - --- | Safely receive a string. Users are recommended to use 'ByteString' instead --- which supports safe and unsafe sending / receiving. --- +receiveArray0 bound end ptr = + IO.liftIO (boundedPeekArray0 bound end ptr) >>= traverse receive + +-- | Variant of 'Foreign.Marshal.Array.lengthArray0' using an upper +-- bound on the elements when searching for the terminator. +boundedLengthArray0 + :: (Storable a, Eq a) + => Int + -> a + -> Ptr a -> IO Int +boundedLengthArray0 bound marker ptr = loop 0 + where + loop i + | i >= bound = return bound + | otherwise = do + val <- FFI.peekElemOff ptr i + if val == marker then return i else loop (i+1) + +-- | Variant of 'Foreign.Marshal.Array.peekArray0' using an upper +-- bound on the elements when searching for the terminator. +boundedPeekArray0 + :: (Storable a, Eq a) + => Int + -> a + -> Ptr a + -> IO [a] +boundedPeekArray0 bound marker ptr = do + size <- boundedLengthArray0 bound marker ptr + FFI.peekArray size ptr + +-- | Variant of 'Foreign.C.String.peekCString' using an upper bound on the +-- elements when searching for the NUL terminator. +peekCStringBound :: Int -> CString -> IO String +peekCStringBound bound cp = do + let nNL = (0 :: CChar) + sz <- boundedLengthArray0 bound nNL cp + FFI.peekCStringLen (cp, sz * sizeOf nNL) + +-- | Safely receive a string. Users are recommended to use +-- 'ByteString' instead which supports safe and unsafe sending / +-- receiving. receiveString :: CString -> SimCont b String receiveString = IO.liftIO . FFI.peekCString + +-- | Ensure that the given 'ByteString' is a null-terminated 'ByteString' +ensureNullTerminated :: ByteString -> ByteString +ensureNullTerminated bs = + if not (BS.null bs) && BS.last bs == 0 then bs else BS.snoc bs 0 diff --git a/clash-ffi/tests/Clash/FFI/Test.hs b/clash-ffi/tests/Clash/FFI/Test.hs new file mode 100644 index 0000000000..391af55f62 --- /dev/null +++ b/clash-ffi/tests/Clash/FFI/Test.hs @@ -0,0 +1,240 @@ +{-| + Copyright : (C) 2023, QBayLogic B.V. + License : BSD2 (see the file LICENSE) + Maintainer : QBayLogic B.V. + + Utility functions for declaring the test cases. +-} +module Clash.FFI.Test where + +import Control.DeepSeq (NFData) +import Control.Monad (replicateM_) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.ByteString.Char8 (pack) +import Data.Coerce (Coercible) +import Data.Proxy (Proxy(..)) +import Foreign.C.Types (CInt(..)) +import GHC.IO.Handle.FD (fdToHandle) +import System.IO (Handle, hGetLine) + +import Test.Tasty.HUnit (assertFailure) +import Test.Tasty.SmallCheck (Reason, Testable, Property, test, monadic) +import Test.SmallCheck.Series (Positive) + +import Clash.Prelude (BitSize, SNat(..), Bit, Signed, snatToNum) + +import Clash.FFI.Monad (SimAction, SimCont, runSimAction) +import Clash.FFI.VPI.Module (Module(..), findTopModule) +import Clash.FFI.VPI.Net (Net(..)) +import Clash.FFI.VPI.Object ( IsObject, Object(..), Value(..) + , ObjectType(..), ValueFormat(..) + ) +import Clash.FFI.VPI.Parameter (Parameter(..)) +import Clash.FFI.VPI.Port (Port(..)) +import Clash.FFI.VPI.Reg (Reg(..)) + +import Clash.FFI.Test.Instances (TShow(..)) + +-- | Creates a POSIX pipe that is used for exchanging data between +-- Haskell and C. The interface serves as an alternative to the +-- FFI. The pipe is created at the C level. The function returns the +-- file descriptor of the created pipe, which can be turned into a +-- Haskell 'Handle' afterwards. +foreign import ccall "vpi_test.h init_pipe" + initPipe :: IO CInt + +-- | Closes the pipe created with 'initPipe'. +foreign import ccall "vpi_test.h close_pipe" + closePipe :: IO () + +-- | Safely runs an action that has access to the pipe. +withPipe :: ((?pipe :: Handle) => IO ()) -> IO () +withPipe action = do + pipe <- initPipe >>= fdToHandle + let ?pipe = pipe + action + closePipe + +-- | Passes some bit size value to the C interface. This side channel +-- is used to dynamically adjust value sizes to match the values that +-- are generated at the Haskell side. This way we avoid the necessity +-- to create and manage objects that match the generated +-- sizes. Instead, we can generate the objects independently of the +-- generated values and adapt their sizes such that they match. +foreign import ccall "vpi_test.h enforce_size" + enforceSize :: CInt -> IO () + +-- | Reifies the bit size from the given value. +valueSize :: Value -> CInt +valueSize = \case + BitVal (_ :: Bit) -> snatToNum (SNat :: SNat (BitSize Bit)) + IntVal (_ :: Signed 32) -> snatToNum (SNat :: SNat (BitSize (Signed 32))) + RealVal (_ :: Double) -> snatToNum (SNat :: SNat (BitSize Double)) + BitVectorVal n@SNat _ -> snatToNum n + StringVal n@SNat _ -> snatToNum n + TimeVal{} -> -1 + +-- | Gives the 'ValueFormat' of the given 'Value'. +valueFormat :: Value -> ValueFormat +valueFormat = \case + BitVal{} -> ScalarFmt + BitVectorVal{} -> VectorFmt + IntVal{} -> IntFmt + RealVal{} -> RealFmt + StringVal{} -> StringFmt + TimeVal{} -> TimeFmt + +-- | Existential data type wrapper for object types (required for +-- realizing 'objectType'). +data SomeObjectType = + forall a. (TShow a, IsObject a, Coercible Object a, NFData a) => + SomeObjectType (Proxy a) + +-- | Returns a type proxy of an 'IsObject' instance, which matches the +-- given 'ObjectType'. +objectType :: ObjectType -> SomeObjectType +objectType = \case + ObjModule -> SomeObjectType (Proxy @Module) + ObjNet -> SomeObjectType (Proxy @Net) + ObjPort -> SomeObjectType (Proxy @Port) + ObjParameter -> SomeObjectType (Proxy @Parameter) + ObjReg -> SomeObjectType (Proxy @Reg) + _ -> SomeObjectType (Proxy @Object) + +-- | Returns the top module named @top@. +topModule :: SimCont o Module +topModule = findTopModule $ pack "top" + +-- | Returns the special top module named @special@. Calls of +-- @vpi_get@ ('Clash.FFI.VPI.Object.getProperty' / +-- 'Clash.FFI.VPI.Object.receiveProperty') produce different output +-- for the return value on this module. If passing @special@, then +-- the values are printed as plain @PLI_INT32@ values instead of +-- their corresponding Haskell representation. +specialTop :: (?pipe :: Handle) => IO Module +specialTop = + runSimAction (findTopModule (pack "special") %% 3) + +-- | Runs tests over lists in the 'monadic' context. +testM :: Testable m [b] => (a -> m b) -> [a] -> Property m +testM xs = monadic . mapM xs + +-- | Runs some Clash FFI action and compares the returned result with +-- the output printed at the C side. +receiveAndCompare :: + (TShow a, ?pipe :: Handle) => + SimAction a -> + Positive Int -> + IO TestResult +receiveAndCompare action = + const $ runSimAction action >>= outputEQ + +-- | Sends some value to the C side via a Clash FFI action and +-- compares the output printed at the C side with the sent value. +sendAndCompare :: + (TShow a, ?pipe :: Handle) => + (a -> SimAction ()) -> + a -> + IO TestResult +sendAndCompare action input = do + runSimAction $ action input + inputEQ input + +-- | Sends some value to the C side via a Clash FFI action and +-- compares the output printed at the C side with the sent value. The +-- same is done for the value returned by the action. +sendReceiveAndCompare :: + (TShow a, TShow b, ?pipe :: Handle) => + (a -> SimAction b) -> + a -> + IO [TestResult] +sendReceiveAndCompare action input = do + output <- runSimAction $ action input + sequence + [ inputEQ input + , outputEQ output + ] + +-- | Sends two values to the C side via a Clash FFI action and +-- compares the output printed at the C side with the sent value. The +-- same is done for the value returned by the action. +sendReceiveAndCompare2 :: + (TShow a, TShow b, TShow c, ?pipe :: Handle) => + (a -> b -> SimAction c) -> + (a, b) -> + IO [TestResult] +sendReceiveAndCompare2 action (i1, i2) = do + output <- runSimAction $ action i1 i2 + sequence + [ inputEQ i1 + , inputEQ i2 + , outputEQ output + ] + +-- | Newtype wrapper introducing some reduced smallcheck interface for +-- declaring the corresponding tests. +newtype TestResult = + TestResult { testResult :: Either Reason () } + +instance Monad m => Testable m TestResult where + test (TestResult x) = case x of + Left err -> test (Left err :: Either Reason Reason) + Right () -> test True + +instance Monad m => Testable m [TestResult] where + test = test . TestResult . mapM_ testResult + +instance Monad m => Testable m [[TestResult]] where + test = test . concat + +-- | Modified variant of 'Test.Tasty.HUnit.assert' checking properties +-- in any 'MonadIO' context. +-- +-- Note: 'Test.Tasty.HUnit.assert' is declared deprecated. Since we +-- do need the original behavior here anyway, its fine to hijack the +-- name. +assert :: MonadIO m => m TestResult -> m () +assert x = (testResult <$> x) >>= \case + Left err -> liftIO $ assertFailure err + Right () -> return () + +-- | Discards the given number of lines on the communication pipe +-- between Haskell and C in case they are not important for a test. +-- Also see the '(%%)' operator for some minimal notation overhead +-- variant of this. +ignoreOutputs :: (MonadIO m, ?pipe :: Handle) => Int -> m () +ignoreOutputs n = replicateM_ n $ liftIO $ hGetLine ?pipe + +infix 1 %% + +-- | Ignores lines on the communication pipe between Haskell and C +-- like 'ignoreOutputs'. The interface of the operator is designed +-- such that it can be attached to any 'MonadIO' action producing the +-- lines to be ignored. +(%%) :: (Monad m, MonadIO m, ?pipe :: Handle) => m a -> Int -> m a +(%%) action n = do + r <- action + ignoreOutputs n + return r + +-- | Checks that the output returned by the tested Clash FFI action +-- matches the value printed at the C side to the communication pipe. +outputEQ :: (MonadIO m, TShow a, ?pipe :: Handle) => a -> m TestResult +outputEQ output = expectEQ <$> liftIO (hGetLine ?pipe) <*> pure (tShow output) + +-- | Checks that the input to the tested Clash FFI action matches the +-- value printed at the C side to the communication pipe. +inputEQ :: (MonadIO m, TShow a, ?pipe :: Handle) => a -> m TestResult +inputEQ input = expectEQ (tShow input) <$> liftIO (hGetLine ?pipe) + +-- | Checks that the print of some expected value matches some +-- received value. If the values do not match, then an error message +-- indicating the difference gets returned. +expectEQ :: String -> String -> TestResult +expectEQ expected got = + TestResult $ + if expected /= got + then Left $ "the printed values differ" + <> "\n expected: \"" <> expected <> "\"" + <> "\n but got: \"" <> got <> "\"" + else Right () diff --git a/clash-ffi/tests/Clash/FFI/Test/Instances.hs b/clash-ffi/tests/Clash/FFI/Test/Instances.hs new file mode 100644 index 0000000000..87fe2eeca2 --- /dev/null +++ b/clash-ffi/tests/Clash/FFI/Test/Instances.hs @@ -0,0 +1,534 @@ +{-| + Copyright : (C) 2023, QBayLogic B.V. + License : BSD2 (see the file LICENSE) + Maintainer : QBayLogic B.V. + + Orphan instances for generating test data for the data types of + Clash FFI to be utilized by 'Test.SmallCheck'. + + Additionally, a custom 'Show' class called 'TShow' is introduced for + printing the values exchanged via the POSIX pipe on the Haskell + side. 'TShow' defaults to 'Show', but can be adapted for individual + types if necessary. By using 'TShow' instead of 'Show' these + adaptions do not have an influence on the main library. + + Beside that, the module also defines some newtype wrappers that + adapt the 'Show' and 'Series' behavior of some predefined types. +-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +module Clash.FFI.Test.Instances where + +import Prelude hiding (init, length) + +import Data.Coerce (coerce) +import Data.Functor ((<&>)) +import Foreign.C.String (CString) +import Foreign.C.Types (CInt(..)) +import Foreign.Marshal.Alloc (malloc) +import Foreign.Ptr (nullPtr) +import GHC.Generics (Generic) +import GHC.TypeNats (SomeNat(..), someNatVal) +import Data.ByteString (ByteString, snoc, init, length, pack, unpack) +import System.IO.Unsafe (unsafePerformIO) +import Text.Printf (printf) + +import qualified Data.ByteString.Char8 as C (pack) + +import Test.SmallCheck.Series + (Serial(..), Series, NonZero(..), NonNegative(..), (\/), (<~>), cons1) + +import Clash.Promoted.Nat (SNat(..), snatProxy, snatToNum) +import Clash.Sized.Internal.BitVector (Bit(..), low, high) +import Clash.Sized.Vector (toList) + +import Clash.FFI.VPI.Callback (Callback, CallbackInfo(..)) +import Clash.FFI.VPI.Callback.Reason (CallbackReason(..)) +import Clash.FFI.VPI.Control (Control(..), StopValue(..), DiagnosticLevel(..)) +import Clash.FFI.VPI.Error (ErrorInfo(..)) +import Clash.FFI.VPI.Error.Level (ErrorLevel) +import Clash.FFI.VPI.Error.State (ErrorState) +import Clash.FFI.VPI.Info (Info(..)) +import Clash.FFI.VPI.Iterator (Iterator) +import Clash.FFI.VPI.Module (Module) +import Clash.FFI.VPI.Net (Net) +import Clash.FFI.VPI.Object (Object(..)) +import Clash.FFI.VPI.Object.Property (Property(..)) +import Clash.FFI.VPI.Object.Time (Time(..), TimeType(..)) +import Clash.FFI.VPI.Object.Type (ObjectType(..)) +import Clash.FFI.VPI.Object.Value (Value(..)) +import Clash.FFI.VPI.Object.Value.Delay (DelayMode(..)) +import Clash.FFI.VPI.Object.Value.Format (ValueFormat(..)) +import Clash.FFI.VPI.Object.Value.Scalar (bitToScalar) +import Clash.FFI.VPI.Object.Value.Vector (bitVectorToVector) +import Clash.FFI.VPI.Parameter (Parameter(..)) +import Clash.FFI.VPI.Port (Port) +import Clash.FFI.VPI.Port.Direction (Direction) +import Clash.FFI.VPI.Reg (Reg) +import Clash.FFI.View (UnsafeSend, Send, CRepr) + +-- | Custom 'Show' class for printing values on the Haskell side to be +-- compared with the respective prints on the C side. +class TShow a where + tShow :: a -> String + default tShow :: Show a => a -> String + tShow = show + +-- | 'String' newtype wrapper for avoiding reprints of already printed +-- values. +newtype S = S String +instance Show S where + show (S str) + | ' ' `elem` str = "(" <> str <> ")" + | otherwise = str + +-- | 'tShow' wrapper that adds parenthesis to the print, if necessary. +pShow :: TShow a => a -> String +pShow = show . S . tShow + +-- | Newtype wrapper for mapping 'TShow' to functors utilizing their +-- default 'show' behavior. +newtype TS a = TS a +instance (Functor f, TShow a, Show (f S)) => TShow (TS (f a)) where + tShow (TS x) = show $ fmap (S . tShow) x + +instance TShow () +instance TShow Bool +instance TShow CInt + +deriving via (TS [CInt]) instance TShow [CInt] +deriving via (TS [SerialBS]) instance TShow [SerialBS] + +deriving via (TS (Maybe Object)) instance TShow (Maybe Object) +deriving via (TS (Maybe Module)) instance TShow (Maybe Module) +deriving via (TS (Maybe Port)) instance TShow (Maybe Port) +deriving via (TS (Maybe Net)) instance TShow (Maybe Net) +deriving via (TS (Maybe Reg)) instance TShow (Maybe Reg) +deriving via (TS (Maybe Parameter)) instance TShow (Maybe Parameter) + +-- | 'ByteString' newtype wrapper, which ensures that the wrapped +-- elements are printed as 'Int' lists and that generated elements do +-- not contain NUL characters. +newtype SerialBS = SerialBS { serialBS :: ByteString } + deriving stock (Generic) + deriving newtype (Show, UnsafeSend, Send) + +type instance CRepr SerialBS = CString +instance TShow SerialBS where + tShow = show . unpack . serialBS +instance Monad m => Serial m SerialBS where + series = SerialBS . pack . filter (/= 0) <$> series + +-- | 'ByteString' newtype wrapper, which ensures that the wrapped +-- elements are printed as 'Int' lists (cf. 'SerialBS') and have a +-- newline character at the end. +newtype BSNL = BSNL { bsnl :: ByteString } + deriving newtype (Show) + +type instance CRepr BSNL = CString +instance TShow BSNL where + tShow = tShow . SerialBS . (`snoc` 10) . bsnl +instance Monad m => Serial m BSNL where + series = BSNL . serialBS <$> series + +-- | 'ByteString' newtype wrapper, whose generated elements are always +-- NUL terminated. Furthermore, 'BSNT' elements are printed as 'Int' +-- lists (cf. 'SerialBS'). +newtype BSNT = BSNT { bsnt :: ByteString } + deriving newtype (Show, UnsafeSend, Send) + +type instance CRepr BSNT = CString +instance TShow BSNT where + tShow = tShow . SerialBS . init . bsnt +instance Monad m => Serial m BSNT where + series = BSNT . (`snoc` 0) . serialBS <$> series + +-- Additional Clash.FFI.VPI.Callback.Callback Instances + +instance TShow Callback + +-- Additional Clash.FFI.VPI.Callback.CallbackInfo Instances + +instance Show a => Show (CallbackInfo a) where + show = const "CallbackInfo {..}" + +instance TShow a => TShow (CallbackInfo a) where + tShow CallbackInfo{..} = + "CallbackInfo {" + <> "cbReason = " <> tShow cbReason <> ", " + <> "cbRoutine = <" <> show (unsafePerformIO $ cbRoutine nullPtr) <> ">, " + <> "cbIndex = " <> show cbIndex <> ", " + <> "cbData = " <> tShow cbData + <> "}" + +instance (Monad m, Serial m a) => Serial m (CallbackInfo a) where + series = + CallbackInfo + <$> series + -- we use the return value of the callback to check that the function + -- passed to the VPI on the Haskell side is the same on the C side. + <~> (series <&> const . return) + <~> series + <~> series + +-- Additional Clash.FFI.VPI.Callback.Reason.CallbackReason Instances + +instance TShow CallbackReason where + tShow = \case + AfterValueChange obj tty vf -> + "AfterValueChange " + <> pShow (coerce obj :: Object) <> " " + <> pShow tty <> " " + <> pShow vf + BeforeStatement obj tty -> + "BeforeStatement " + <> pShow (coerce obj :: Object) <> " " + <> pShow tty + AfterForce mObj tty vf -> + "AfterForce " + <> pShow ((coerce <$> mObj) :: Maybe Object) <> " " + <> pShow tty <> " " + <> pShow vf + AfterRelease mObj tty vf -> + "AfterRelease " + <> pShow ((coerce <$> mObj) :: Maybe Object) <> " " + <> pShow tty <> " " + <> pShow vf + AtStartOfSimTime mObj t -> + "AtStartOfSimTime " + <> pShow ((coerce <$> mObj) :: Maybe Object) <> " " + <> pShow t + ReadWriteSynch mObj t -> + "ReadWriteSynch " + <> pShow ((coerce <$> mObj) :: Maybe Object) <> " " + <> pShow t + ReadOnlySynch mObj t -> + "ReadOnlySynch " + <> pShow ((coerce <$> mObj) :: Maybe Object) <> " " + <> pShow t + NextSimTime mObj tty -> + "NextSimTime " + <> pShow ((coerce <$> mObj) :: Maybe Object) <> " " + <> pShow tty + AfterDelay mObj t -> + "AfterDelay " + <> pShow ((coerce <$> mObj) :: Maybe Object) <> " " + <> pShow t + EndOfCompile -> "EndOfCompile" + StartOfSimulation -> "StartOfSimulation" + EndOfSimulation -> "EndOfSimulation" + RuntimeError -> "RuntimeError" + TchkViolation -> "TchkViolation" + StartOfSave -> "StartOfSave" + EndOfSave -> "EndOfSave" + StartOfRestart -> "StartOfRestart" + EndOfRestart -> "EndOfRestart" + StartOfReset -> "StartOfReset" + EndOfReset -> "EndOfReset" + EnterInteractive -> "EnterInteractive" + ExitInteractive -> "ExitInteractive" + InteractiveScopeChange -> "InteractiveScopeChange" + UnresolvedSysTf -> "UnresolvedSysTf" +#if defined(VERILOG_2001) + AfterAssign obj tty vf -> + "AfterAssign " + <> pShow ((coerce obj) :: Object) <> " " + <> pShow tty <> " " + <> pShow vf + AfterDeassign obj tty vf -> + "AfterDeassign " + <> pShow ((coerce obj) :: Object) <> " " + <> pShow tty <> " " + <> pShow vf + AfterDisable obj tty vf -> + "AfterDisable " + <> pShow ((coerce obj) :: Object) <> " " + <> pShow tty <> " " + <> pShow vf + PliError -> "PliError" + Signal -> "Signal" +#endif +#if defined(VERILOG_2005) + NbaSynch mObj t -> + "NbaSynch " + <> pShow ((coerce <$> mObj) :: Maybe Object) <> " " + <> pShow t + AtEndOfSimTime mObj t -> + "AtEndOfSimTime " + <> pShow ((coerce <$> mObj) :: Maybe Object) <> " " + <> pShow t +#endif + +instance Monad m => Serial m CallbackReason where + series = + (AfterValueChange <$> obj <~> series <~> series) + \/ (BeforeStatement <$> obj <~> series) + \/ (AfterForce <$> mObj <~> series <~> series) + \/ (AfterRelease <$> mObj <~> series <~> series) + \/ (AtStartOfSimTime <$> mObj <~> series) + \/ (ReadWriteSynch <$> mObj <~> series) + \/ (ReadOnlySynch <$> mObj <~> series) + \/ (NextSimTime <$> mObj <~> series) + \/ (AfterDelay <$> mObj <~> series) + \/ pure EndOfCompile + \/ pure StartOfSimulation + \/ pure EndOfSimulation + \/ pure RuntimeError + \/ pure TchkViolation + \/ pure StartOfSave + \/ pure EndOfSave + \/ pure StartOfRestart + \/ pure EndOfRestart + \/ pure StartOfReset + \/ pure EndOfReset + \/ pure EnterInteractive + \/ pure ExitInteractive + \/ pure InteractiveScopeChange + \/ pure UnresolvedSysTf +#if defined(VERILOG_2001) + \/ (AfterAssign <$> obj <~> series <~> series) + \/ (AfterDeassign <$> obj <~> series <~> series) + \/ (AfterDisable <$> obj <~> series <~> series) + \/ pure PliError + \/ pure Signal +#endif +#if defined(VERILOG_2005) + \/ (NbaSynch <$> mObj <~> series) + \/ (AtEndOfSimTime <$> mObj <~> series) +#endif + where + obj :: Series m Object + obj = series + + mObj :: Series m (Maybe Object) + mObj = series + +-- Additional Clash.FFI.VPI.Control.Control Instances + +instance TShow Control +deriving instance Generic Control +instance Monad m => Serial m Control where + series = cons1 Stop \/ cons1 Finish \/ + (Reset <$> series <~> (fmap getNonZero <$> series) <~> series) + +-- Additional Clash.FFI.VPI.Control.StopValue Instances + +instance TShow StopValue +deriving instance Generic StopValue +instance Monad m => Serial m StopValue + +-- Additional Clash.FFI.VPI.Control.DiagnosticLevel Instances + +instance TShow DiagnosticLevel +deriving instance Generic DiagnosticLevel +instance Monad m => Serial m DiagnosticLevel + +-- Additional Clash.FFI.VPI.Error.ErrorInfo Instances + +deriving instance Show ErrorInfo +instance TShow ErrorInfo where + tShow ErrorInfo{..} = + "ErrorInfo {" + <> "errorState = " <> tShow errorState <> ", " + <> "errorLevel = " <> tShow errorLevel <> ", " + <> "errorMessage = " <> tShow (SerialBS errorMessage) <> ", " + <> "errorProduct = " <> tShow (SerialBS errorProduct) <> ", " + <> "errorCode = " <> tShow (SerialBS errorCode) <> ", " + <> "errorFile = " <> tShow (SerialBS $ C.pack errorFile) <> ", " + <> "errorLine = " <> show errorLine <> "}" + +-- Additional Clash.FFI.VPI.Error.Level.ErrorLevel Instances + +instance TShow ErrorLevel + +-- Additional Clash.FFI.VPI.Error.Level.ErrorState Instances + +instance TShow ErrorState + +-- Additional Clash.FFI.VPI.Info.Info Instances + +instance TShow Info where + tShow Info{..} = + "Info {" + <> "infoArgs = " <> tShow (map SerialBS infoArgs) <> ", " + <> "infoProduct = " <> tShow (SerialBS infoProduct) <> ", " + <> "infoVersion = " <> tShow (SerialBS infoVersion) <> "}" + +instance Monad m => Serial m Info where + series = Info + <$> (fmap serialBS <$> series) + <~> (serialBS <$> series) + <~> (serialBS <$> series) + +-- Additional Clash.FFI.VPI.Iterator.Iterator Instances + +instance TShow Iterator + +-- Additional Clash.FFI.VPI.Module.Module Instances + +instance TShow Module + +-- Additional Clash.FFI.VPI.Net.Net Instances + +instance TShow Net + +-- Additional Clash.FFI.VPI.Object.Object Instances + +instance TShow Object +instance Monad m => Serial m Object where + series = pure $ Object $ unsafePerformIO malloc + +-- Additional Clash.FFI.VPI.Object.Property.Property Instances + +instance TShow (Property a) + +instance Monad m => Serial m (Property CInt) where + series = + foldl (\/) (pure TypeOf) $ map pure + [Size, LineNo, Direction, NetType, PortIndex] + +instance Monad m => Serial m (Property CString) where + series = foldl (\/) (pure Name) $ map pure [FullName, File] + +instance Monad m => Serial m (Property Bool) where + series = + foldl (\/) (pure IsScalar) $ map pure + [ IsVector +#if defined(VERILOG_2001) + , IsSigned + , IsLocalParam +#endif + ] + +-- Additional Clash.FFI.VPI.Object.Time.TimeType Instances + +instance TShow TimeType +deriving instance Generic TimeType +instance Monad m => Serial m TimeType where + series = pure ScaledReal \/ pure Sim + +-- Additional Clash.FFI.VPI.Object.Time.Time Instances + +instance TShow Time where + tShow = \case + SimTime t -> "SimTime " <> show t + RealTime t -> "RealTime " <> printf "%.10f" t + +deriving instance Generic Time +instance Monad m => Serial m Time + +-- Additional Clash.FFI.VPI.Object.Type.ObjectType Instances + +instance TShow ObjectType +deriving instance Generic ObjectType +instance Monad m => Serial m ObjectType + +-- Additional Clash.FFI.VPI.Object.Value.Value Instances + +instance Eq Value where + x1 == x2 + | BitVal (bitToScalar -> b1) <- x1 + , BitVal (bitToScalar -> b2) <- x2 + = b1 == b2 + + | BitVectorVal n1@SNat (toList . bitVectorToVector -> v1) <- x1 + , BitVectorVal n2@SNat (toList . bitVectorToVector -> v2) <- x2 + , snatToNum n1 == (snatToNum n2 :: Integer) + = v1 == v2 + + | IntVal i1 <- x1 + , IntVal i2 <- x2 + = i1 == i2 + + | RealVal r1 <- x1 + , RealVal r2 <- x2 + = r1 == r2 + + | StringVal n1@SNat s1 <- x1 + , StringVal n2@SNat s2 <- x2 + , snatToNum n1 == (snatToNum n2 :: Integer) + = s1 == s2 + + | TimeVal t1 <- x1 + , TimeVal t2 <- x2 + = t1 == t2 + + | otherwise + = False + +instance Monad m => Serial m Value where + series = + (BitVal <$> (pure high \/ pure low \/ pure (Bit 1 0))) + \/ bitVectorVal + \/ (IntVal . fromInteger <$> series) + \/ (RealVal <$> series) + \/ stringVal + \/ (TimeVal <$> series) + where + bitVectorVal = do + b <- series + -- ensure that large vectors are generated as well + n <- (if b then (+ 45) else id) . getNonNegative <$> series + m <- series + return $ case someNatVal (fromIntegral (n :: Integer)) of + SomeNat proxy -> + BitVectorVal (snatProxy proxy) (fromInteger m) + stringVal = do + bs <- serialBS <$> series + return $ case someNatVal (fromIntegral (length bs)) of + SomeNat proxy -> + StringVal (snatProxy proxy) bs + +instance TShow Value where + tShow = \case + BitVal bit -> "BitVal " <> show bit + BitVectorVal SNat bv -> "BitVectorVal " <> show bv + IntVal int -> "IntVal " <> show int + RealVal real -> "RealVal " <> printf "%.10f" real + StringVal _ str -> "StringVal " <> tShow (SerialBS str) + TimeVal time -> "TimeVal " <> tShow time + +-- Additional Clash.FFI.VPI.Object.Value.Delay.DelayMode Instances + +deriving instance Show DelayMode +instance TShow DelayMode where + tShow = \case + NoDelay -> "NoDelay" + InertialDelay t -> "InertialDelay " <> pShow t + TransportDelay t -> "TransportDelay " <> pShow t + PureTransportDelay t -> "PureTransportDelay " <> pShow t + Force -> "Force" + Release -> "Release" + +deriving instance Generic DelayMode +instance Monad m => Serial m DelayMode + +-- Additional Clash.FFI.VPI.Object.Value.Format.ValueFormat Instances + +instance TShow ValueFormat +deriving instance Generic ValueFormat +instance Monad m => Serial m ValueFormat + +-- Additional Clash.FFI.VPI.Parameter.Parameter Instances + +instance TShow Parameter + +-- Additional Clash.FFI.VPI.Port.Port Instances + +instance TShow Port + +-- Additional Clash.FFI.VPI.Port.Direction Instances + +instance TShow Direction + +-- Additional Clash.FFI.VPI.Reg.Reg Instances + +instance TShow Reg diff --git a/clash-ffi/tests/Main.hs b/clash-ffi/tests/Main.hs new file mode 100644 index 0000000000..0928859999 --- /dev/null +++ b/clash-ffi/tests/Main.hs @@ -0,0 +1,387 @@ +{-| + Copyright : (C) 2023, QBayLogic B.V. + License : BSD2 (see the file LICENSE) + Maintainer : QBayLogic B.V. + + A test suite that checks for the correct FFI data transfer of Clash + FFI. + + The tests work via utilizing an FFI-independent POSIX pipe to + compare the exchanged data in printed format. On the Haskell side, + the default 'Show' instances are used to print the values that are + transferred whenever possible. As this is not always an option, the + wrapper class 'TShow' is utilized to adapt the 'Show' behavior when + necessary. On the C side the corresponding data structures are + printed manually such that they match the Haskell 'TShow' behavior. + + The suite tests for FFI calls of Clash FFI that the prints of the + arguments and return values match at the Haskell and at the C + side. To this end, the values are printed one after another to the + pipe, always separated by a newline. For generating the test data, + the SmallCheck library is used, whenever possible. The remaining + cases are covered by HUnit tests. The test suite is not thread safe, + as only a single pipe is used to exchange the data. + + Also note: this test suite only checks that the data (described via + Haskell data values) is correctly transferred to the C level + structures and vice versa. Accordingly, these tests are independent + of any actual VPI simulator implementation. When combined with a + simulator, it still has to be taken care that the interaction with a + simulator is setup correctly. These tests only ensure that data does + not get corrupted when exchanged via the VPI. +-} +module Main where + +import Prelude hiding (iterate) + +import Control.Exception (SomeException, catch) +import Control.Monad.IO.Class (liftIO) +import Data.ByteString.Char8 (pack) +import Data.Proxy (Proxy(..)) +import Foreign.C.Types (CInt(..)) +import Foreign.C.String (CString) +import System.Environment (setEnv) + +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.HUnit (testCase, assertFailure) +import Test.Tasty.SmallCheck (testProperty) +import Test.SmallCheck.Series (Positive) + +import Clash.FFI.Monad +import Clash.FFI.VPI.Callback +import Clash.FFI.VPI.Control +import Clash.FFI.VPI.Error +import Clash.FFI.VPI.IO +import Clash.FFI.VPI.Info +import Clash.FFI.VPI.Iterator +import Clash.FFI.VPI.Module +import Clash.FFI.VPI.Net +import Clash.FFI.VPI.Object +import Clash.FFI.VPI.Parameter +import Clash.FFI.VPI.Port +import Clash.FFI.VPI.Reg + +import Clash.FFI.Test +import Clash.FFI.Test.Instances + +-- | Main entry for 'ffi-interface-tests'. +main :: IO () +main = withPipe $ do + -- using only a single joint pipe for all tests is not thread-safe, + -- which is why w restrict to single-threaded execution for now. + setEnv "TASTY_NUM_THREADS" "1" + + defaultMain $ testGroup "Clash-FFI" + [ testGroup "Clash.FFI.VPI.Callback" + [ testProperty "registerCallback (vpi_register_cb)" + $ testM $ sendReceiveAndCompare @(CallbackInfo BSNT) registerCallback + , testProperty "removeCallback (vpi_remove_cb)" + $ testM $ \cbInfo -> runSimAction $ do + cb <- registerCallback (cbInfo :: CallbackInfo BSNT) %% 2 + removeCallback cb + inputEQ cb + ] + , testGroup "Clash.FFI.VPI.Control" + [ testProperty "controlSimulator (vpi_control)" + $ testM $ sendAndCompare controlSimulator + ] + , testGroup "Clash.FFI.VPI.Error" + [ testProperty "receiveErrorLevel (vpi_chk_error)" + $ testM $ receiveAndCompare receiveErrorLevel + , testProperty "unsafeReceiveErrorInfo (vpi_chk_error)" + $ testM $ receiveAndCompare unsafeReceiveErrorInfo + , testProperty "receiveErrorInfo (vpi_chk_error)" + $ testM $ receiveAndCompare receiveErrorInfo + ] + , testGroup "Clash.FFI.VPI.IO" + [ testProperty "simPutStr (vpi_printf)" + $ testM $ sendAndCompare $ simPutStr . serialBS + , testProperty "simPutStrLn (vpi_printf)" + $ testM $ sendAndCompare $ simPutStrLn . bsnl + , testProperty "simFlushIO (vpi_flush)" + $ testM $ receiveAndCompare simFlushIO + ] + , testGroup "Clash.FFI.VPI.Info" + [ testProperty "receiveSimulatorInfo (vpi_get_vlog_info)" + $ testM $ receiveAndCompare receiveSimulatorInfo + , testProperty "unsafeReceiveSimulatorInfo (vpi_get_vlog_info)" + $ testM $ receiveAndCompare unsafeReceiveSimulatorInfo + ] + , testGroup "Clash.FFI.VPI.Iterator" + [ testProperty "iterate (vpi_iterate)" + $ testM $ sendReceiveAndCompare2 @_ @(Maybe Object) iterate + , testProperty "scan (vpi_scan)" + $ testM $ \x -> do + iterator <- runSimAction (iterate ObjModule (Nothing @Object) %% 3) + receiveAndCompare @(Maybe Module) (scan iterator) x + , testProperty "iterateAll (vpi_iterate, vpi_scan)" + $ testM $ \(input, mObj) -> case objectType input of + SomeObjectType (Proxy :: Proxy t) -> do + xs <- runSimAction $ iterateAll input mObj + -- check vpi_iterate output + cInput <- sequence + [ inputEQ input + , inputEQ (mObj :: Maybe Object) + ] + ignoreOutputs 1 -- internal iterator + -- check vpi_scan_output + cOutputs <- mapM (outputEQ . TS . Just) (xs :: [t]) + cEnd <- outputEQ (Nothing @Object) + return (cInput <> cOutputs <> [cEnd]) + ] + , testGroup "Clash.FFI.VPI.Module" + [ testCase "topModules (vpi_iterate, vpi_scan)" $ do + modules <- runSimAction topModules %% 3 + mapM_ (assert . outputEQ . Just) modules + assert $ outputEQ (Nothing @Module) + , testCase "findTopModule (vpi_handle_by_name)" $ do + let known = pack "top" + unknown = pack "unknown" + empty = pack "" + top <- runSimAction $ findTopModule known + mapM_ assert + [ inputEQ (SerialBS known) + , inputEQ (Nothing @Module) + , outputEQ top + ] + catch + ( runSimAction (findTopModule unknown) + >> assertFailure "expected Exception" + ) $ \(_ :: SomeException) -> return () + mapM_ assert + [ inputEQ (SerialBS unknown) + , inputEQ (Nothing @Module) + ] + catch + ( runSimAction (findTopModule empty) + >> assertFailure "expected Exception" + ) $ \(_ :: SomeException) -> return () + mapM_ assert + [ inputEQ (SerialBS empty) + , inputEQ (Nothing @Module) + ] + , testCase "moduleNets (vpi_iterate, vpi_scan)" $ + runSimAction ((topModule >>= moduleNets) %% 6) + >>= mapM_ (assert . outputEQ . Just) + >> assert (outputEQ (Nothing @Net)) + , testCase "moduleParameters (vpi_iterate, vpi_scan)" $ + runSimAction ((topModule >>= moduleParameters) %% 6) + >>= mapM_ (assert . outputEQ . Just) + >> assert (outputEQ (Nothing @Parameter)) + , testCase "modulePorts (vpi_iterate, vpi_scan)" $ + runSimAction ((topModule >>= modulePorts) %% 6) + >>= mapM_ (assert . outputEQ . Just) + >> assert (outputEQ (Nothing @Port)) + , testCase "moduleRegs (vpi_iterate, vpi_scan)" $ + runSimAction ((topModule >>= moduleRegs) %% 6) + >>= mapM_ (assert . outputEQ . Just) + >> assert (outputEQ (Nothing @Reg)) + ] + , testGroup "Clash.FFI.VPI.Object" + [ testProperty "freeObject (vpi_free_object)" + $ testM $ sendAndCompare @Object freeObject + , testProperty "compareObjects (vpi_compare_objects)" + $ testM $ sendReceiveAndCompare2 @Object @Object compareObjects + , testCase "getChild (vpi_handle)" $ do + let none = Nothing @Object + objTypeTop = ObjModule + objTypePort = ObjPort + runSimAction $ do + top <- getChild objTypeTop none + mapM_ assert + [ inputEQ objTypeTop + , inputEQ none + , outputEQ (top :: Module) + ] + let topRef = Just top + port <- getChild objTypePort topRef + mapM_ assert + [ inputEQ objTypePort + , inputEQ topRef + , outputEQ (port :: Port) + ] + catch + ( (runSimAction (getChild objTypePort none) :: IO Port) + >> assertFailure "expected Exception" + ) $ \(_ :: SomeException) -> return () + mapM_ assert + [ inputEQ objTypePort + , inputEQ none + ] + , testCase "sendChild (vpi_handle_by_name)" $ do + let none = Nothing @Object + topName = pack "top" + portName = pack "port" + runSimAction $ do + top <- sendChildRef topName none + mapM_ assert + [ inputEQ (SerialBS topName) + , inputEQ none + , outputEQ (top :: Module) + ] + let topRef = Just top + port <- sendChildRef portName topRef + mapM_ assert + [ inputEQ (SerialBS portName) + , inputEQ topRef + , outputEQ (port :: Port) + ] + catch + ( (runSimAction (sendChildRef portName none) :: IO Port) + >> assertFailure "expected Exception" + ) $ \(_ :: SomeException) -> return () + mapM_ assert + [ inputEQ (SerialBS portName) + , inputEQ none + ] + , testCase "unsafeSendChild (vpi_handle_by_name)" $ do + let none = Nothing @Object + topName = pack "top" + portName = pack "port" + runSimAction $ do + top <- unsafeSendChildRef topName none + mapM_ assert + [ inputEQ (SerialBS topName) + , inputEQ none + , outputEQ (top :: Module) + ] + let topRef = Just top + port <- unsafeSendChildRef portName topRef + mapM_ assert + [ inputEQ (SerialBS portName) + , inputEQ topRef + , outputEQ (port :: Port) + ] + catch + ( (runSimAction (unsafeSendChildRef portName none) :: IO Port) + >> assertFailure "expected Exception" + ) $ \(_ :: SomeException) -> return () + mapM_ assert + [ inputEQ (SerialBS portName) + , inputEQ none + ] + , testCase "getChild (vpi_handle_by_index)" $ do + let none = Nothing @Object + netNameRef = pack "top.net" + existingNetBitIdx = (0 :: CInt) + missingNetBitIdx = (20 :: CInt) + net <- Just <$> runSimAction (sendChildRef netNameRef none %% 3) + obj <- runSimAction $ getChild existingNetBitIdx (net :: Maybe Net) + mapM_ assert + [ inputEQ existingNetBitIdx + , inputEQ net + , outputEQ (obj :: Object) + ] + catch + ( (runSimAction (getChild missingNetBitIdx net) :: IO Port) + >> assertFailure "expected Exception" + ) $ \(_ :: SomeException) -> return () + mapM_ assert + [ inputEQ missingNetBitIdx + , inputEQ net + ] + , testCase "getChild (vpi_handle_by_multi_index)" $ do + let none = Nothing @Object + netNameRef = pack "top.reg" + existingRegBit = [0 :: CInt, 1 :: CInt] + missingRegBit = [1 :: CInt, 2 :: CInt] + reg <- Just <$> runSimAction (sendChildRef netNameRef none %% 3) + bit <- runSimAction $ getChild existingRegBit (reg :: Maybe Reg) + mapM_ assert + [ inputEQ existingRegBit + , inputEQ reg + , outputEQ (bit :: Object) + ] + catch + ( (runSimAction (getChild missingRegBit reg) :: IO Port) + >> assertFailure "expected Exception" + ) $ \(_ :: SomeException) -> return () + mapM_ assert + [ inputEQ missingRegBit + , inputEQ reg + ] + , testProperty "getProperty (vpi_get) [CInt]" + $ testM $ \(prop :: Property CInt) -> + specialTop >>= sendReceiveAndCompare2 getProperty . (prop, ) + , testProperty "getProperty (vpi_get) [Bool]" + $ testM $ \(prop :: Property Bool) -> + specialTop >>= sendReceiveAndCompare2 getProperty . (prop, ) + , testProperty "receiveProperty (vpi_get_str) [CString]" + $ testM $ \(prop :: Property CString) -> + specialTop >>= sendReceiveAndCompare2 + (((SerialBS <$>) .) . receiveProperty) . (prop, ) + , testProperty "receiveTime (vpi_get_time)" + $ testM $ sendReceiveAndCompare2 @_ @(Maybe Object) receiveTime + , testProperty "receiveValue (vpi_get_value)" + $ testM + ( (%% 3) -- internal call of 'getProperty Size' + . sendReceiveAndCompare2 @_ @Object receiveValue + ) + . filter ((`notElem` [SuppressValue, ObjTypeFmt]) . fst) + , testProperty "unsafeReceiveValue (vpi_get_value)" + $ testM + ( (%% 3) -- internal call of 'getProperty Size' + . sendReceiveAndCompare2 @_ @Object unsafeReceiveValue + ) + . filter ((`notElem` [SuppressValue, ObjTypeFmt]) . fst) + , testProperty "sendValue (vpi_put_value)" + $ testM $ \(value, delayMode) -> runSimAction $ do + let none = Nothing @Object + portNameRef = pack "top.port" + port <- sendChildRef portNameRef none %% 3 + liftIO $ enforceSize $ valueSize value + sendValue port value delayMode + sequence + [ inputEQ (port :: Port) + , inputEQ value + , inputEQ delayMode + ] + , testProperty "unsafeSendValue (vpi_put_value)" + $ testM $ \(value, delayMode) -> runSimAction $ do + let none = Nothing @Object + portNameRef = pack "top.port" + port <- sendChildRef portNameRef none %% 3 + liftIO $ enforceSize $ valueSize value + unsafeSendValue port value delayMode + sequence + [ inputEQ (port :: Port) + , inputEQ value + , inputEQ delayMode + ] + , testProperty "compare send & receive" + $ testM $ \(value, delayMode) -> runSimAction $ do + let none = Nothing @Object + portNameRef = pack "top.port" + port <- sendChildRef portNameRef none %% 3 + liftIO $ enforceSize $ valueSize value + sendValue (port :: Port) value delayMode %% 3 + value' <- receiveValue (valueFormat value) port %% 6 + return $ TestResult $ + if value /= value' + then Left $ "the values differ" + <> "\n sent: \"" <> tShow value <> "\"" + <> "\n but received: \"" <> tShow value' <> "\"" + else Right () + ] + , testGroup "Clash.FFI.VPI.Port" + [ testProperty "direction (vpi_get)" + $ testM $ \(_ :: [Positive Int]) -> + runSimAction $ do + let none = Nothing @Object + portNameRef = pack "top.port" + port <- sendChildRef portNameRef none %% 3 + value <- direction port + sequence + [ inputEQ Direction + , inputEQ port + , outputEQ value + ] + ] + ] + +foreign export ccall "clash_ffi_main" + ffiMain :: IO () + +-- | Must be declared for Clash FFI. +ffiMain :: IO () +ffiMain = return () diff --git a/clash-ffi/tests/cbits/Pipe.c b/clash-ffi/tests/cbits/Pipe.c new file mode 100644 index 0000000000..f5868bac63 --- /dev/null +++ b/clash-ffi/tests/cbits/Pipe.c @@ -0,0 +1,47 @@ +#include +#include +#include +#include + +#include "Pipe.h" + +static int pipefd[2]; +static FILE* f = NULL; + +int init_pipe(void) +{ + if (pipe(pipefd) == -1) + { + perror("ERROR: Cannot create pipe.\n"); + exit(EXIT_FAILURE); + } + + f = fdopen(pipefd[PIPE_WRITE_END], "w"); + + return pipefd[PIPE_READ_END]; +} + +void close_pipe(void) +{ + close(pipefd[PIPE_WRITE_END]); +} + +bool pipe_closed() +{ + return f == NULL; +} + +void send(char *restrict format, ...) +{ + va_list ap; + + va_start(ap, format); + vfprintf(f, format, ap); + va_end(ap); +} + +void commit_value() +{ + fprintf(f, "\n"); + fflush(f); +} diff --git a/clash-ffi/tests/cbits/Pipe.h b/clash-ffi/tests/cbits/Pipe.h new file mode 100644 index 0000000000..2e54574a1e --- /dev/null +++ b/clash-ffi/tests/cbits/Pipe.h @@ -0,0 +1,34 @@ +#ifndef PIPE_H +#define PIPE_H + +#include + +#define PIPE_READ_END 0 +#define PIPE_WRITE_END 1 + +/* Creates a POSIX pipe that is used for exchanging data between + * Haskell and C. The interface serves as an alternative to the + * Haskell-FFI. The pipe is created at the C level. The function + * returns the file descriptor of the created pipe. + */ +int init_pipe(void); + +/* Closes the pipe created with 'initPipe'. + */ +void close_pipe(void); + +/* Checks whether the pipe already got initialized. + */ +bool pipe_closed(void); + +/* Sends some values to the pipe formatted according to the given + format string. It's bascially is just an 'fprintf' wrapper. + */ +void send(char *restrict, ...); + +/* Finalizes a value printed to the pipe via sending a newline + * character. + */ +void commit_value(void); + +#endif diff --git a/clash-ffi/tests/cbits/Print.c b/clash-ffi/tests/cbits/Print.c new file mode 100644 index 0000000000..41575735f2 --- /dev/null +++ b/clash-ffi/tests/cbits/Print.c @@ -0,0 +1,734 @@ +#include + +#include "Test.h" +#include "Pipe.h" +#include "Print.h" + +void print_bytes(PLI_BYTE8 *bytes) +{ + if (pipe_closed()) + return; + + send("["); + int i = 0; + while (bytes[i] != 0) + { + if (i > 0) + send(","); + send("%u", (unsigned char) bytes[i++]); + } + + send("]"); +} + +void print_diagnostic_level(PLI_INT32 diagnosticLevel) +{ + if (pipe_closed()) + return; + + switch (diagnosticLevel) + { + case 0: send("NoDiagnostics"); break; + case 1: send("TimeAndLocation"); break; + case 2: send("TimeLocationAndStats"); break; + default: send("UNKNOWN DiagnosticLevel"); break; + } +} + +void print_property(PLI_INT32 prop) +{ + if (pipe_closed()) + return; + + switch (prop) + { + case vpiUndefined: send("Undefined"); break; + case vpiType: send("TypeOf"); break; + case vpiName: send("Name"); break; + case vpiFullName: send("FullName"); break; + case vpiSize: send("Size"); break; + case vpiFile: send("File"); break; + case vpiLineNo: send("LineNo"); break; + case vpiTopModule: send("IsTopModule"); break; + case vpiCellInstance: send("IsCellInstance"); break; + case vpiDefName: send("DefName"); break; + case vpiProtected: send("IsProtected"); break; + case vpiTimeUnit: send("TimeUnit"); break; + case vpiTimePrecision: send("TimePrecision"); break; + case vpiDefNetType: send("DefNetType"); break; + case vpiUnconnDrive: send("UnconnDrive"); break; + case vpiDefFile: send("DefFile"); break; + case vpiDefLineNo: send("DefLineNo"); break; + case vpiScalar: send("IsScalar"); break; + case vpiVector: send("IsVector"); break; + case vpiExplicitName: send("ExplicitName"); break; + case vpiDirection: send("Direction"); break; + case vpiConnByName: send("IsConnByName"); break; + case vpiNetType: send("NetType"); break; + case vpiExplicitScalared: send("IsExplicitScalared"); break; + case vpiExplicitVectored: send("IsExplicitVectored"); break; + case vpiExpanded: send("IsExpanded"); break; + case vpiImplicitDecl: send("IsImplicitDecl"); break; + case vpiChargeStrength: send("ChargeStrength"); break; + case vpiArray: send("IsArray"); break; + case vpiPortIndex: send("PortIndex"); break; + case vpiTermIndex: send("TermIndex"); break; + case vpiStrength0: send("Strength0"); break; + case vpiStrength1: send("Strength1"); break; + case vpiPrimType: send("PrimType"); break; + case vpiPolarity: send("Polarity"); break; + case vpiDataPolarity: send("DataPolarity"); break; + case vpiEdge: send("Edge"); break; + case vpiPathType: send("PathType"); break; + case vpiTchkType: send("TchkType"); break; + case vpiOpType: send("OpType"); break; + case vpiConstType: send("ConstType"); break; + case vpiBlocking: send("IsBlocking"); break; + case vpiCaseType: send("CaseType"); break; + case vpiNetDeclAssign: send("IsNetDeclAssign"); break; + case vpiFuncType: send("FuncType"); break; + case vpiUserDefn: send("IsUserDefn"); break; + case vpiScheduled: send("IsScheduled"); break; + case vpiDefDelayMode: send("DefDelayMode"); break; + case vpiDefDecayTime: send("DefDecayTime"); break; + case vpiActive: send("IsActive"); break; + case vpiAutomatic: send("IsAutomatic"); break; + case vpiCell: send("Cell"); break; + case vpiConfig: send("Config"); break; + case vpiConstantSelect: send("IsConstantSelect"); break; + case vpiDecompile: send("Decompile"); break; + case vpiDefAttribute: send("DefAttribute"); break; + case vpiDelayType: send("DelayType"); break; + case vpiIteratorType: send("IteratorType"); break; + case vpiLibrary: send("Library"); break; + case vpiOffset: send("Offset"); break; + case vpiResolvedNetType: send("ResolvedNetType"); break; + case vpiSaveRestartID: send("SaveRestartID"); break; + case vpiSaveRestartLocation: send("SaveRestartLocation"); break; + case vpiValid: send("IsValid"); break; + case vpiSigned: send("IsSigned"); break; + case vpiLocalParam: send("IsLocalParam"); break; + case vpiModPathHasIfNone: send("ModPathHasIfNone"); break; + case vpiIndexedPartSelectType: send("IndexedPartSelectType"); break; + case vpiIsMemory: send("IsMemory"); break; + case vpiIsProtected: send("IsProtected"); break; + default: send("UNKNOWN Property"); break; + } +} + +void print_time_type(PLI_INT32 type) +{ + if (pipe_closed()) + return; + + switch (type) + { + case vpiScaledRealTime: send("ScaledReal"); break; + case vpiSimTime: send("Sim"); break; + case vpiSuppressTime: send("SuppressTime"); break; + default: send("UNKNOWN TimeType"); break; + } +} + +void print_object_type(PLI_INT32 type) +{ + if (pipe_closed()) + return; + + switch (type) + { + case vpiAlways: send("ObjAlways"); break; + case vpiAssignStmt: send("ObjAssignStmt"); break; + case vpiAssignment: send("ObjAssignment"); break; + case vpiBegin: send("ObjBegin"); break; + case vpiCase: send("ObjCase"); break; + case vpiCaseItem: send("ObjCaseItem"); break; + case vpiConstant: send("ObjConstant"); break; + case vpiContAssign: send("ObjContAssign"); break; + case vpiDeassign: send("ObjDeassign"); break; + case vpiDefParam: send("ObjDefParam"); break; + case vpiDelayControl: send("ObjDelayControl"); break; + case vpiDisable: send("ObjDisable"); break; + case vpiEventControl: send("ObjEventControl"); break; + case vpiEventStmt: send("ObjEventStmt"); break; + case vpiFor: send("ObjFor"); break; + case vpiForce: send("ObjForce"); break; + case vpiForever: send("ObjForever"); break; + case vpiFork: send("ObjFork"); break; + case vpiFuncCall: send("ObjFuncCall"); break; + case vpiFunction: send("ObjFunction"); break; + case vpiGate: send("ObjGate"); break; + case vpiIf: send("ObjIf"); break; + case vpiIfElse: send("ObjIfElse"); break; + case vpiInitial: send("ObjInitial"); break; + case vpiIntegerVar: send("ObjIntegerVar"); break; + case vpiInterModPath: send("ObjInterModPath"); break; + case vpiIterator: send("ObjIterator"); break; + case vpiIODecl: send("ObjIODecl"); break; + case vpiMemory: send("ObjMemory"); break; + case vpiMemoryWord: send("ObjMemoryWord"); break; + case vpiModPath: send("ObjModPath"); break; + case vpiModule: send("ObjModule"); break; + case vpiNamedBegin: send("ObjNamedBegin"); break; + case vpiNamedEvent: send("ObjNamedEvent"); break; + case vpiNamedFork: send("ObjNamedFork"); break; + case vpiNet: send("ObjNet"); break; + case vpiNetBit: send("ObjNetBit"); break; + case vpiNullStmt: send("ObjNullStmt"); break; + case vpiOperation: send("ObjOperation"); break; + case vpiParamAssign: send("ObjParamAssign"); break; + case vpiParameter: send("ObjParameter"); break; + case vpiPartSelect: send("ObjPartSelect"); break; + case vpiPathTerm: send("ObjPathTerm"); break; + case vpiPort: send("ObjPort"); break; + case vpiPortBit: send("ObjPortBit"); break; + case vpiPrimTerm: send("ObjPrimTerm"); break; + case vpiRealVar: send("ObjRealVar"); break; + case vpiReg: send("ObjReg"); break; + case vpiRegBit: send("ObjRegBit"); break; + case vpiRelease: send("ObjRelease"); break; + case vpiRepeat: send("ObjRepeat"); break; + case vpiRepeatControl: send("ObjRepeatControl"); break; + case vpiSchedEvent: send("ObjSchedEvent"); break; + case vpiSpecParam: send("ObjSpecParam"); break; + case vpiSwitch: send("ObjSwitch"); break; + case vpiSysFuncCall: send("ObjSysFuncCall"); break; + case vpiSysTaskCall: send("ObjSysTaskCall"); break; + case vpiTableEntry: send("ObjTableEntry"); break; + case vpiTask: send("ObjTask"); break; + case vpiTaskCall: send("ObjTaskCall"); break; + case vpiTchk: send("ObjTchk"); break; + case vpiTchkTerm: send("ObjTchkTerm"); break; + case vpiTimeVar: send("ObjTimeVar"); break; + case vpiTimeQueue: send("ObjTimeQueue"); break; + case vpiUdp: send("ObjUdp"); break; + case vpiUdpDefn: send("ObjUdpDefn"); break; + case vpiUserSystf: send("ObjUserSystf"); break; + case vpiVarSelect: send("ObjVarSelect"); break; + case vpiWait: send("ObjWait"); break; + case vpiWhile: send("ObjWhile"); break; + case vpiAttribute: send("ObjAttribute"); break; + case vpiBitSelect: send("ObjBitSelect"); break; + case vpiCallback: send("ObjCallback"); break; + case vpiDelayTerm: send("ObjDelayTerm"); break; + case vpiDelayDevice: send("ObjDelayDevice"); break; + case vpiFrame: send("ObjFrame"); break; + case vpiGateArray: send("ObjGateArray"); break; + case vpiModuleArray: send("ObjModuleArray"); break; + case vpiPrimitiveArray: send("ObjPrimitiveArray"); break; + case vpiNetArray: send("ObjNetArray"); break; + case vpiRange: send("ObjRange"); break; + case vpiRegArray: send("ObjRegArray"); break; + case vpiSwitchArray: send("ObjSwitchArray"); break; + case vpiUdpArray: send("ObjUdpArray"); break; + case vpiContAssignBit: send("ObjContAssignBit"); break; + case vpiNamedEventArray: send("ObjNamedEventArray"); break; + case vpiIndexedPartSelect: send("ObjIndexedPartSelect"); break; + case vpiGenScopeArray: send("ObjGenScopeArray"); break; + case vpiGenScope: send("ObjGenScope"); break; + case vpiGenVar: send("ObjGenVar"); break; + default: send("UNKNOWN ObjectType"); break; + } +} + +void print_value_format(PLI_INT32 format) +{ + if (pipe_closed()) + return; + + switch (format) + { + case vpiBinStrVal: send("BinStrFmt"); break; + case vpiOctStrVal: send("OctStrFmt"); break; + case vpiDecStrVal: send("DecStrFmt"); break; + case vpiHexStrVal: send("HexStrFmt"); break; + case vpiScalarVal: send("ScalarFmt"); break; + case vpiIntVal: send("IntFmt"); break; + case vpiRealVal: send("RealFmt"); break; + case vpiStringVal: send("StringFmt"); break; + case vpiVectorVal: send("VectorFmt"); break; + case vpiTimeVal: send("TimeFmt"); break; + case vpiObjTypeVal: send("ObjTypeFmt"); break; + case vpiStrengthVal: send("StrengthFmt"); break; + case vpiShortIntVal: send("ShortIntFmt"); break; + case vpiLongIntVal: send("LongIntFmt"); break; + case vpiShortRealVal: send("ShortRealFmt"); break; + case vpiRawTwoStateVal: send("RawTwoStateFmt"); break; + case vpiRawFourStateVal: send("RawFourStateFmt"); break; + case vpiSuppressVal: send("SuppressValue"); break; + default: send("UNKNOWN ValueFormat"); break; + } +} + +void print_object_ref(vpiHandle ref) +{ + bool knownType = true; + + if (pipe_closed()) + return; + + else if (is_iterator_ref(ref)) send("Iterator {iteratorObject = "); + else if (ref == &callback_ref) send("Callback {callbackObject = "); + else if (ref == &module_ref) send("Module {moduleObject = "); + else if (ref == &special_ref) send("Module {moduleObject = "); + else if (ref == &net_ref) send("Net {netObject = "); + else if (ref == ¶meter_ref) send("Parameter {parameterObject = "); + else if (ref == &port_ref) send("Port {portObject = "); + else if (ref == ®_ref) send("Reg {regObject = "); + else knownType = false; + + if (sizeof(ref) == 8) + send("Object {objectPtr = 0x%.16" PRIxPTR "}", (uintptr_t) ref); + else + send("Object {objectPtr = 0x%.8" PRIxPTR "}", (uintptr_t) ref); + + if (knownType) + send("}"); +} + +void print_mobject(vpiHandle object) +{ + if (pipe_closed()) + return; + + if (object == NULL) + send("Nothing"); + else + { + send("Just ("); + print_object_ref(object); + send(")"); + } +} + +void print_time(p_vpi_time time) +{ + if (pipe_closed() || time == NULL) + return; + + switch (time->type) + { + case vpiScaledRealTime: + { + send("RealTime %.10f", time->real); + break; + } + case vpiSimTime: + { + uint64_t time_v; + time_v |= (uint64_t) time->high; + time_v <<= sizeof(time->low) * 8; + time_v |= (uint64_t) time->low; + send("SimTime %ld", time_v); + break; + } + default: break; + } +} + +void print_value(p_vpi_value value, int size) +{ + if (pipe_closed() || value == NULL) + return; + + switch (value->format) + { + case vpiObjTypeVal: + case vpiScalarVal: + { + send("BitVal "); + + switch (value->value.scalar) + { + case vpi0: + case vpiL: send("0"); break; + case vpi1: + case vpiH: send("1"); break; + default: send("."); break; + } + + break; + } + case vpiVectorVal: + { + send("BitVectorVal "); + + if (size > 0) + { + send("0b"); + + while (size--) + { + unsigned int sel = 1 << (size % 32); + unsigned int idx = size / 32; + + if (sel & value->value.vector[idx].bval) send("."); + else if (sel & value->value.vector[idx].aval) send("1"); + else send("0"); + + if (size > 0 && size % 4 == 0) + send("_"); + } + } + else + send("0"); + + break; + } + case vpiIntVal: + { + send("IntVal %d", value->value.integer); + break; + } + case vpiRealVal: + { + send("RealVal %.10f", value->value.real); + break; + } + case vpiBinStrVal: + { + send("BitVectorVal "); + + if (size > 0) + { + send("0b"); + + for (int i = 0; i < size; i++) + { + switch (value->value.str[i]) + { + case '0': send("0"); break; + case '1': send("1"); break; + default: send("."); break; + } + + if (size > i + 1 && (size - i - 1) % 4 == 0) + send("_"); + } + } + else + send("0"); + + break; + } + case vpiOctStrVal: + { + send("BitVectorVal "); + + if (size > 0) + { + send("0b"); + + int p = size * 3 - 1; + + for (int i = 0; i < size; i++) + { + char buf[4]; + + switch (value->value.str[i]) + { + case '0': sprintf(buf, "000"); break; + case '1': sprintf(buf, "001"); break; + case '2': sprintf(buf, "010"); break; + case '3': sprintf(buf, "011"); break; + case '4': sprintf(buf, "100"); break; + case '5': sprintf(buf, "101"); break; + case '6': sprintf(buf, "110"); break; + case '7': sprintf(buf, "111"); break; + default: sprintf(buf, "..."); break; + } + + send("%c", buf[0]); + if (p > 0 && (p % 4) == 0) send("_"); p--; + send("%c", buf[1]); + if (p > 0 && (p % 4) == 0) send("_"); p--; + send("%c", buf[2]); + if (p > 0 && (p % 4) == 0) send("_"); p--; + } + } + else + send("0"); + + break; + } + case vpiDecStrVal: + { + send("BitVectorVal "); + + if (size > 0) + { + send("0b"); + + unsigned long int num = 0; + unsigned long int m = 1; + + for (int i = size - 1; i >= 0; i--) + { + num += m * ((unsigned long int) (value->value.str[i] - '0')); + m *= 10; + } + + int upperBound = 1; + for (int i = 0; i < size; i++) + upperBound *= 10; + upperBound -= 1; + int bits = 0; + while (upperBound) + { + bits++; + upperBound >>= 1; + } + + for (int i = bits - 1; i >= 0; i--) + { + if (num & (1 << i)) + send("1"); + else + send("0"); + + if (i > 0 && (i % 4) == 0) + send("_"); + } + } + else + send("0"); + + break; + } + case vpiHexStrVal: + { + send("BitVectorVal "); + + if (size > 0) + { + send("0b"); + + for (int i = 0; i < size; i++) + { + switch (value->value.str[i]) + { + case '0': send("0000"); break; + case '1': send("0001"); break; + case '2': send("0010"); break; + case '3': send("0011"); break; + case '4': send("0100"); break; + case '5': send("0101"); break; + case '6': send("0110"); break; + case '7': send("0111"); break; + case '8': send("1000"); break; + case '9': send("1001"); break; + case 'a': send("1010"); break; + case 'b': send("1011"); break; + case 'c': send("1100"); break; + case 'd': send("1101"); break; + case 'e': send("1110"); break; + case 'f': send("1111"); break; + default: send("...."); break; + } + + if (size > i + 1) + send("_"); + } + } + else + send("0"); + + break; + } + case vpiStringVal: + { + send("StringVal "); + print_bytes(value->value.str); + break; + } + case vpiTimeVal: + { + send("TimeVal "); + print_time(value->value.time); + break; + } + case vpiStrengthVal: // + case vpiShortIntVal: // + case vpiLongIntVal: // + case vpiShortRealVal: // + case vpiRawTwoStateVal: // + case vpiRawFourStateVal: // currently not supported by clash-ffi + case vpiSuppressVal: + default: break; + } +} + +void print_callback_reason(p_cb_data cb_data_p) +{ + if (pipe_closed() || cb_data_p == NULL) + return; + + switch (cb_data_p->reason) + { + case cbValueChange: + { + send("AfterValueChange ("); + print_object_ref(cb_data_p->obj); + send(") "); + print_time_type(cb_data_p->time->type); + send(" "); + print_value_format(cb_data_p->value->format); + break; + } + case cbStmt: + { + send("BeforeStatement ("); + print_object_ref(cb_data_p->obj); + send(") "); + print_time_type(cb_data_p->time->type); + break; + } + case cbForce: + { + send("AfterForce "); + if (cb_data_p->obj != NULL) send("("); + print_mobject(cb_data_p->obj); + if (cb_data_p->obj != NULL) send(")"); + send(" "); + print_time_type(cb_data_p->time->type); + send(" "); + print_value_format(cb_data_p->value->format); + break; + } + case cbRelease: + { + send("AfterRelease "); + if (cb_data_p->obj != NULL) send("("); + print_mobject(cb_data_p->obj); + if (cb_data_p->obj != NULL) send(")"); + send(" "); + print_time_type(cb_data_p->time->type); + send(" "); + print_value_format(cb_data_p->value->format); + break; + } + case cbAtStartOfSimTime: + { + send("AtStartOfSimTime "); + if (cb_data_p->obj != NULL) send("("); + print_mobject(cb_data_p->obj); + if (cb_data_p->obj != NULL) send(")"); + send(" ("); + print_time(cb_data_p->time); + send(")"); + break; + } + case cbReadWriteSynch: + { + send("ReadWriteSynch "); + if (cb_data_p->obj != NULL) send("("); + print_mobject(cb_data_p->obj); + if (cb_data_p->obj != NULL) send(")"); + send(" ("); + print_time(cb_data_p->time); + send(")"); + break; + } + case cbReadOnlySynch: + { + send("ReadOnlySynch "); + if (cb_data_p->obj != NULL) send("("); + print_mobject(cb_data_p->obj); + if (cb_data_p->obj != NULL) send(")"); + send(" ("); + print_time(cb_data_p->time); + send(")"); + break; + } + case cbNextSimTime: + { + send("NextSimTime "); + if (cb_data_p->obj != NULL) send("("); + print_mobject(cb_data_p->obj); + if (cb_data_p->obj != NULL) send(")"); + send(" "); + print_time_type(cb_data_p->time->type); + break; + } + case cbAfterDelay: + { + send("AfterDelay "); + if (cb_data_p->obj != NULL) send("("); + print_mobject(cb_data_p->obj); + if (cb_data_p->obj != NULL) send(")"); + send(" ("); + print_time(cb_data_p->time); + send(")"); + break; + } + case cbEndOfCompile: send("EndOfCompile"); break; + case cbStartOfSimulation: send("StartOfSimulation"); break; + case cbEndOfSimulation: send("EndOfSimulation"); break; + case cbError: send("RuntimeError"); break; + case cbTchkViolation: send("TchkViolation"); break; + case cbStartOfSave: send("StartOfSave"); break; + case cbEndOfSave: send("EndOfSave"); break; + case cbStartOfRestart: send("StartOfRestart"); break; + case cbEndOfRestart: send("EndOfRestart"); break; + case cbStartOfReset: send("StartOfReset"); break; + case cbEndOfReset: send("EndOfReset"); break; + case cbEnterInteractive: send("EnterInteractive"); break; + case cbExitInteractive: send("ExitInteractive"); break; + case cbInteractiveScopeChange: send("InteractiveScopeChange"); break; + case cbUnresolvedSystf: send("UnresolvedSysTf"); break; + case cbAssign: + { + send("AfterAssign ("); + print_object_ref(cb_data_p->obj); + send(") "); + print_time_type(cb_data_p->time->type); + send(" "); + print_value_format(cb_data_p->value->format); + break; + } + case cbDeassign: + { + send("AfterDeassign ("); + print_object_ref(cb_data_p->obj); + send(") "); + print_time_type(cb_data_p->time->type); + send(" "); + print_value_format(cb_data_p->value->format); + break; + } + case cbDisable: + { + send("AfterDisable ("); + print_object_ref(cb_data_p->obj); + send(") "); + print_time_type(cb_data_p->time->type); + send(" "); + print_value_format(cb_data_p->value->format); + break; + } + case cbPLIError: send("PliError"); break; + case cbSignal: send("Signal"); break; + case cbNBASynch: + { + send("NbaSynch "); + if (cb_data_p->obj != NULL) send("("); + print_mobject(cb_data_p->obj); + if (cb_data_p->obj != NULL) send(")"); + send(" ("); + print_time(cb_data_p->time); + send(")"); + break; + } + case cbAtEndOfSimTime: + { + send("AtEndOfSimTime "); + if (cb_data_p->obj != NULL) send("("); + print_mobject(cb_data_p->obj); + if (cb_data_p->obj != NULL) send(")"); + send(" ("); + print_time(cb_data_p->time); + send(")"); + break; + } + } +} diff --git a/clash-ffi/tests/cbits/Print.h b/clash-ffi/tests/cbits/Print.h new file mode 100644 index 0000000000..260725f3b3 --- /dev/null +++ b/clash-ffi/tests/cbits/Print.h @@ -0,0 +1,100 @@ +#ifndef PRINT_H +#define PRINT_H + +#include "vpi_user.h" + +/* Prints a NUL terminated sequence of bytes to the shared pipe + * according to the Haskell representation of: + * + * 'Show [Int]' + */ +void print_bytes(PLI_BYTE8*); + +/* Prints the diagnostic level to the shared pipe according to the + * Haskell representation of: + * + * 'Show Clash.FFI.VPI.Error.Level.ErrorLevel' + */ +void print_diagnostic_level(PLI_INT32); + +/* Prints an VPI property to the shared pipe according to the Haskell + * representation of: + * + * 'Show Clash.FFI.VPI.Object.Property.Property' + */ +void print_property(PLI_INT32); + +/* Prints a time type to the shared pipe according to the Haskell + * representation of: + * + * 'Show Clash.FFI.VPI.Object.Time.TimeType' + */ +void print_time_type(PLI_INT32); + + +/* Prints the type of an object to the shared pipe according to the + * Haskell representation of: + * + * 'Show Clash.FFI.VPI.Object.Type.ObjectType' + */ +void print_object_type(PLI_INT32); + +/* Prints some value format to the shared pipe according to the + * Haskell representation of: + * + * 'Show Clash.FFI.VPI.Object.Value.Format.ValueFormat' + */ +void print_value_format(PLI_INT32); + +/* Prints an object referene to the shared pipe according to the + * Haskell representations of: + * + * 'Show Clash.FFI.VPI.Callback.Callback' + * 'Show Clash.FFI.VPI.Iterator.Iterator' + * 'Show Clash.FFI.VPI.Module.Module' + * 'Show Clash.FFI.VPI.Net.Net' + * 'Show Clash.FFI.VPI.Object.Object' + * 'Show Clash.FFI.VPI.Parameter.Parameter' + * 'Show Clash.FFI.VPI.Port.Port' + * 'Show Clash.FFI.VPI.Reg.Reg' + */ +void print_object_ref(vpiHandle); + +/* Prints an optional object referene to the shared pipe according to + * the Haskell representations of: + * + * 'Show (Maybe Clash.FFI.VPI.Callback.Callback)' + * 'Show (Maybe Clash.FFI.VPI.Iterator.Iterator)' + * 'Show (Maybe Clash.FFI.VPI.Module.Module)' + * 'Show (Maybe Clash.FFI.VPI.Net.Net)' + * 'Show (Maybe Clash.FFI.VPI.Object.Object)' + * 'Show (Maybe Clash.FFI.VPI.Parameter.Parameter)' + * 'Show (Maybe Clash.FFI.VPI.Port.Port)' + * 'Show (Maybe Clash.FFI.VPI.Reg.Reg)' + */ +void print_mobject(vpiHandle); + +/* Prints a time reference to the shared pipe according to the Haskell + * representation of: + * + * 'Show Clash.FFI.VPI.Object.Time.Time' + */ +void print_time(p_vpi_time); + +/* Prints some value to the shared pipe according to the Haskell + * representation of: + * + * 'Show Clash.FFI.VPI.Object.Value.Value' + * + * The second argument determines the size of the value. + */ +void print_value(p_vpi_value, int); + +/* Prints a callback reason to the shared pipe according to the + * Haskell representation of: + * + * 'Show Clash.FFI.VPI.Callback.Reason.CallbackReason' + */ +void print_callback_reason(p_cb_data); + +#endif diff --git a/clash-ffi/tests/cbits/Test.c b/clash-ffi/tests/cbits/Test.c new file mode 100644 index 0000000000..0334a9e384 --- /dev/null +++ b/clash-ffi/tests/cbits/Test.c @@ -0,0 +1,53 @@ +#include +#include + +#include "vpi_user.h" + +char some_strings[20][70] = + { "", "00", "aeajhbxpq", "@#$%^&*()_", "r561`123-imvnzf.nkpygaifd" + , "001384", "argument", "-/.,<>?[]|", "0123456789", "AOQABQILSAOTYH" + , "adf", "A", "-", "Hi", "Hello", "World", "zzz", "8", "=;+~+;=" + , "1234567890qwertyuiopasdfghjklzxcvbnmQWERTYUIOPASDFGHJKLZXCVBNM" + }; + +p_vpi_value stored_value = NULL; +PLI_INT32 stored_len = -1; +PLI_INT32 object_size = -1; + +PLI_UINT32 iterator_ref; +PLI_UINT32 iterator_module_ref; +PLI_UINT32 iterator_port_ref; +PLI_UINT32 iterator_parameter_ref; +PLI_UINT32 iterator_net_ref; +PLI_UINT32 iterator_reg_ref; +PLI_UINT32 callback_ref; +PLI_UINT32 module_ref; +PLI_UINT32 net_ref; +PLI_UINT32 net_bit_0_ref; +PLI_UINT32 net_bit_1_ref; +PLI_UINT32 parameter_ref; +PLI_UINT32 port_ref; +PLI_UINT32 reg_ref; +PLI_UINT32 reg_bit_0_0_ref; +PLI_UINT32 reg_bit_0_1_ref; +PLI_UINT32 reg_bit_1_0_ref; +PLI_UINT32 reg_bit_1_1_ref; +PLI_UINT32 special_ref; +PLI_UINT32 object_ref; + +void enforce_size(PLI_INT32 size) +{ + if (size >= 0) + object_size = size; +} + +bool is_iterator_ref(vpiHandle ref) +{ + return + ref == &iterator_ref + || ref == &iterator_module_ref + || ref == &iterator_port_ref + || ref == &iterator_parameter_ref + || ref == &iterator_net_ref + || ref == &iterator_reg_ref; +} diff --git a/clash-ffi/tests/cbits/Test.h b/clash-ffi/tests/cbits/Test.h new file mode 100644 index 0000000000..90250da757 --- /dev/null +++ b/clash-ffi/tests/cbits/Test.h @@ -0,0 +1,54 @@ +#ifndef TEST_H +#define TEST_H + +#include + +#include "vpi_user.h" + +/* Some Selection of Strings */ +#define NUM_STRINGS 20 +#define MAX_STR_LEN 70 +extern char some_strings[NUM_STRINGS][MAX_STR_LEN]; + +/* Shared Values */ +extern p_vpi_value stored_value; +extern PLI_INT32 stored_len; +extern PLI_INT32 object_size; + +/* Unique Object References */ +extern PLI_UINT32 iterator_ref; +extern PLI_UINT32 iterator_module_ref; +extern PLI_UINT32 iterator_port_ref; +extern PLI_UINT32 iterator_parameter_ref; +extern PLI_UINT32 iterator_net_ref; +extern PLI_UINT32 iterator_reg_ref; +extern PLI_UINT32 callback_ref; +extern PLI_UINT32 module_ref; +extern PLI_UINT32 net_ref; +extern PLI_UINT32 net_bit_0_ref; +extern PLI_UINT32 net_bit_1_ref; +extern PLI_UINT32 parameter_ref; +extern PLI_UINT32 port_ref; +extern PLI_UINT32 reg_ref; +extern PLI_UINT32 reg_bit_0_0_ref; +extern PLI_UINT32 reg_bit_0_1_ref; +extern PLI_UINT32 reg_bit_1_0_ref; +extern PLI_UINT32 reg_bit_1_1_ref; +extern PLI_UINT32 special_ref; +extern PLI_UINT32 object_ref; + +/* Passes some bit size value to the C interface. This side channel is + * used to dynamically adjust value sizes to match values that are + * generated at the Haskell side. This avoids the necessity of + * creating and managing objects that match the different + * sizes. Instead, we can generate the objects independently of the + * generated values and adapt their value size dynamically. + */ +void enforce_size(PLI_INT32); + +/* Checks whether the given reference is one of the known iterator + *references. + */ +bool is_iterator_ref(vpiHandle); + +#endif diff --git a/clash-ffi/tests/cbits/VPI.c b/clash-ffi/tests/cbits/VPI.c new file mode 100644 index 0000000000..567792f118 --- /dev/null +++ b/clash-ffi/tests/cbits/VPI.c @@ -0,0 +1,1055 @@ +#include +#include +#include + +#include "vpi_user.h" + +#include "Test.h" +#include "Pipe.h" +#include "Print.h" + +PLI_INT32 vpi_control(PLI_INT32 operation, ...) +{ + va_list ap; + + if (pipe_closed()) + return false; + + switch (operation) + { + case vpiStop: + { + va_start(ap, operation); + int diagnosticLevel = va_arg(ap, int); + va_end(ap); + + send("Stop "); + print_diagnostic_level(diagnosticLevel); + + break; + } + case vpiFinish: + { + va_start(ap, operation); + int diagnosticLevel = va_arg(ap, int); + va_end(ap); + + send("Finish "); + print_diagnostic_level(diagnosticLevel); + + break; + } + case vpiReset: + { + va_start(ap, operation); + int stopValue = va_arg(ap, int); + int returnValue = va_arg(ap, int); + int diagnosticLevel = va_arg(ap, int); + va_end(ap); + + send("Reset "); + + switch (stopValue) + { + case 0: send("Interactive"); break; + case 1: send("Processing"); break; + default: send("UNKNOWN StopValue"); break; + } + + send(" "); + if (returnValue == 0) + send("Nothing"); + else if (returnValue > 0) + send("(Just %d)", returnValue); + else + send("(Just (%d))", returnValue); + + send(" "); + print_diagnostic_level(diagnosticLevel); + + break; + } + default: + { + send("UNKNOWN vpi_control operation"); + + break; + } + } + commit_value(); + + return true; +} + +PLI_INT32 vpi_printf(PLI_BYTE8 *format, ...) +{ + va_list ap; + int result; + char buf[4096] = {0,}; + + if (pipe_closed()) + return -1; + + va_start(ap, format); + vsprintf(buf, format, ap); + va_end(ap); + + print_bytes(buf); + commit_value(); + + return result; +} + +PLI_INT32 vpi_flush(void) +{ + if (pipe_closed()) + return 1; + + send("()"); + commit_value(); + + return 0; +} + +static PLI_INT32 vpi_chk_error_call = 0; + +PLI_INT32 vpi_chk_error(p_vpi_error_info error_info_p) { + int errorLevel = 0; + PLI_INT32 call = 0; + + if (pipe_closed()) + return vpiInternal; + + call = vpi_chk_error_call++; + + // generate some error instance + if (error_info_p != NULL) + { + error_info_p->state = (call % 3) + 1; + error_info_p->level = ((call / 3) % 6); + error_info_p->message = some_strings[call % 20]; + error_info_p->product = some_strings[call % 5]; + error_info_p->code = some_strings[call % 12]; + error_info_p->file = some_strings[call % 14]; + error_info_p->line = call / 18; + + send("ErrorInfo {"); + + send("errorState = "); + switch (error_info_p->state) + { + case vpiCompile: send("CompileError"); break; + case vpiPLI: send("PliError"); break; + case vpiRun: send("RunError"); break; + default: send("UNKNOWN ErrorState"); break; + } + + send(", errorLevel = "); + errorLevel = error_info_p->level; + } + else + errorLevel = vpi_chk_error_call % 6; + + switch (errorLevel) + { + case 0: send("Success"); break; + case vpiNotice: send("Notice"); break; + case vpiWarning: send("Warning"); break; + case vpiError: send("Error"); break; + case vpiSystem: send("System"); break; + case vpiInternal: send("Internal"); break; + default: send("UNKNOWN ErrorLevel"); break; + } + + if (error_info_p != NULL) + { + send(", errorMessage = "); + print_bytes(error_info_p->message); + send(", errorProduct = "); + print_bytes(error_info_p->product); + send(", errorCode = "); + print_bytes(error_info_p->code); + send(", errorFile = "); + print_bytes(error_info_p->file); + send(", errorLine = "); + send("%d", error_info_p->line); + send("}"); + } + commit_value(); + + return errorLevel; +} + +static PLI_INT32 vpi_get_vlog_info_call = 0; + +PLI_INT32 vpi_get_vlog_info(p_vpi_vlog_info vlog_info_p) +{ + PLI_INT32 call = 0; + + if (pipe_closed() || vlog_info_p == NULL) + return false; + + call = vpi_get_vlog_info_call++; + + // generate some info instance + vlog_info_p->argc = call % NUM_STRINGS; + vlog_info_p->argv = (PLI_BYTE8**) malloc(sizeof(PLI_BYTE8*) * vlog_info_p->argc); + for (int i = 0; i < vlog_info_p->argc; i++) + vlog_info_p->argv[i] = some_strings[i]; + if (vlog_info_p->argc > 1) + { + vlog_info_p->argv[1] = (PLI_BYTE8*) malloc(sizeof(PLI_BYTE8) * 3); + vlog_info_p->argv[1][0] = 48 + (call % 100) / 10; + vlog_info_p->argv[1][1] = 48 + (call % 10); + vlog_info_p->argv[1][2] = some_strings[0][0]; + } + vlog_info_p->product = some_strings[call % 10]; + vlog_info_p->version = some_strings[call % 4]; + + send("Info {"); + send("infoArgs = ["); + for (int i = 0; i < vlog_info_p->argc; i++) + { + if (i > 0) + send(","); + + print_bytes(vlog_info_p->argv[i]); + } + send("], infoProduct = "); + print_bytes(vlog_info_p->product); + send(", infoVersion = "); + print_bytes(vlog_info_p->version); + send("}"); + commit_value(); + + return true; +} + +static PLI_INT32 vpi_get_call = 0; + +PLI_INT32 vpi_get(PLI_INT32 property, vpiHandle object) +{ + PLI_INT32 result = -1; + PLI_INT32 call = 0; + + if (pipe_closed()) + return result; + + call = vpi_get_call++; + + print_property(property); + commit_value(); + + print_object_ref(object); + commit_value(); + + switch (property) + { + case vpiType: + { + if (object == NULL) result = 0; + else if (is_iterator_ref(object)) result = vpiIterator; + else if (object == &callback_ref) result = vpiCallback; + else if (object == &module_ref) result = vpiModule; + else if (object == &special_ref) result = vpiModule; + else if (object == &net_ref) result = vpiNet; + else if (object == &net_bit_0_ref) result = vpiNetBit; + else if (object == &net_bit_1_ref) result = vpiNetBit; + else if (object == ¶meter_ref) result = vpiParameter; + else if (object == &port_ref) result = vpiPort; + else if (object == ®_ref) result = vpiReg; + else if (object == ®_bit_0_0_ref) result = vpiRegBit; + else if (object == ®_bit_0_1_ref) result = vpiRegBit; + else if (object == ®_bit_1_0_ref) result = vpiRegBit; + else if (object == ®_bit_1_1_ref) result = vpiRegBit; + + if (result > 0) + { + if (object == &special_ref) + send("%d", result); + else + print_object_type(result); + } + + break; + } + case vpiSize: + { + if (object_size >= 0) + { + result = object_size; + object_size = -1; + } + else + result = (call % 21) + 1; + + send("%d", result); + break; + } + case vpiLineNo: + { + result = (call % 13) + 1; + send("%d", result); + break; + } + case vpiDirection: + { + result = (call % 5) + 1; + + if (object == &special_ref) + send("%d", result); + else + { + switch (result) + { + case vpiInput: send("Input"); break; + case vpiOutput: send("Output"); break; + case vpiInout: send("InOut"); break; + case vpiMixedIO: send("MixedIO"); break; + case vpiNoDirection: send("NoDirection"); break; + default: send("UNKNOWN Direction"); break; + } + } + + break; + } + case vpiNetType: + { + result = (call % 13) + 1; + + if (object == &special_ref) + send("%d", result); + else + { + switch (result) + { + case vpiWire: send("Wire"); break; + case vpiWand: send("Wand"); break; + case vpiWor: send("Wor"); break; + case vpiTri: send("Tri"); break; + case vpiTri0: send("Tri0"); break; + case vpiTri1: send("Tri1"); break; + case vpiTriReg: send("TriReg"); break; + case vpiTriAnd: send("TriAnd"); break; + case vpiTriOr: send("TriOr"); break; + case vpiSupply1: send("Supply1"); break; + case vpiSupply0: send("Supply0"); break; + case vpiNone: send("None"); break; + case vpiUwire: send("Uwire"); break; + default: send("UNKNOWN NetType"); break; + } + } + + break; + } + case vpiPortIndex: + { + result = call % 11; + send("%d", result); + break; + } + case vpiScalar: + case vpiVector: + case vpiSigned: + case vpiLocalParam: + { + result = call % 2; + + if (result) + send("True"); + else + send("False"); + } + default: break; + } + commit_value(); + + return result; +} + +vpiHandle vpi_iterate(PLI_INT32 type, vpiHandle refHandle) +{ + if (pipe_closed()) + return NULL; + + PLI_INT32* ref = NULL; + + switch (type) + { + case vpiModule: ref = &iterator_module_ref; break; + case vpiNet: ref = &iterator_net_ref; break; + case vpiParameter: ref = &iterator_parameter_ref; break; + case vpiPort: ref = &iterator_port_ref; break; + case vpiReg: ref = &iterator_reg_ref; break; + default: ref = &iterator_ref; break; + } + + print_object_type(type); + commit_value(); + + print_mobject(refHandle); + commit_value(); + + print_object_ref(ref); + commit_value(); + + return ref; +} + +static PLI_INT32 vpi_scan_call = 0; + +vpiHandle vpi_scan(vpiHandle iterator) +{ + PLI_INT32 call = 0; + + if (pipe_closed() || !is_iterator_ref(iterator)) + return NULL; + + call = vpi_scan_call++; + + PLI_UINT32* ref; + + if ((call % 5) == 0) ref = NULL; + else if (iterator == &iterator_module_ref) ref = &module_ref; + else if (iterator == &iterator_port_ref) ref = &port_ref; + else if (iterator == &iterator_parameter_ref) ref = ¶meter_ref; + else if (iterator == &iterator_net_ref) ref = &net_ref; + else if (iterator == &iterator_reg_ref) ref = ®_ref; + else ref = &object_ref; + + print_mobject(ref); + commit_value(); + + return ref; +} + +static PLI_INT32 vpi_get_time_call = 0; + +void vpi_get_time(vpiHandle object, p_vpi_time time_p) +{ + PLI_INT32 call = 0; + + if (pipe_closed() || time_p == NULL) + return; + + call = vpi_get_time_call++; + + switch (time_p->type) + { + case vpiScaledRealTime: + { + time_p->high = 0; + time_p->low = 0; + time_p->real = ((double) call) * 0.32; + break; + } + case vpiSimTime: + { + time_p->high = call / 10; + time_p->low = call % 10; + time_p->real = 0.0; + break; + } + default: break; + } + + print_time_type(time_p->type); + commit_value(); + + print_mobject(object); + commit_value(); + + print_time(time_p); + commit_value(); +} + +static PLI_INT32 vpi_get_str_call = 0; + +PLI_BYTE8* vpi_get_str(PLI_INT32 property, vpiHandle object) +{ + PLI_BYTE8* result = NULL; + PLI_INT32 call = 0; + + if (pipe_closed()) + return result; + + call = vpi_get_str_call++; + + print_property(property); + commit_value(); + + print_object_ref(object); + commit_value(); + + switch (property) + { + case vpiFullName: result = some_strings[call % 7]; break; + case vpiName: result = some_strings[call % 19]; break; + case vpiFile: result = some_strings[call % 13]; break; + default: break; + } + + if (result != NULL) + print_bytes(result); + commit_value(); + + return result; +} + +static PLI_INT32 vpi_get_value_call = 0; + +void vpi_get_value(vpiHandle expr, p_vpi_value value_p) +{ + PLI_INT32 len = -1; + PLI_INT32 call = 0; + + if (pipe_closed() || expr == NULL || value_p == NULL) + return; + + call = vpi_get_value_call++; + + if (stored_value != NULL && stored_value->format == value_p->format) + { + len = stored_len; + memcpy(value_p, stored_value, sizeof(s_vpi_value)); + object_size = len; + } + else + { + switch (value_p->format) + { + case vpiBinStrVal: + { + len = call % 5; + object_size = len; + value_p->value.str = (PLI_BYTE8*) malloc(len * sizeof(PLI_BYTE8)); + + for (int i = 0; i < len; i++) + { + switch (call % 4) + { + case 0: value_p->value.str[i] = '0'; break; + case 1: value_p->value.str[i] = '1'; break; + case 2: value_p->value.str[i] = 'x'; break; + default: value_p->value.str[i] = 'z'; break; + } + call >>= 1; + } + + break; + } + case vpiOctStrVal: + { + len = call % 3; + object_size = len * 3; + value_p->value.str = (PLI_BYTE8*) malloc(len * sizeof(PLI_BYTE8)); + + PLI_BYTE8 choice = (PLI_BYTE8) (call % 10); + + for (int i = 0; i < len; i++) + { + if (choice >= 0 && choice < 8) + value_p->value.str[i] = '0' + choice; + else + value_p->value.str[i] = choice == 8 ? 'x' : 'z'; + + // Note: 'X' or 'Z' values are not generated, as they + // are not supported by clash-ffi. + call >>= 1; + } + + break; + } + case vpiDecStrVal: + { + len = call % 3; + int upperBound = 1; + + for (int i = 0; i < len; i++) + upperBound *= 10; + upperBound -= 1; + int bits = 0; + while (upperBound) + { + bits++; + upperBound >>= 1; + } + + object_size = bits; + value_p->value.str = (PLI_BYTE8*) malloc(len + 1 * sizeof(PLI_BYTE8)); + + PLI_BYTE8 choice = (PLI_BYTE8) (call % 10); + + for (int i = 0; i < len; i++) + { + value_p->value.str[i] = '0' + choice; + call >>= 1; + } + + // We NUL terminate strings, if encoded as decimals. Note + // that decimal encodings and binary encodings do not + // align properly. For example, the value '9' needs 4 bits + // to be represented in binary, but only 1 character in + // the decimal encoding. Nevertheless, 4 bit sized values + // may also require 2 character in decimal + // encoding. Hence, the reported bit size does not always + // uniquely determine the number of transmitted + // characters. + // + // We avoid this situation in the other cases by always + // generating the maximal amount of characters. However, + // we chose differently here, for testing that this + // alternative works as well. + value_p->value.str[len] = 0; + + break; + } + case vpiHexStrVal: + { + len = call % 3; + enforce_size(len * 4); + value_p->value.str = (PLI_BYTE8*) malloc(len * sizeof(PLI_BYTE8)); + + PLI_BYTE8 choice = (PLI_BYTE8) (call % 18); + + for (int i = 0; i < len; i++) + { + if (choice >= 0 && choice < 10) + value_p->value.str[i] = '0' + choice; + else if (choice >= 10 && choice < 16) + value_p->value.str[i] = 'a' + choice - 10; + else + value_p->value.str[i] = choice == 16 ? 'x' : 'z'; + + // Note: 'X' or 'Z' values are not generated, as they + // are not supported by clash-ffi. + call >>= 1; + } + + break; + } + case vpiScalarVal: + { + enforce_size(1); + + switch (call % 7) + { + case 0: value_p->value.scalar = vpi0; break; + case 1: value_p->value.scalar = vpi1; break; + case 2: value_p->value.scalar = vpiZ; break; + case 3: value_p->value.scalar = vpiX; break; + case 4: value_p->value.scalar = vpiH; break; + case 5: value_p->value.scalar = vpiL; break; + default: value_p->value.scalar = vpiDontCare; break; + } + + break; + } + case vpiIntVal: + { + enforce_size(8 * sizeof(PLI_INT32)); + + bool sign = call % 2; + call >>= 1; + value_p->value.integer = call; + if (sign) + value_p->value.integer *= -1; + break; + } + case vpiRealVal: + { + enforce_size(8 * sizeof(double)); + + value_p->value.real = 0.29 * ((double) (call % 1000)); + break; + } + case vpiStringVal: + { + len = call % 3; + value_p->value.str = (PLI_BYTE8*) malloc(1 + len * sizeof(PLI_BYTE8)); + + for (int i = 0; i < len; i++) + { + value_p->value.str[i] = (PLI_BYTE8) (call % 256); + call >>= 1; + } + + value_p->value.str[len] = 0; + break; + } + case vpiVectorVal: + { + len = call % 45; + int size = 1 + (len - 1 / 32); + enforce_size(len); + + p_vpi_vecval vec = (p_vpi_vecval) malloc(size * sizeof(s_vpi_vecval)); + vec->aval = 0; + vec->bval = 0; + + for (int i = 0; i <= (len % 32); i++) + for (int j = 0; j < size; j++) + { + switch (call % 4) + { + case 2: break; + case 1: vec[j].aval |= 1; break; + case 0: vec[j].bval |= 1; break; + default: vec[j].aval |= 1; vec[j].bval |= 1; break; + } + + if (i < (len % 32) - 1) + { + vec[j].aval <<= 1; + vec[j].bval <<= 1; + } + + call >>= 1; + } + + value_p->value.vector = vec; + + break; + } + case vpiTimeVal: + { + p_vpi_time time = (p_vpi_time) malloc(sizeof(s_vpi_time)); + + time->type = call % 2 ? vpiScaledRealTime : vpiSimTime; + call >>= 1; + + switch (time->type) + { + case vpiScaledRealTime: + { + time->high = 0; + time->low = 0; + time->real = ((double) call) * 0.32; + break; + } + case vpiSimTime: + { + time->high = call / 10; + time->low = call % 10; + time->real = 0.0; + break; + } + default: break; + } + + value_p->value.time = time; + + break; + } + case vpiObjTypeVal: // + case vpiStrengthVal: // + case vpiShortIntVal: // + case vpiLongIntVal: // + case vpiShortRealVal: // + case vpiRawTwoStateVal: // + case vpiRawFourStateVal: // currently not supported by clash-ffi + case vpiSuppressVal: + default: break; + } + } + + stored_len = -1; + stored_value = NULL; + + print_value_format(value_p->format); + commit_value(); + + print_object_ref(expr); + commit_value(); + + print_value(value_p, len); + commit_value(); +} + +vpiHandle vpi_put_value(vpiHandle object, p_vpi_value value_p, + p_vpi_time time_p, PLI_INT32 flags) +{ + if (pipe_closed() || object == NULL || value_p == NULL) + return NULL; + + print_object_ref(object); + commit_value(); + + // Handling fixed sizes for data driven objects would introduce a + // lot of some overhead, which is out of scope for this testing + // interface. Instead, we require the size of values to be set + // dynamically before each 'vpi_put_value' call using the + // 'enforce_size' method. This is more flexible, since sizes can be + // adjusted for each test case individually. + PLI_INT32 len = object_size; + object_size = -1; + print_value(value_p, len); + commit_value(); + + switch (flags) + { + case vpiNoDelay: + { + send("NoDelay"); + break; + } + case vpiInertialDelay: + { + send("InertialDelay ("); + print_time(time_p); + send(")"); + break; + } + case vpiTransportDelay: + { + send("TransportDelay ("); + print_time(time_p); + send(")"); + break; + } + case vpiPureTransportDelay: + { + send("PureTransportDelay ("); + print_time(time_p); + send(")"); + break; + } + case vpiForceFlag: + { + send("Force"); + break; + } + case vpiReleaseFlag: + { + send("Release"); + break; + } + default: + { + send("UNKNOWN DelayMode"); + break; + } + } + commit_value(); + + stored_len = len; + stored_value = value_p; + + return NULL; +} + +PLI_INT32 vpi_free_object(vpiHandle object) +{ + if (pipe_closed()) + return -1; + + print_object_ref(object); + commit_value(); + + return true; +} + +PLI_INT32 vpi_compare_objects(vpiHandle object1, vpiHandle object2) +{ + if (pipe_closed()) + return -1; + + print_object_ref(object1); + commit_value(); + + print_object_ref(object2); + commit_value(); + + if (object1 == object2) + send("True"); + else + send("False"); + + commit_value(); + + return object1 == object2; +} + +vpiHandle vpi_handle(PLI_INT32 type, vpiHandle refHandle) +{ + vpiHandle ref = NULL; + + if (pipe_closed()) + return NULL; + + switch (type) + { + case vpiModule: + { + if (refHandle == NULL) + ref = &module_ref; + break; + } + case vpiNet: + { + if (refHandle == &module_ref) + ref = &net_ref; + break; + } + case vpiParameter: + { + if (refHandle == &module_ref) + ref = ¶meter_ref; + break; + } + case vpiPort: + { + if (refHandle == &module_ref) + ref = &port_ref; + break; + } + case vpiReg: + { + if (refHandle == &module_ref) + ref = ®_ref; + break; + } + default: break; + } + + print_object_type(type); + commit_value(); + + print_mobject(refHandle); + commit_value(); + + if (ref != NULL) + { + print_object_ref(ref); + commit_value(); + } + + return ref; +} + +vpiHandle vpi_handle_by_name(PLI_BYTE8 *name, vpiHandle scope) +{ + vpiHandle ref = NULL; + + if (pipe_closed()) + return NULL; + + else if (strcmp(name, "top") == 0) ref = &module_ref; + else if (strcmp(name, "top.net") == 0) ref = &net_ref; + else if (strcmp(name, "top.port") == 0) ref = &port_ref; + else if (strcmp(name, "top.reg") == 0) ref = ®_ref; + else if (strcmp(name, "special") == 0) ref = &special_ref; + else if (scope == &module_ref && strcmp(name, "net") == 0) ref = &net_ref; + else if (scope == &module_ref && strcmp(name, "port") == 0) ref = &port_ref; + else if (scope == &module_ref && strcmp(name, "reg") == 0) ref = ®_ref; + + print_bytes(name); + commit_value(); + + print_mobject(scope); + commit_value(); + + if (ref != NULL) + { + print_object_ref(ref); + commit_value(); + } + + return ref; +} + +vpiHandle vpi_handle_by_index(vpiHandle object, PLI_INT32 indx) +{ + vpiHandle ref = NULL; + + if (pipe_closed()) + return NULL; + + else if (object == &net_ref && indx == 0) ref = &net_bit_0_ref; + else if (object == &net_ref && indx == 1) ref = &net_bit_1_ref; + + send("%d", indx); + commit_value(); + + print_mobject(object); + commit_value(); + + if (ref != NULL) + { + print_object_ref(ref); + commit_value(); + } + + return ref; +} + +vpiHandle vpi_handle_by_multi_index(vpiHandle obj, PLI_INT32 num_index, + PLI_INT32 *index_array) +{ + vpiHandle ref = NULL; + + if (pipe_closed() && (num_index > 0 && index_array == NULL)) + return NULL; + + if (obj == ®_ref && num_index == 2) + { + if (index_array[0] == 0 && index_array[1] == 0) ref = ®_bit_0_0_ref; + else if (index_array[0] == 0 && index_array[1] == 1) ref = ®_bit_0_1_ref; + else if (index_array[0] == 1 && index_array[1] == 0) ref = ®_bit_1_0_ref; + else if (index_array[0] == 1 && index_array[1] == 1) ref = ®_bit_1_1_ref; + } + + send("["); + for (int i = 0; i < num_index; i++) + { + if (i > 0) + send(","); + send("%d", index_array[i]); + } + send("]"); + commit_value(); + + print_mobject(obj); + commit_value(); + + if (ref != NULL) + { + print_object_ref(ref); + commit_value(); + } + + return ref; +} + +vpiHandle vpi_register_cb(p_cb_data cb_data_p) +{ + if (pipe_closed() || cb_data_p == NULL) + return NULL; + + send("CallbackInfo {"); + send("cbReason = "); + print_callback_reason(cb_data_p); + send(", "); + send("cbRoutine = <%d>, ", cb_data_p->cb_rtn(NULL)); + send("cbIndex = %d, ", cb_data_p->index); + send("cbData = "); + print_bytes(cb_data_p->user_data); + send("}"); + commit_value(); + + print_object_ref(&callback_ref); + commit_value(); + + return &callback_ref; +} + +PLI_INT32 vpi_remove_cb(vpiHandle cb_obj) +{ + if (pipe_closed() || cb_obj == NULL) + return false; + + print_object_ref(cb_obj); + commit_value(); + + return true; +}