add pre-processing

bittide-experiments/bittide-experiments.cabal

@@ -106,6 +106,7 @@ library
     text,
     typelits-witnesses,
     vector,
+    vivado-hs,
 
   exposed-modules:
     Bittide.Github.Artifacts

bittide-experiments/src/Bittide/Hitl.hs

@@ -46,6 +46,7 @@ module Bittide.Hitl (
   -- * Test definition
   HitlTestGroup (..),
   HitlTestCase (..),
+  CasePreProcessing (..),
   MayHavePostProcData (..),
   Done,
   Success,
@@ -78,6 +79,9 @@ import Data.Map.Strict qualified as Map
 
 import System.Exit (ExitCode)
 
+import Vivado (VivadoHandle)
+import Vivado.Tcl (HwTarget)
+
 {- | Fully qualified name to a function that is the target for Clash
 compilation. E.g. @Bittide.Foo.topEntity@.
 -}
@@ -177,10 +181,12 @@ data HitlTestGroup where
     , extraXdcFiles :: [String]
     , testCases :: [HitlTestCase HwTargetRef a b]
     -- ^ List of test cases
+    , mPreProc :: Maybe (VivadoHandle -> String -> HwTarget -> IO ())
+    -- ^ Optional pre-processing step. First argument is the name of the test
     , mPostProc :: Maybe (FilePath -> ExitCode -> IO ())
     -- ^ Optional post processing step.
     , externalHdl :: [String]
-    -- ^ List of external HDL files to include in the project
+    -- ^ List of external HDL files to include in he project
     } ->
     HitlTestGroup
 
@@ -192,12 +198,23 @@ data HitlTestCase h a b where
     (Show h, Show a, BitPack a, Show b, Typeable h) =>
     { name :: String
     , parameters :: Map h a
+    , preProc :: CasePreProcessing
     , postProcData :: b
     } ->
     HitlTestCase h a b
 
 deriving instance Show (HitlTestCase h a b)
 
+data CasePreProcessing
+  = NoPreProcess
+  | InheritPreProcess
+  | CustomPreProcess (VivadoHandle -> HwTarget -> IO ())
+
+instance Show CasePreProcessing where
+  show NoPreProcess = "NoPreProcess"
+  show InheritPreProcess = "InheritPreProcess"
+  show (CustomPreProcess _) = "CustomPreProcess <func>"
+
 -- | A class for extracting optional post processing data from a test.
 class MayHavePostProcData b where
   -- | Returns the test names with some post processing data of type @c@,
@@ -252,6 +269,7 @@ testCasesFromEnum hwTs ppd =
     { name = show constr
     , parameters = Map.fromList ((,constr) <$> hwTs)
     , postProcData = ppd
+    , preProc = InheritPreProcess
     }
   | (constr :: a) <- [minBound ..]
   ]

bittide-instances/bittide-instances.cabal

@@ -110,6 +110,7 @@ common common-options
     text,
     unix,
     vector,
+    vivado-hs,
 
 library
   import: common-options
@@ -126,6 +127,7 @@ library
     Bittide.Instances.Hitl.LinkConfiguration
     Bittide.Instances.Hitl.Post.BoardTestExtended
     Bittide.Instances.Hitl.Post.PostProcess
+    Bittide.Instances.Hitl.Pre.Program
     Bittide.Instances.Hitl.Setup
     Bittide.Instances.Hitl.SyncInSyncOut
     Bittide.Instances.Hitl.TemperatureMonitor

bittide-instances/src/Bittide/Instances/Hitl/BoardTest.hs

@@ -22,8 +22,9 @@ import Bittide.Instances.Hitl.Post.BoardTestExtended
 import Bittide.Instances.Hitl.Post.PostProcess
 
 import Bittide.Hitl (
-  HitlTestCase (HitlTestCase),
+  HitlTestCase (..),
   HitlTestGroup (..),
+  CasePreProcessing (..),
   hitlVio,
   hitlVioBool,
   paramForHwTargets,
@@ -181,7 +182,13 @@ testSimple =
     { topEntity = 'boardTestSimple
     , extraXdcFiles = []
     , externalHdl = []
-    , testCases = [HitlTestCase "Simple" (paramForHwTargets allHwTargets ()) ()]
+    , testCases = [HitlTestCase
+      { name = "Simple"
+      , parameters = (paramForHwTargets allHwTargets ())
+      , postProcData = ()
+      , preProc = InheritPreProcess
+      }]
+    , mPreProc = Nothing
     , mPostProc = Nothing
     }
 
@@ -192,6 +199,7 @@ testExtended =
     , extraXdcFiles = []
     , externalHdl = []
     , testCases = testCasesFromEnum @Test allHwTargets ()
+    , mPreProc = Nothing
     , mPostProc = Just postBoardTestExtendedFunc
     }
 

