From d563b67afb13885e9cb326978389fe5ca04c6a7b Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Mon, 9 Jun 2025 10:56:47 +0200 Subject: [PATCH 1/4] inline-verilog --- inline-verilog/Setup.hs | 2 + inline-verilog/inline-verilog.cabal | 54 +++ inline-verilog/src/Language/Verilog/Inline.hs | 364 ++++++++++++++++++ inline-verilog/test/tests.hs | 335 ++++++++++++++++ 4 files changed, 755 insertions(+) create mode 100644 inline-verilog/Setup.hs create mode 100644 inline-verilog/inline-verilog.cabal create mode 100644 inline-verilog/src/Language/Verilog/Inline.hs create mode 100644 inline-verilog/test/tests.hs diff --git a/inline-verilog/Setup.hs b/inline-verilog/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/inline-verilog/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/inline-verilog/inline-verilog.cabal b/inline-verilog/inline-verilog.cabal new file mode 100644 index 0000000..b27dc73 --- /dev/null +++ b/inline-verilog/inline-verilog.cabal @@ -0,0 +1,54 @@ +cabal-version: 2.2 +name: inline-verilog +version: 0.1.0.0 +synopsis: Lets you embed Verilog code into Haskell. +description: Utilities to inline Verilog code into Haskell using inline-c. See + tests for example on how to build. +license: MIT +license-file: LICENSE +author: Francesco Mazzoli +maintainer: f@mazzo.li +copyright: (c) 2025 Francesco Mazzoli +category: FFI +tested-with: GHC == 9.2.8, GHC == 9.4.7, GHC == 9.6.2 +build-type: Simple + +source-repository head + type: git + location: https://github.com/fpco/inline-c + +library + exposed-modules: Language.Verilog.Inline + build-depends: base >=4.7 && <5 + , bytestring + , inline-c >= 0.9.0.0 + , inline-c-cpp + , template-haskell + , text + , process + , temporary + , raw-strings-qq + , parsec + , parsers + , unordered-containers + , aeson + , bytestring + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: tests.hs + build-depends: base >=4 && <5 + , bytestring + , inline-c + , inline-verilog + , hspec + , containers + , template-haskell + , vector + , raw-strings-qq + , QuickCheck + default-language: Haskell2010 diff --git a/inline-verilog/src/Language/Verilog/Inline.hs b/inline-verilog/src/Language/Verilog/Inline.hs new file mode 100644 index 0000000..f43883e --- /dev/null +++ b/inline-verilog/src/Language/Verilog/Inline.hs @@ -0,0 +1,364 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module Language.Verilog.Inline + ( verilog + , block + , verbatim + ) where + +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Syntax as TH +import qualified Language.Haskell.TH.Quote as TH + +import qualified Language.C.Inline as C +import qualified Language.C.Inline.Context as C + +import Data.Maybe (maybeToList) +import Control.Monad (msum, void, MonadPlus, when, join) +import Data.Traversable (for) +import Control.Monad.IO.Class (liftIO) +import System.Exit (ExitCode(..)) +import System.Process (readProcessWithExitCode) +import System.Environment (lookupEnv) +import Data.Maybe (fromMaybe) +import System.IO.Temp (withSystemTempDirectory) +import Data.List (dropWhileEnd, intercalate) +import Data.Char (isSpace) +import Text.RawString.QQ (r) +import qualified Text.Parsec as Parsec +import qualified Text.Parsec.Pos as Parsec +import Text.Parser.Char +import Text.Parser.Combinators +import Text.Parser.LookAhead +import Text.Parser.Token +import qualified Text.Parser.Token.Highlight as Highlight +import qualified Data.HashSet as HashSet +import qualified Data.Aeson as Aeson +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Encoding as T +import qualified Data.ByteString.Lazy as BSL +import GHC.Generics (Generic) +import Data.IORef +import System.IO.Unsafe (unsafePerformIO) +import qualified Data.HashSet as HS +import Foreign.Ptr (Ptr) +import Data.Word + +data PortDirection = In | Out | InOut deriving (Show, Eq, Generic, Aeson.ToJSON, Aeson.FromJSON) + +data DataType = Wire | Reg | Logic | Integer | Real deriving (Show, Eq, Generic, Aeson.ToJSON, Aeson.FromJSON) + +data Range = Range { rangeMSB :: Int, rangeLSB :: Int } deriving (Show, Eq, Generic, Aeson.ToJSON, Aeson.FromJSON) + +rangeWidth :: Range -> Int +rangeWidth (Range msb lsb) = msb - lsb + 1 + +data Port = Port + { portDirection :: PortDirection + , portDataType :: Maybe DataType + , portRanges :: [Range] + , portName :: String + } deriving (Show, Eq, Generic, Aeson.ToJSON, Aeson.FromJSON) + +data Module = Module + { mName :: String + , mPorts :: [Port] + , mBody :: String + } deriving (Show, Eq, Generic, Aeson.ToJSON, Aeson.FromJSON) + +type VParser m = + ( Monad m + , Functor m + , Applicative m + , MonadPlus m + , Parsing m + , CharParsing m + , TokenParsing m + , LookAheadParsing m +#if (MIN_VERSION_base(4,13,0)) + , MonadFail m +#endif + ) + +verilogIdentStart :: [Char] +verilogIdentStart = ['a'..'z'] ++ ['A'..'Z'] ++ ['_'] + +-- Technically this also supports $, but we use it for things that +-- should also be Haskell identifiers. +verilogIdentLetter :: [Char] +verilogIdentLetter = ['a'..'z'] ++ ['A'..'Z'] ++ ['_'] ++ ['0'..'9'] + +verilogReservedWords :: HashSet.HashSet String +verilogReservedWords = HashSet.fromList + [ "always","and","assign","automatic" + , "begin","buf","bufif0","bufif1" + , "case","casex","casez","cell" + , "cmos","config","deassign","default" + , "defparam","design","disable","edge" + , "else","end","endcase","endconfig" + , "endfunction","endgenerate","endmodule","endprimitive" + , "endspecify","endtable","endtask","event" + , "for","force","forever","fork" + , "function","generate","genvar","highz0" + , "highz1","if","ifnone","incdir" + , "include","initial","inout","input" + , "instance","integer","join","larger" + , "liblist","library","localparam","macromodule" + , "medium","module","nand","negedge" + , "nmos","nor","noshow-cancelled","not" + , "notif0","notif1","or","output" + , "parameter","pmos","posedge","primitive" + , "pull0","pull1","pullup","pulldown" + , "pulsestyle_ondetect","pulsestyle_onevent","rcmos","real" + , "realtime","reg","release","repeat" + , "rnmos","rpmos","rtran","rtranif0" + , "rtranif1","scalared","show-cancelled","signed" + , "small","specify","specpa","strong0" + , "strong1","supply0","supply1","table" + , "task","time","tran","tranif0" + , "tranif1","tri","tri0","tri1" + , "triand","trior","trireg","use" + , "vectored","wait","wand","weak0" + , "weak1","while","wire","wor" + , "xnor","xor" ] + +verilogIdentStyle :: (TokenParsing m, Monad m) => IdentifierStyle m +verilogIdentStyle = IdentifierStyle + { _styleName = "Verilog identifier" + , _styleStart = oneOf verilogIdentStart + , _styleLetter = oneOf verilogIdentLetter + , _styleReserved = verilogReservedWords + , _styleHighlight = Highlight.Identifier + , _styleReservedHighlight = Highlight.ReservedIdentifier + } + +pPortDirection :: VParser m => m PortDirection +pPortDirection = msum + [ In <$ reserve verilogIdentStyle "input" + , Out <$ reserve verilogIdentStyle "output" + , InOut <$ reserve verilogIdentStyle "inout" + ] + +pDataType :: VParser m => m DataType +pDataType = msum + [ Wire <$ reserve verilogIdentStyle "wire" + , Reg <$ reserve verilogIdentStyle "reg" + , Logic <$ reserve verilogIdentStyle "logic" + , Integer <$ reserve verilogIdentStyle "integer" + , Real <$ reserve verilogIdentStyle "real" + ] + +pRange :: VParser m => m Range +pRange = brackets $ do + msb <- token natural + _ <- token (char ':') + lsb <- token natural + return $ Range (fromIntegral msb) (fromIntegral lsb) + +pPort :: VParser m => m Port +pPort = do + dir <- pPortDirection + typ <- optional pDataType + rngs <- many pRange + name <- ident verilogIdentStyle + return Port + { portDirection = dir + , portDataType = typ + , portRanges = rngs + , portName = name + } + +pModule :: VParser m => String -> m Module +pModule mname = do + reserve verilogIdentStyle "module" + ports <- lookAhead $ do + ports <- join . maybeToList <$> optional (parens (commaSep pPort)) + _ <- token (char ';') + return ports + body <- many anyChar + return $ Module mname ports body + +runParserInQ :: String -> (forall m. VParser m => m a) -> TH.Q a +runParserInQ s p = do + loc <- TH.location + let (line, col) = TH.loc_start loc + let parsecLoc = Parsec.newPos (TH.loc_filename loc) line col + let p' = Parsec.setPosition parsecLoc *> (spaces >> p) <* eof + case Parsec.parse p' (TH.loc_filename loc) s of + Left err -> do + -- TODO consider prefixing with "error while parsing Verilog" or similar + fail $ show err + Right res -> do + return res + +data VerilogFileItem = + VFIVerbatim String + | VFIModule Module + deriving (Eq, Show, Generic, Aeson.ToJSON, Aeson.FromJSON) + +verbatimItem :: VerilogFileItem -> TH.DecsQ +verbatimItem a = C.verbatim (T.unpack (T.decodeUtf8 (BSL.toStrict (Aeson.encode a)))) + +{-# NOINLINE verilogModuleCounter #-} +verilogModuleCounter :: IORef Int +verilogModuleCounter = unsafePerformIO (newIORef 0) + +data ModuleInfo = ModuleInfo + { miName :: String + , miInputs :: [(String, TH.Type, String)] -- Name, Haskell, C + , miOutputs :: [(String, TH.Type, String)] -- Name, Haskell, C + } deriving (Eq, Show) + +portType :: Port -> TH.Q (TH.Type, String) +portType p = case portRanges p of + [] -> (, "uint8_t") <$> [t| Bool |] + [n] | rangeWidth n == 1 -> (, "uint8_t") <$> [t| Bool |] + [n] | rangeWidth n <= 8 -> (, "uint8_t") <$> [t| Word8 |] + [n] | rangeWidth n <= 16 -> (, "uint16_t") <$> [t| Word16 |] + [n] | rangeWidth n <= 32 -> (, "uint32_t") <$> [t| Word32 |] + [n] | rangeWidth n <= 64 -> (, "uint64_t") <$> [t| Word64 |] + _ -> fail $ "Unsupported port ranges " ++ show (portRanges p) + +moduleInfo :: Module -> TH.Q ModuleInfo +moduleInfo m = do + when (HS.size (HS.fromList (map portName (mPorts m))) /= length (mPorts m)) $ + fail "Duplicated port names" + (inputs, outputs) <- fmap mconcat $ for (mPorts m) $ \port -> do + (hTyp, cTyp) <- portType port + let p = (portName port, hTyp, cTyp) + case portDirection port of + In -> return ([p], []) + Out -> return ([], [p]) + InOut -> fail "InOut not supported yet" -- would be very easy to fix, just lazy + return ModuleInfo + { miName = mName m + , miInputs = inputs + , miOutputs = outputs + } + +block :: TH.QuasiQuoter +block = TH.QuasiQuoter + { TH.quoteExp = \s -> do + -- create C symbol name + modCount <- liftIO (atomicModifyIORef' verilogModuleCounter (\c -> (c + 1, c + 1))) + let modn = "_inline_verilog_" ++ show modCount + -- parse verilog module and emit it in the file + modu <- runParserInQ s (pModule modn) + TH.addTopDecls =<< verbatimItem (VFIModule modu) + -- create FFI type + minfo <- moduleInfo modu + ffiImportName <- TH.newName . show =<< TH.newName "inline_verilog" + let ffiTyp = foldr + (\(_, ty, _) f -> TH.AppT (TH.AppT TH.ArrowT ty) f) + (foldr + (\(_, ty, _) f -> TH.AppT (TH.AppT TH.ArrowT (TH.AppT (TH.ConT ''Ptr) ty)) f) + (TH.AppT (TH.ConT ''IO) (TH.TupleT 0)) + (miOutputs minfo)) + (miInputs minfo) + -- create FFI declaration + ffiDec <- TH.forImpD TH.CCall TH.Unsafe modn ffiImportName (return ffiTyp) + TH.addTopDecls [ffiDec] + -- invoke ffi + TH.appsE (TH.varE ffiImportName : map (TH.varE . TH.mkName) [n | (n, _, _) <- miInputs minfo ++ miOutputs minfo]) + , TH.quotePat = const $ fail "inline-verilog: quotePat not implemented (quoteCode)" + , TH.quoteType = const $ fail "inline-verilog: quoteType not implemented (quoteCode)" + , TH.quoteDec = const $ fail "inline-verilog: quoteDec not implemented (quoteCode)" + } + +verbatim :: String -> TH.DecsQ +verbatim s = verbatimItem (VFIVerbatim s) + +invokeCommand :: String -> [String] -> IO (String, String) +invokeCommand cmd args = do + (code, stdout, stderr) <- readProcessWithExitCode cmd args "" + case code of + ExitSuccess -> return (stdout, stderr) + ExitFailure fcode -> fail $ unlines + [ "Command: " ++ (foldl (\a b -> a ++ " " ++ show b) " " (cmd : args)) + , "Exit code: " ++ show fcode + , "Output:\n" ++ unlines (map (\l -> " " ++ l) (lines stdout)) + , "Error:\n" ++ unlines (map (\n -> " " ++ n) (lines stderr)) + ] + +compileVerilog :: String -> TH.Q FilePath +compileVerilog src = do + -- executables we need + gpp <- fromMaybe "g++" <$> liftIO (lookupEnv "INLINE_C_CPP_COMPILER") + verilator <- fromMaybe "verilator" <$> liftIO (lookupEnv "INLINE_C_VERILATOR") + ld <- fromMaybe "ld" <$> liftIO (lookupEnv "INLINE_C_LINKER") + -- generate verilog source and collect module infos + mref :: IORef [ModuleInfo] <- liftIO (newIORef []) + vsource <- fmap unlines $ for (filter (not . all isSpace) (lines src)) $ \l -> do + case Aeson.eitherDecode (BSL.fromStrict (T.encodeUtf8 (T.pack l))) of + Left err -> fail $ "Impossible: could not decode item line: " ++ err + Right fileItem -> case fileItem of + VFIVerbatim v -> return v + VFIModule m -> do + minfo <- moduleInfo m + liftIO (modifyIORef' mref (minfo :)) + return ("module " ++ mName m ++ " " ++ mBody m) + minfos <- liftIO (readIORef mref) + -- compile all sources in the same dir + mergedOFile <- TH.addTempFile "o" + liftIO $ withSystemTempDirectory "inline-verilog" $ \tmpDir -> do + verilatorRoot <- do + (rootOut, _) <- invokeCommand verilator ["--getenv", "VERILATOR_ROOT"] + return (dropWhileEnd isSpace (dropWhile isSpace rootOut)) + let svFile = tmpDir ++ "/src.sv" + writeFile svFile vsource + modsObjs <- fmap concat $ for minfos $ \minfo -> do + let oFile = tmpDir ++ "/" ++ miName minfo ++ ".o" + _ <- invokeCommand verilator ["--sv", svFile, "--top-module", miName minfo, "--cc", "--build", "--Mdir", tmpDir] + let cppFile = tmpDir ++ "/" ++ miName minfo ++ ".cpp" + let inputParams = [cTyp ++ " " ++ n | (n, _, cTyp) <- miInputs minfo] + let outputParams = [cTyp ++ "* " ++ n | (n, _, cTyp) <- miOutputs minfo] + let fullParams = intercalate ", " (inputParams ++ outputParams) + let storeInputs = unlines ["top->" ++ n ++ " = " ++ n ++ ";" | (n, _, _) <- miInputs minfo] + let storeOutputs = unlines ["*" ++ n ++ " = top->" ++ n ++ ";" | (n, _, _) <- miOutputs minfo] + T.writeFile cppFile $ + T.replace "MNAME" (T.pack (miName minfo)) $ + T.replace "MPARAMS" (T.pack fullParams) $ + T.replace "MINPUTS" (T.pack storeInputs) $ + T.replace "MOUTPUTS" (T.pack storeOutputs) $ T.pack [r| + #include "VMNAME.h" + #include "verilated.h" + + extern "C" void MNAME(MPARAMS) { + VerilatedContext* contextp = new VerilatedContext; + VMNAME* top = new VMNAME{contextp, "TOP"}; + MINPUTS + if (!contextp->gotFinish()) { + top->eval(); // Triggers the initial block + } + top->final(); + MOUTPUTS + delete top; + delete contextp; + } + |] + let gppArgs = ["-c", "-I", verilatorRoot ++ "/include", "-I", tmpDir, cppFile, "-o", oFile] + _ <- invokeCommand gpp gppArgs + return [oFile, tmpDir ++ "/V" ++ (miName minfo) ++ "__ALL.o"] + let ldArgs = ["-r", "-o", mergedOFile, tmpDir ++ "/verilated.o", tmpDir ++ "/verilated_threads.o"] ++ modsObjs + void (invokeCommand ld ldArgs) + return mergedOFile + +verilogCtx :: C.Context +verilogCtx = mempty + { C.ctxForeignSrcLang = Just TH.RawObject + , C.ctxRawObjectCompile = Just compileVerilog + } + +verilog :: TH.DecsQ +verilog = C.context verilogCtx + diff --git a/inline-verilog/test/tests.hs b/inline-verilog/test/tests.hs new file mode 100644 index 0000000..91835bc --- /dev/null +++ b/inline-verilog/test/tests.hs @@ -0,0 +1,335 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +import qualified Language.Verilog.Inline as V +import Data.Word +import Text.RawString.QQ +import Foreign.Marshal.Alloc (alloca) +import Foreign.Storable (peek) +import Data.Bits +import Text.Printf +import Test.Hspec +import qualified Test.QuickCheck as QC + +V.verilog + +hello_world :: IO () +hello_world = + [V.block| + module; + initial begin + $display("Hello World!"); + end + endmodule + |] + +adder :: Word16 -> Word16 -> IO (Bool, Word16) +adder a b = alloca $ \sum -> alloca $ \carry_out -> do + [V.block| + module ( + input [15:0] a, + input [15:0] b, + output [15:0] sum, + output carry_out + ); + assign {carry_out, sum} = a + b; + endmodule + |] + (,) <$> peek carry_out <*> peek sum + +V.verbatim [r| + module popcount #( + parameter WIDTH = 32 + ) ( + input wire [WIDTH-1:0] data, + // The output width must be large enough to hold the maximum possible + // count, which is equal to WIDTH. $clog2(WIDTH) gives the number of + // bits to address WIDTH items (e.g., 6 for 64), so we need one extra + // bit to hold the value of WIDTH itself. + output reg [$clog2(WIDTH):0] count + ); + + integer i; + + // This combinational block continuously calculates the popcount. + // Synthesis tools will typically implement this as an efficient adder tree. + always @(*) begin + count = 0; + for (i = 0; i < WIDTH; i = i + 1) begin + count = count + {{$clog2(WIDTH){1'b0}}, data[i]}; + end + end + + endmodule +|] + +bitManip :: Word64 -> Word32 -> Word8 -> Word8 -> IO (Word64, Word32, Bool) +bitManip in_A in_B shuffle_control op_select = do + alloca $ \out_shuffled -> alloca $ \out_op_result -> alloca $ \out_popcount_A_gt_B -> do + [V.block| + module ( + input wire [63:0] in_A, + input wire [31:0] in_B, + input wire [2:0] shuffle_control, + input wire [1:0] op_select, + output reg [63:0] out_shuffled, + output reg [31:0] out_op_result, + output reg out_popcount_A_gt_B + ); + // -- Section 1: Parallel Bit Shuffling -- + // This block shuffles the 64 bits of `in_A` based on `shuffle_control`. + // This functionality remains unchanged. + always @(*) begin + case (shuffle_control) + 3'b000: out_shuffled = in_A; // No change + 3'b001: out_shuffled = {in_A[31:0], in_A[63:32]}; // Swap halves + 3'b010: out_shuffled = {<<{in_A}}; // Bit reversal + 3'b011: out_shuffled = (in_A << 16) | (in_A >> 48); // 16-bit barrel rotate left + 3'b100: out_shuffled = {in_A[0], in_A[1], in_A[2], in_A[3], in_A[4], in_A[5], in_A[6], in_A[7], + in_A[15:8], in_A[23:16], in_A[31:24], in_A[39:32], + in_A[47:40], in_A[55:48], in_A[63:56]}; // Swap bytes within words + default: out_shuffled = 64'hDEADBEEF_DEADBEEF; // Default case + endcase + end + + // -- Section 2: Parallel Bitwise Operation -- + // This block performs a bitwise operation between the lower 32 bits of `in_A` + // and the 32 bits of `in_B`. This functionality remains unchanged. + always @(*) begin + case (op_select) + 2'b00: out_op_result = in_A[31:0] & in_B; // 32 parallel ANDs + 2'b01: out_op_result = in_A[31:0] | in_B; // 32 parallel ORs + 2'b10: out_op_result = in_A[31:0] ^ in_B; // 32 parallel XORs + default: out_op_result = ~in_A[31:0]; // 32 parallel NOTs + endcase + end + + // -- Section 3: Parallel Population Count Comparison (Refactored) -- + // Wires to connect to the outputs of the Popcount modules. + wire [$clog2(64):0] popcount_A_result; // Result from 64-bit popcount, 7 bits wide + wire [$clog2(32):0] popcount_B_result; // Result from 32-bit popcount, 6 bits wide + + // Instantiate the Popcount module for the 64-bit input 'in_A'. + // The WIDTH parameter is set to 64. + popcount #(.WIDTH(64)) popcount_A_inst ( + .data(in_A), + .count(popcount_A_result) + ); + + // Instantiate the Popcount module for the 32-bit input 'in_B'. + // The WIDTH parameter is set to 32. + popcount #(.WIDTH(32)) popcount_B_inst ( + .data(in_B), + .count(popcount_B_result) + ); + + // Perform the comparison on the results from the instantiated modules. + always @(*) begin + // FIX: Explicitly zero-extend popcount_B_result from 6 bits to 7 bits to + // match the width of popcount_A_result. This resolves the WIDTHEXPAND warning. + if (popcount_A_result > {1'b0, popcount_B_result}) begin + out_popcount_A_gt_B = 1'b1; + end else begin + out_popcount_A_gt_B = 1'b0; + end + end + + endmodule + |] + (,,) <$> peek out_shuffled <*> peek out_op_result <*> peek out_popcount_A_gt_B + +-- The main function that encapsulates the logic of the Verilog module. +-- It takes the same inputs and returns a tuple with the three outputs. +bitManipHs + :: Word64 -- ^ in_A: Primary 64-bit data input + -> Word32 -- ^ in_B: Secondary 32-bit data input + -> Word8 -- ^ shuffle_control: 3-bit control signal (0-7) + -> Word8 -- ^ op_select: 2-bit control signal (0-3) + -> (Word64, Word32, Bool) -- ^ (out_shuffled, out_op_result, out_popcount_A_gt_B) +bitManipHs in_A in_B shuffle_control op_select = + (out_shuffled, out_op_result, out_popcount_A_gt_B) + where + -- Section 1: Parallel Bit Shuffling + -- Translates the Verilog case statement for shuffling `in_A`. + -- Operations that are a single netlist in hardware require masking, + -- shifting, and combining in software. + out_shuffled = case shuffle_control of + 0 -> in_A -- No change + 1 -> (in_A `shiftL` 32) .|. (in_A `shiftR` 32) -- Swap halves + 2 -> bitReverse64 in_A -- Bit reversal + 3 -> rotateL in_A 16 -- 16-bit barrel rotate left + 4 -> custom_shuffle in_A -- The complex byte-swapping pattern + _ -> 0xDEADBEEFDEADBEEF -- Default case + + -- Helper function for the specific byte shuffle from the Verilog. + -- This is a great example of something trivial in hardware (rewiring) + -- that is complex and slow in software. + custom_shuffle :: Word64 -> Word64 + custom_shuffle val = + let -- Extract each byte from the input value + byte0 = (val `shiftR` 0) .&. 0xFF + byte1 = (val `shiftR` 8) .&. 0xFF + byte2 = (val `shiftR` 16) .&. 0xFF + byte3 = (val `shiftR` 24) .&. 0xFF + byte4 = (val `shiftR` 32) .&. 0xFF + byte5 = (val `shiftR` 40) .&. 0xFF + byte6 = (val `shiftR` 48) .&. 0xFF + byte7 = (val `shiftR` 56) .&. 0xFF + -- Scatter the first 8 bits individually to the top byte of the output, + -- which is what the Verilog `{in_A[0], in_A[1], ...}` syntax implies. + bit_scatter = sum [ if testBit val i then bit (63-i) else 0 | i <- [0..7] ] + in + bit_scatter -- Bits 0-7 -> Bits 63-56 + .|. (byte1 `shiftL` 48) -- Byte 1 -> Bits 55-48 + .|. (byte2 `shiftL` 40) -- Byte 2 -> Bits 47-40 + .|. (byte3 `shiftL` 32) -- Byte 3 -> Bits 39-32 + .|. (byte4 `shiftL` 24) -- Byte 4 -> Bits 31-24 + .|. (byte5 `shiftL` 16) -- Byte 5 -> Bits 23-16 + .|. (byte6 `shiftL` 8) -- Byte 6 -> Bits 15-8 + .|. byte7 -- Byte 7 -> Bits 7-0 + + -- Section 2: Parallel Bitwise Operation + -- Translates the Verilog case statement for the bitwise operation. + -- `fromIntegral` truncates the 64-bit `in_A` to 32 bits to match `in_B`. + in_A_32 = fromIntegral in_A :: Word32 + out_op_result = case op_select of + 0 -> in_A_32 .&. in_B + 1 -> in_A_32 .|. in_B + 2 -> in_A_32 `xor` in_B + _ -> complement in_A_32 -- Default is NOT + + -- Section 3: Parallel Population Count Comparison + -- `popCount` is a built-in, efficient software equivalent to the hardware + -- adder tree described in the Verilog comments. + popcount_A = popCount in_A + popcount_B = popCount in_B + out_popcount_A_gt_B = popcount_A > popcount_B + +main :: IO () +main = hspec $ do + describe "Verilog Adder" $ do + -- Section 1: Property-based testing with QuickCheck + -- This section verifies the adder's correctness against the native Haskell + -- addition for a large number of random inputs. + context "Property-based tests (QuickCheck)" $ do + it "should match Haskell's native addition and carry logic" $ + -- The 'property' function tells Hspec to run a QuickCheck test. + QC.property $ \(a :: Word16, b :: Word16) -> do + -- Call the adder function (our FFI-bound Verilog module) + (verilog_carry, verilog_sum) <- adder a b + + -- Calculate the expected results using a wider Integer type in Haskell + -- to avoid overflow and correctly determine the carry bit. + let expected_full_sum = (fromIntegral a :: Integer) + (fromIntegral b :: Integer) + let expected_sum = fromIntegral expected_full_sum :: Word16 + let expected_carry = expected_full_sum > fromIntegral (maxBound :: Word16) + + -- Assert that the Verilog results match the Haskell results + verilog_sum `shouldBe` expected_sum + verilog_carry `shouldBe` expected_carry + + -- Section 2: Edge case testing + -- This section manually tests specific values that are often sources of bugs, + -- such as zero, maximum values, and inputs that just barely cause a carry. + context "Manual edge case tests" $ do + it "handles adding zero to zero" $ do + (carry, sum_res) <- adder 0 0 + sum_res `shouldBe` 0 + carry `shouldBe` False + + it "handles a simple addition without carry" $ do + (carry, sum_res) <- adder 100 250 + sum_res `shouldBe` 350 + carry `shouldBe` False + + it "handles adding zero to the maximum value" $ do + (carry, sum_res) <- adder maxBound 0 + sum_res `shouldBe` maxBound + carry `shouldBe` False + + it "correctly generates a carry when wrapping around" $ do + -- 65535 + 1 = 65536, which is 2^16. + -- The sum should be 0, and the carry should be 1. + (carry, sum_res) <- adder maxBound 1 + sum_res `shouldBe` 0 + carry `shouldBe` True + + it "handles adding the maximum value to itself" $ do + -- 65535 + 65535 = 131070 = 1*65536 + 65534 + -- The sum should be 65534 (0xFFFE), and the carry should be 1. + (carry, sum_res) <- adder maxBound maxBound + sum_res `shouldBe` (maxBound - 1) + carry `shouldBe` True + + describe "Bit manipulation" $ do + -- Run the same set of tests for both implementations + context "Haskell Implementation" $ + bitManipSpec (\a b c d -> return (bitManipHs a b c d)) + context "Verilog (Simulated) Implementation" $ + bitManipSpec bitManip + +type BitManipFn = Word64 -> Word32 -> Word8 -> Word8 -> IO (Word64, Word32, Bool) + +-- A generic test suite that can be run on any function of type BitManipFn. +bitManipSpec :: BitManipFn -> Spec +bitManipSpec bitManipFn = do + -- Test Case 1: Baseline and AND Operation + context "with shuffle_control=0 (no change) and op_select=0 (AND)" $ do + let in_A = 0xAAAAAAAAAAAAAAAA + let in_B = 0xFFFF0000 + (shuf, op, pop) <- runIO (bitManipFn in_A in_B 0 0) + + it "passes through in_A unchanged" $ + shuf `shouldBe` 0xAAAAAAAAAAAAAAAA + + it "performs a bitwise AND" $ + op `shouldBe` 0xAAAA0000 + + it "correctly compares population counts (A > B)" $ + pop `shouldBe` True + + -- Test Case 2: Swap Halves and XOR Operation + context "with shuffle_control=1 (swap halves) and op_select=2 (XOR)" $ do + let in_A = 0x123456789ABCDEF0 + let in_B = 0xFFFFFFFF + (shuf, op, pop) <- runIO (bitManipFn in_A in_B 1 2) + + it "swaps the upper and lower halves of in_A" $ + shuf `shouldBe` 0x9ABCDEF012345678 + + it "performs a bitwise XOR" $ + op `shouldBe` 0x6543210F + + it "correctly compares population counts (A == B)" $ + pop `shouldBe` False + + -- Test Case 3: Bit Reversal and OR Operation + context "with shuffle_control=2 (bit reverse) and op_select=1 (OR)" $ do + let in_A = 0xF000000000000001 + let in_B = 0x0F0F0F0F + (shuf, op, pop) <- runIO (bitManipFn in_A in_B 2 1) + + it "reverses the bits of in_A" $ + shuf `shouldBe` 0x800000000000000F + + it "performs a bitwise OR" $ + op `shouldBe` 0x0F0F0F0F + + it "correctly compares population counts (A < B)" $ + pop `shouldBe` False + + -- Test Case 4: Barrel Rotate and NOT Operation + context "with shuffle_control=3 (rotate) and op_select=3 (NOT)" $ do + let in_A = 0x0001000200030004 + let in_B = 0x00000000 + (shuf, op, pop) <- runIO (bitManipFn in_A in_B 3 3) + + it "rotates in_A left by 16 bits" $ + shuf `shouldBe` 0x0002000300040001 + + it "performs a bitwise NOT (default case)" $ + op `shouldBe` 0xFFFCFFFB + + it "correctly compares population counts (A > B)" $ + pop `shouldBe` True From 99bc0e48f20c923a357f461da6af6940a4216cdc Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Mon, 9 Jun 2025 14:51:10 +0200 Subject: [PATCH 2/4] support comments in argument list --- inline-verilog/inline-verilog.cabal | 1 + inline-verilog/src/Language/Verilog/Inline.hs | 49 ++++++++++++++----- inline-verilog/test/tests.hs | 14 +++--- 3 files changed, 46 insertions(+), 18 deletions(-) diff --git a/inline-verilog/inline-verilog.cabal b/inline-verilog/inline-verilog.cabal index b27dc73..d0541f6 100644 --- a/inline-verilog/inline-verilog.cabal +++ b/inline-verilog/inline-verilog.cabal @@ -33,6 +33,7 @@ library , unordered-containers , aeson , bytestring + , transformers hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/inline-verilog/src/Language/Verilog/Inline.hs b/inline-verilog/src/Language/Verilog/Inline.hs index f43883e..b38a98e 100644 --- a/inline-verilog/src/Language/Verilog/Inline.hs +++ b/inline-verilog/src/Language/Verilog/Inline.hs @@ -5,9 +5,10 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} module Language.Verilog.Inline ( verilog @@ -43,23 +44,24 @@ import Text.Parser.Token import qualified Text.Parser.Token.Highlight as Highlight import qualified Data.HashSet as HashSet import qualified Data.Aeson as Aeson +import qualified Data.Aeson.TH as Aeson import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Encoding as T import qualified Data.ByteString.Lazy as BSL -import GHC.Generics (Generic) import Data.IORef import System.IO.Unsafe (unsafePerformIO) import qualified Data.HashSet as HS import Foreign.Ptr (Ptr) import Data.Word +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Applicative (Alternative) -data PortDirection = In | Out | InOut deriving (Show, Eq, Generic, Aeson.ToJSON, Aeson.FromJSON) +data PortDirection = In | Out | InOut deriving (Show, Eq) -data DataType = Wire | Reg | Logic | Integer | Real deriving (Show, Eq, Generic, Aeson.ToJSON, Aeson.FromJSON) - -data Range = Range { rangeMSB :: Int, rangeLSB :: Int } deriving (Show, Eq, Generic, Aeson.ToJSON, Aeson.FromJSON) +data DataType = Wire | Reg | Logic | Integer | Real deriving (Show, Eq) +data Range = Range { rangeMSB :: Int, rangeLSB :: Int } deriving (Show, Eq) rangeWidth :: Range -> Int rangeWidth (Range msb lsb) = msb - lsb + 1 @@ -68,13 +70,19 @@ data Port = Port , portDataType :: Maybe DataType , portRanges :: [Range] , portName :: String - } deriving (Show, Eq, Generic, Aeson.ToJSON, Aeson.FromJSON) + } deriving (Show, Eq) data Module = Module { mName :: String , mPorts :: [Port] , mBody :: String - } deriving (Show, Eq, Generic, Aeson.ToJSON, Aeson.FromJSON) + } deriving (Show, Eq) + +Aeson.deriveJSON Aeson.defaultOptions ''PortDirection +Aeson.deriveJSON Aeson.defaultOptions ''DataType +Aeson.deriveJSON Aeson.defaultOptions ''Range +Aeson.deriveJSON Aeson.defaultOptions ''Port +Aeson.deriveJSON Aeson.defaultOptions ''Module type VParser m = ( Monad m @@ -188,13 +196,31 @@ pModule mname = do body <- many anyChar return $ Module mname ports body +newtype VParserImpl t a = VPI (t a) + deriving (MonadFail, Alternative, Functor, Applicative, Monad, MonadPlus, Semigroup, Parsing, CharParsing, LookAheadParsing) + +instance MonadTrans VParserImpl where + lift = VPI + +instance (Monad m, MonadPlus m, CharParsing m) => TokenParsing (VParserImpl m) where + someSpace = do + skipSome (satisfy isSpace) + msum + [ try (string "//") >> manyTill anyChar (try (char '\n')) >> someSpace + , try (string "/*") >> manyTill anyChar (try (string "*/")) >> someSpace + , return () + ] + +runVParser :: VParserImpl (Parsec.Parsec String ()) a -> Parsec.SourceName -> String -> Either Parsec.ParseError a +runVParser (VPI m) name s = Parsec.parse m name s + runParserInQ :: String -> (forall m. VParser m => m a) -> TH.Q a runParserInQ s p = do loc <- TH.location let (line, col) = TH.loc_start loc let parsecLoc = Parsec.newPos (TH.loc_filename loc) line col - let p' = Parsec.setPosition parsecLoc *> (spaces >> p) <* eof - case Parsec.parse p' (TH.loc_filename loc) s of + let p' = VPI (Parsec.setPosition parsecLoc) *> (spaces >> p) <* eof + case runVParser p' (TH.loc_filename loc) s of Left err -> do -- TODO consider prefixing with "error while parsing Verilog" or similar fail $ show err @@ -204,7 +230,8 @@ runParserInQ s p = do data VerilogFileItem = VFIVerbatim String | VFIModule Module - deriving (Eq, Show, Generic, Aeson.ToJSON, Aeson.FromJSON) + deriving (Eq, Show) +Aeson.deriveJSON Aeson.defaultOptions ''VerilogFileItem verbatimItem :: VerilogFileItem -> TH.DecsQ verbatimItem a = C.verbatim (T.unpack (T.decodeUtf8 (BSL.toStrict (Aeson.encode a)))) diff --git a/inline-verilog/test/tests.hs b/inline-verilog/test/tests.hs index 91835bc..f52de36 100644 --- a/inline-verilog/test/tests.hs +++ b/inline-verilog/test/tests.hs @@ -69,13 +69,13 @@ bitManip in_A in_B shuffle_control op_select = do alloca $ \out_shuffled -> alloca $ \out_op_result -> alloca $ \out_popcount_A_gt_B -> do [V.block| module ( - input wire [63:0] in_A, - input wire [31:0] in_B, - input wire [2:0] shuffle_control, - input wire [1:0] op_select, - output reg [63:0] out_shuffled, - output reg [31:0] out_op_result, - output reg out_popcount_A_gt_B + input wire [63:0] in_A, // Primary 64-bit data input for shuffling and operations + input wire [31:0] in_B, // Secondary 32-bit data input for operations + input wire [2:0] shuffle_control, // Selects the shuffle operation for in_A + input wire [1:0] op_select, // Selects the bitwise operation for in_A[31:0] and in_B + output reg [63:0] out_shuffled, // Output of the 64-bit shuffle operation + output reg [31:0] out_op_result, // Output of the 32-bit bitwise operation + output reg out_popcount_A_gt_B // '1' if popcount of in_A > popcount of in_B ); // -- Section 1: Parallel Bit Shuffling -- // This block shuffles the 64 bits of `in_A` based on `shuffle_control`. From 3f988dcfbd90a468806b90b57c48f69cdc6bc255 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Mon, 9 Jun 2025 14:58:04 +0200 Subject: [PATCH 3/4] README.md --- inline-verilog/README.md | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 inline-verilog/README.md diff --git a/inline-verilog/README.md b/inline-verilog/README.md new file mode 100644 index 0000000..8f798e9 --- /dev/null +++ b/inline-verilog/README.md @@ -0,0 +1,10 @@ +Very quick and dirty "inline Verilog" support for Haskell. See `tests.hs` for examples. + +Currently missing or untested: + +* Inputs/outputs wider than 64 bits. +* `struct` ports. +* Multidimensional input/output port, e.g. `reg [15:0] foo [3:0][3:0]` . +* Importing. + +All of the above should be easy, I just didn't bother yet. \ No newline at end of file From 6c649e8a7e9c771ef99c5067699b2e833656ea05 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Mon, 9 Jun 2025 15:06:29 +0200 Subject: [PATCH 4/4] Small tweaks --- inline-verilog/src/Language/Verilog/Inline.hs | 6 +++--- inline-verilog/test/tests.hs | 2 -- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/inline-verilog/src/Language/Verilog/Inline.hs b/inline-verilog/src/Language/Verilog/Inline.hs index b38a98e..e3d3aca 100644 --- a/inline-verilog/src/Language/Verilog/Inline.hs +++ b/inline-verilog/src/Language/Verilog/Inline.hs @@ -320,7 +320,7 @@ invokeCommand cmd args = do compileVerilog :: String -> TH.Q FilePath compileVerilog src = do -- executables we need - gpp <- fromMaybe "g++" <$> liftIO (lookupEnv "INLINE_C_CPP_COMPILER") + cpp <- fromMaybe "g++" <$> liftIO (lookupEnv "INLINE_C_CPP_COMPILER") verilator <- fromMaybe "verilator" <$> liftIO (lookupEnv "INLINE_C_VERILATOR") ld <- fromMaybe "ld" <$> liftIO (lookupEnv "INLINE_C_LINKER") -- generate verilog source and collect module infos @@ -373,8 +373,8 @@ compileVerilog src = do delete contextp; } |] - let gppArgs = ["-c", "-I", verilatorRoot ++ "/include", "-I", tmpDir, cppFile, "-o", oFile] - _ <- invokeCommand gpp gppArgs + let cppArgs = ["-c", "-I", verilatorRoot ++ "/include", "-I", tmpDir, cppFile, "-o", oFile] + _ <- invokeCommand cpp cppArgs return [oFile, tmpDir ++ "/V" ++ (miName minfo) ++ "__ALL.o"] let ldArgs = ["-r", "-o", mergedOFile, tmpDir ++ "/verilated.o", tmpDir ++ "/verilated_threads.o"] ++ modsObjs void (invokeCommand ld ldArgs) diff --git a/inline-verilog/test/tests.hs b/inline-verilog/test/tests.hs index f52de36..11c2cf3 100644 --- a/inline-verilog/test/tests.hs +++ b/inline-verilog/test/tests.hs @@ -126,8 +126,6 @@ bitManip in_A in_B shuffle_control op_select = do // Perform the comparison on the results from the instantiated modules. always @(*) begin - // FIX: Explicitly zero-extend popcount_B_result from 6 bits to 7 bits to - // match the width of popcount_A_result. This resolves the WIDTHEXPAND warning. if (popcount_A_result > {1'b0, popcount_B_result}) begin out_popcount_A_gt_B = 1'b1; end else begin