bittide-instances/src/Bittide/Instances/Hitl/FincFdec.hs

@@ -222,5 +222,6 @@ tests =
     , extraXdcFiles = []
     , externalHdl = []
     , testCases = testCasesFromEnum @Test [HwTargetByIndex 7] ()
+    , mPreProc = Nothing
     , mPostProc = Nothing
     }

bittide-instances/src/Bittide/Instances/Hitl/FullMeshHwCc.hs

@@ -519,8 +519,10 @@ mkTest topEntity =
                   , clockOffsets = Nothing
                   , startupDelays = toList $ repeat @FpgaCount 0
                   }
+            , preProc = InheritPreProcess
             }
         ]
+    , mPreProc = Nothing
     , mPostProc = Nothing
     }
  where

bittide-instances/src/Bittide/Instances/Hitl/FullMeshSwCc.hs

@@ -688,9 +688,11 @@ tests =
                 , clockOffsets = Nothing
                 , startupDelays = toList $ repeat @FpgaCount 0
                 }
+          , preProc = InheritPreProcess
           }
         | n <- [0 .. testsToRun - 1]
         ]
+    , mPreProc = Nothing
     , mPostProc = Nothing
     }
  where

bittide-instances/src/Bittide/Instances/Hitl/HwCcTopologies.hs

@@ -840,6 +840,7 @@ tests = testGroup
             , clockOffsets = Nothing
             , startupDelays = toList $ repeat @FpgaCount 0
             }
+      , preProc = InheritPreProcess
       }
 
   -- tests the given topology
@@ -873,6 +874,7 @@ tests = testGroup
             , clockOffsets = toList <$> clockShifts
             , startupDelays = fromIntegral <$> toList startDelays
             }
+      , preProc = InheritPreProcess
       }
 
   maybeVecToVecMaybe :: forall n a. (KnownNat n) => Maybe (Vec n a) -> Vec n (Maybe a)
@@ -919,6 +921,7 @@ tests = testGroup
           -- make sure the clock offsets detected during calibration is still the same
         , validateClockOffsetCalibration
         ]
+    , mPreProc = Nothing
     , mPostProc = Nothing
     }
 {- FOURMOLU_ENABLE -}

bittide-instances/src/Bittide/Instances/Hitl/LinkConfiguration.hs

@@ -285,7 +285,9 @@ tests =
                   | i <- [0 ..] :: [Index FpgaCount]
                   ]
             , postProcData = ()
+            , preProc = InheritPreProcess
             }
         ]
+    , mPreProc = Nothing
     , mPostProc = Nothing
     }

bittide-instances/src/Bittide/Instances/Hitl/Pre/Program.hs

@@ -0,0 +1,201 @@
+module Bittide.Instances.Hitl.Pre.Program where
+
+import Prelude
+
+import Paths_bittide_instances
+
+import Control.Monad (unless)
+import Control.Monad.Extra (forM_)
+import Data.List.Extra (isPrefixOf, trim)
+import Data.Maybe (fromJust)
+import System.IO
+import System.IO.Temp
+import System.Process
+
+import Test.Tasty.HUnit
+
+data Error = Ok | Error String
+data Filter = Continue | Stop Error
+
+getOpenOcdStartPath :: IO FilePath
+getOpenOcdStartPath = getDataFileName "data/openocd/start.sh"
+
+getGdbProgPath :: IO FilePath
+getGdbProgPath = getDataFileName "data/gdb/test-gdb-prog"
+
+getPicocomStartPath :: IO FilePath
+getPicocomStartPath = getDataFileName "data/picocom/start.sh"
+
+-- \| XXX: Currently hardcoded to a very specific position. Maybe we could probe
+--          using JTAG to see what device we're connected to?
+--
+getUartDev :: IO String
+getUartDev = pure "/dev/serial/by-path/pci-0000:00:14.0-usb-0:5.1:1.1-port0"
+
+-- \| Copy the GDB program obtained from 'getGdbProgPath' to a temporary file,
+--    prepend each non-comment, non-empty line with 'echo > {line}\n'. This effectively
+--    emulates Bash's 'set -x' for the GDB program. This can in turn be used to
+--    wait for specific commands to be executed, or simply for debugging.
+--
+withAnnotatedGdbProgPath :: FilePath -> (String -> IO ()) -> IO ()
+withAnnotatedGdbProgPath srcPath action = do
+  withSystemTempFile "test-gdb-prog" $ \dstPath dstHandle -> do
+    withFile srcPath ReadMode $ \srcHandle -> do
+      srcLines <- lines <$> hGetContents srcHandle
+      forM_ srcLines $ \line -> do
+        let trimmedLine = trim line
+        unless
+          (null trimmedLine || "#" `isPrefixOf` trimmedLine)
+          ( hPutStr dstHandle "echo > "
+              >> hPutStr dstHandle line
+              >> hPutStrLn dstHandle "\\n"
+          )
+        hPutStrLn dstHandle line
+
+    hClose dstHandle
+    action dstPath
+
+-- \| Utility function that reads lines from a handle, and applies a filter to
+--    each line. If the filter returns 'Continue', the function will continue
+--    reading lines. If the filter returns @Stop Ok@, the function will return
+--    successfully. If the filter returns @Stop (Error msg)@, the function will
+--    fail with the given message.
+--
+expectLine :: (HasCallStack) => Handle -> (String -> Filter) -> IO ()
+expectLine h f = do
+  line <- trim <$> hGetLine h
+  let cont = expectLine h f
+  if null line
+    then cont
+    else case f line of
+      Continue -> cont
+      Stop Ok -> pure ()
+      Stop (Error msg) -> assertFailure msg
+
+-- \| Utility function that reads lines from a handle, and waits for a specific
+--    line to appear. Though this function does not fail in the traditional sense,
+--    it will get stuck if the expected line does not appear. Only use in combination
+--    with sensible time outs (also see 'main').
+--
+waitForLine :: Handle -> String -> IO ()
+waitForLine h expected =
+  expectLine h $ \s ->
+    if s == expected
+      then Stop Ok
+      else Continue
+
+-- \| Test that the GDB program works as expected. This test will start OpenOCD,
+--    Picocom, and GDB, and will wait for the GDB program to execute specific
+--    commands. This test will fail if any of the processes fail, or if the GDB
+--    program does not execute the expected commands.
+--
+--    OpenOCD: A program that communicates with the FPGA over JTAG. When it starts
+--            it will \"interrogate\" the JTAG chain - making sure it can read our
+--            CPU's ID. After that, it will open a GDB server on port 3333.
+--
+--    Picocom: A program that communicates with the FPGA over UART.
+--
+--    GDB: GNU Debugger. This program will connect to the OpenOCD server and is able
+--        to, amongst other things, load programs, set break points, and step
+--        through code.
+--
+
+{-
+case_testGdbProgram :: Assertion
+case_testGdbProgram = do
+  startOpenOcdPath <- getOpenOcdStartPath
+  startPicocomPath <- getPicocomStartPath
+  uartDev <- getUartDev
+
+  gdbProc <- getGdbProgPath
+
+  withAnnotatedGdbProgPath gdbProc $ \gdbProgPath -> do
+    let
+      openOcdProc = (proc startOpenOcdPath []){std_err = CreatePipe}
+      picocomProc = (proc startPicocomPath [uartDev]){std_out = CreatePipe, std_in = CreatePipe}
+      gdbProc = (proc "gdb" ["--command", gdbProgPath]){std_out = CreatePipe, std_err = CreatePipe}
+
+      -- Wait until we see "Halting processor", fail if we see an error
+      waitForHalt s
+        | "Error:" `isPrefixOf` s = Stop (Error ("Found error in OpenOCD output: " <> s))
+        | "Halting processor" `isPrefixOf` s = Stop Ok
+        | otherwise = Continue
+
+    withCreateProcess openOcdProc $ \_ _ (fromJust -> openOcdStdErr) _ -> do
+      hSetBuffering openOcdStdErr LineBuffering
+      expectLine openOcdStdErr waitForHalt
+
+      -- XXX: Picocom doesn't immediately clean up after closing, because it
+      --      spawns as a child of the shell (start.sh). We could use 'exec' to
+      --      make sure the intermediate shell doesn't exist, but this causes
+      --      the whole test program to exit with signal 15 (??????).
+      withCreateProcess picocomProc $ \maybePicocomStdIn maybePicocomStdOut _ _ -> do
+        let
+          picocomStdIn = fromJust maybePicocomStdIn
+          picocomStdOut = fromJust maybePicocomStdOut
+
+        hSetBuffering picocomStdIn LineBuffering
+        hSetBuffering picocomStdOut LineBuffering
+
+        waitForLine picocomStdOut "Terminal ready"
+
+        withCreateProcess gdbProc $ \_ (fromJust -> gdbStdOut) _ _ -> do
+          -- Wait for GDB to program the FPGA. If successful, we should see
+          -- "going in echo mode" in the picocom output.
+          hSetBuffering gdbStdOut LineBuffering
+          waitForLine picocomStdOut "Going in echo mode!"
+
+          -- Wait for GDB to reach its last command - where it will wait indefinitely
+          waitForLine gdbStdOut "> continue"
+
+          -- Test UART echo
+          hPutStrLn picocomStdIn "Hello, UART!"
+          waitForLine picocomStdOut "Hello, UART!"
+-}
+
+runGdbPicocomOpenOcd ::
+  -- | Path to the GDB script to run
+  FilePath ->
+  (Handle -> (Handle, Handle) -> IO ()) ->
+  IO ()
+runGdbPicocomOpenOcd gdbScript action = do
+  startOpenOcdPath <- getOpenOcdStartPath
+  startPicocomPath <- getPicocomStartPath
+  uartDev <- getUartDev
+
+  withAnnotatedGdbProgPath gdbScript $ \gdbProgPath -> do
+    let
+      openOcdProc = (proc startOpenOcdPath []){std_err = CreatePipe}
+      picocomProc = (proc startPicocomPath [uartDev]){std_out = CreatePipe, std_in = CreatePipe}
+      gdbProc = (proc "gdb" ["--command", gdbProgPath]){std_out = CreatePipe, std_err = CreatePipe}
+
+
+    withCreateProcess openOcdProc $ \_ _ (fromJust -> openOcdStdErr) _ -> do
+      let
+        -- Wait until we see "Halting processor", fail if we see an error
+        waitForHalt s
+          | "Error:" `isPrefixOf` s = Stop (Error ("Found error in OpenOCD output: " <> s))
+          | "Halting processor" `isPrefixOf` s = Stop Ok
+          | otherwise = Continue
+
+      hSetBuffering openOcdStdErr LineBuffering
+      expectLine openOcdStdErr waitForHalt
+
+      -- XXX: Picocom doesn't immediately clean up after closing, because it
+      --      spawns as a child of the shell (start.sh). We could use 'exec' to
+      --      make sure the intermediate shell doesn't exist, but this causes
+      --      the whole test program to exit with signal 15 (??????).
+      withCreateProcess picocomProc $ \maybePicocomStdIn maybePicocomStdOut _ _ -> do
+        let
+          picocomStdIn = fromJust maybePicocomStdIn
+          picocomStdOut = fromJust maybePicocomStdOut
+
+        hSetBuffering picocomStdIn LineBuffering
+        hSetBuffering picocomStdOut LineBuffering
+
+        waitForLine picocomStdOut "Terminal ready"
+
+        withCreateProcess gdbProc $ \_ (fromJust -> gdbStdOut) _ _ -> do
+
+          hSetBuffering gdbStdOut LineBuffering
+          action gdbStdOut (picocomStdIn, picocomStdOut)

bittide-instances/src/Bittide/Instances/Hitl/SyncInSyncOut.hs

@@ -168,7 +168,9 @@ tests =
             { name = "SyncInSyncOut"
             , parameters = paramForHwTargets allHwTargets ()
             , postProcData = ()
+            , preProc = InheritPreProcess
             }
         ]
+    , mPreProc = Nothing
     , mPostProc = Nothing
     }