WIP monitor func

bittide-experiments/src/Bittide/Hitl.hs

@@ -47,11 +47,13 @@ module Bittide.Hitl (
   HitlTestGroup (..),
   HitlTestCase (..),
   CasePreProcessing (..),
+  TestStepResult (..),
   MayHavePostProcData (..),
   Done,
   Success,
   hitlVio,
   hitlVioBool,
+  noPreProcess,
 
   -- * Test construction convenience functions
   paramForHwTargets,
@@ -103,6 +105,11 @@ data HwTargetRef
   | HwTargetById FpgaId
   deriving (Eq, Ord, Show)
 
+data TestStepResult a
+  = TestStepSuccess a
+  | TestStepFailure String
+  deriving (Eq, Ord, Show)
+
 {- | A definition of a test that should be performed with hardware in the loop.
 Such a HITL test definition can have one or more named test cases that may differ in
 what hardware targets (FPGAs) they involve and in what parameters they provide
@@ -175,15 +182,17 @@ This must be accompanied by a @hitlVio \@NumberOfStages@ in the design.
 -}
 data HitlTestGroup where
   HitlTestGroup ::
-    (Typeable a, Typeable b) =>
+    (Typeable a, Typeable b, Typeable c) =>
     { topEntity :: ClashTargetName
     -- ^ Reference to the Design Under Test
     , extraXdcFiles :: [String]
-    , testCases :: [HitlTestCase HwTargetRef a b]
+    , testCases :: [HitlTestCase HwTargetRef a b c]
     -- ^ 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 ())
+    , mPreProc :: (VivadoHandle -> String -> HwTarget -> IO (TestStepResult c))
+    -- ^ Pre-processing step. First argument is the name of the test
+    , mMonitorProc :: Maybe (VivadoHandle -> String -> FilePath -> [(HwTarget, c)] -> IO ExitCode)
+    -- ^ Optional monitoring process.
+    , mPostProc :: Maybe (FilePath -> ExitCode -> IO (TestStepResult ()))
     -- ^ Optional post processing step.
     , externalHdl :: [String]
     -- ^ List of external HDL files to include in he project
@@ -193,25 +202,23 @@ data HitlTestGroup where
 {- | A HITL test case. One HITL test group can have multiple test cases
 associated with it.
 -}
-data HitlTestCase h a b where
+data HitlTestCase h a b c where
   HitlTestCase ::
-    (Show h, Show a, BitPack a, Show b, Typeable h) =>
+    (Show h, Show a, BitPack a, Show b, Typeable h, Typeable c) =>
     { name :: String
     , parameters :: Map h a
-    , preProc :: CasePreProcessing
+    , preProc :: CasePreProcessing c
     , postProcData :: b
     } ->
-    HitlTestCase h a b
+    HitlTestCase h a b c
 
-deriving instance Show (HitlTestCase h a b)
+deriving instance Show (HitlTestCase h a b c)
 
-data CasePreProcessing
-  = NoPreProcess
-  | InheritPreProcess
-  | CustomPreProcess (VivadoHandle -> HwTarget -> IO ())
+data CasePreProcessing c
+  = InheritPreProcess
+  | CustomPreProcess (VivadoHandle -> HwTarget -> IO (TestStepResult c))
 
-instance Show CasePreProcessing where
-  show NoPreProcess = "NoPreProcess"
+instance Show (CasePreProcessing a) where
   show InheritPreProcess = "InheritPreProcess"
   show (CustomPreProcess _) = "CustomPreProcess <func>"
 
@@ -220,8 +227,8 @@ class MayHavePostProcData b where
   -- | Returns the test names with some post processing data of type @c@,
   -- if that data exists.
   mGetPPD ::
-    forall h a.
-    [HitlTestCase h a b] ->
+    forall h a c.
+    [HitlTestCase h a b c] ->
     Map String (Maybe b)
 
 instance MayHavePostProcData a where
@@ -232,6 +239,9 @@ instance MayHavePostProcData a where
 instance MayHavePostProcData () where
   mGetPPD = Map.fromList . map ((,Nothing) . name)
 
+noPreProcess :: VivadoHandle -> String -> HwTarget -> IO (TestStepResult ())
+noPreProcess _ _ _ = pure (TestStepSuccess ())
+
 -- | Obtain a list of the hardware targets that are relevant for a given HITL test.
 hwTargetRefsFromHitlTestGroup :: HitlTestGroup -> [HwTargetRef]
 hwTargetRefsFromHitlTestGroup HitlTestGroup{testCases} =
@@ -259,11 +269,13 @@ to it and receives that constructur as test parameter.
 > testCases = testCasesFromEnum @ABC allHwTargets ()
 -}
 testCasesFromEnum ::
-  forall a b.
-  (Show a, Bounded a, Enum a, BitPack a, Show b, Typeable a, Typeable b) =>
+  forall a b c.
+  ( Show a, Bounded a, Enum a, BitPack a
+  , Show b, Show c
+  , Typeable a, Typeable b, Typeable c) =>
   [HwTargetRef] ->
   b ->
-  [HitlTestCase HwTargetRef a b]
+  [HitlTestCase HwTargetRef a b c]
 testCasesFromEnum hwTs ppd =
   [ HitlTestCase
     { name = show constr

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

@@ -25,10 +25,12 @@ import Bittide.Hitl (
   HitlTestCase (..),
   HitlTestGroup (..),
   CasePreProcessing (..),
+  TestStepResult (..),
   hitlVio,
   hitlVioBool,
   paramForHwTargets,
   testCasesFromEnum,
+  noPreProcess,
  )
 import Bittide.Instances.Domains (Ext125)
 import Bittide.Instances.Hitl.Setup (allHwTargets)
@@ -188,7 +190,8 @@ testSimple =
       , postProcData = ()
       , preProc = InheritPreProcess
       }]
-    , mPreProc = Nothing
+    , mPreProc = noPreProcess
+    , mMonitorProc = Nothing
     , mPostProc = Nothing
     }
 
@@ -199,12 +202,14 @@ testExtended =
     , extraXdcFiles = []
     , externalHdl = []
     , testCases = testCasesFromEnum @Test allHwTargets ()
-    , mPreProc = Nothing
+    , mPreProc = noPreProcess
+    , mMonitorProc = Nothing
     , mPostProc = Just postBoardTestExtendedFunc
     }
 
-postBoardTestExtendedFunc :: FilePath -> ExitCode -> IO ()
+postBoardTestExtendedFunc :: FilePath -> ExitCode -> IO (TestStepResult ())
 postBoardTestExtendedFunc ilaDir exitCode = do
   csvPaths <- glob (ilaDir </> "*" </> "*" </> "*.csv")
   let ilaCsvPaths = toFlattenedIlaCsvPathList ilaDir csvPaths
   postBoardTestExtended exitCode ilaCsvPaths
+  pure $ TestStepSuccess ()

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

@@ -26,6 +26,7 @@ import Bittide.Hitl (
   HwTargetRef (HwTargetByIndex),
   hitlVio,
   testCasesFromEnum,
+  noPreProcess,
  )
 import Bittide.Instances.Domains
 
@@ -222,6 +223,7 @@ tests =
     , extraXdcFiles = []
     , externalHdl = []
     , testCases = testCasesFromEnum @Test [HwTargetByIndex 7] ()
-    , mPreProc = Nothing
+    , mPreProc = noPreProcess
+    , mMonitorProc = Nothing
     , mPostProc = Nothing
     }

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

@@ -522,7 +522,8 @@ mkTest topEntity =
             , preProc = InheritPreProcess
             }
         ]
-    , mPreProc = Nothing
+    , mPreProc = noPreProcess
+    , mMonitorProc = Nothing
     , mPostProc = Nothing
     }
  where

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

@@ -692,7 +692,8 @@ tests =
           }
         | n <- [0 .. testsToRun - 1]
         ]
-    , mPreProc = Nothing
+    , mPreProc = noPreProcess
+    , mMonitorProc = Nothing
     , mPostProc = Nothing
     }
  where

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

@@ -818,7 +818,7 @@ tests = testGroup
   calibrateClockOffsets = calibrateCC False
   validateClockOffsetCalibration = calibrateCC True
 
-  calibrateCC :: Bool -> HitlTestCase HwTargetRef TestConfig CcConf
+  calibrateCC :: Bool -> HitlTestCase HwTargetRef TestConfig CcConf ()
   calibrateCC validate =
     HitlTestCase
       { name = (if validate then "zzz_validate" else "0_calibrate") <> "_clock_offsets"
@@ -850,7 +850,7 @@ tests = testGroup
     Maybe (Vec n PartsPer) ->
     Vec n StartupDelay ->
     Topology n ->
-    HitlTestCase HwTargetRef TestConfig CcConf
+    HitlTestCase HwTargetRef TestConfig CcConf ()
   tt clockShifts startDelays t =
     HitlTestCase
       { name = topologyName t
@@ -921,7 +921,8 @@ tests = testGroup
           -- make sure the clock offsets detected during calibration is still the same
         , validateClockOffsetCalibration
         ]
-    , mPreProc = Nothing
+    , mPreProc = noPreProcess
+    , mMonitorProc = Nothing
     , mPostProc = Nothing
     }
 {- FOURMOLU_ENABLE -}

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

@@ -288,6 +288,7 @@ tests =
             , preProc = InheritPreProcess
             }
         ]
-    , mPreProc = Nothing
+    , mPreProc = noPreProcess
+    , mMonitorProc = Nothing
     , mPostProc = Nothing
     }

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

@@ -171,6 +171,7 @@ tests =
             , preProc = InheritPreProcess
             }
         ]
-    , mPreProc = Nothing
+    , mPreProc = noPreProcess
+    , mMonitorProc = Nothing
     , mPostProc = Nothing
     }

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

@@ -23,6 +23,7 @@ import Bittide.Hitl (
   hitlVioBool,
   paramForHwTargets,
   CasePreProcessing (..),
+  noPreProcess,
  )
 import Bittide.Instances.Hitl.Setup (allHwTargets)
 
@@ -115,6 +116,7 @@ tests =
             , preProc = InheritPreProcess
             }
         ]
-    , mPreProc = Nothing
+    , mPreProc = noPreProcess
+    , mMonitorProc = Nothing
     , mPostProc = Nothing
     }

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

@@ -233,7 +233,8 @@ tests =
     , externalHdl = []
     , extraXdcFiles = []
     , testCases = iters
-    , mPreProc = Nothing
+    , mPreProc = noPreProcess
+    , mMonitorProc = Nothing
     , mPostProc = Nothing
     }
  where

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

@@ -21,8 +21,8 @@ import Protocols
 import Protocols.Wishbone
 import VexRiscv
 
-import Vivado (VivadoHandle)
-import Vivado.Tcl (HwTarget)
+import Vivado
+import Vivado.Tcl
 
 import Bittide.DoubleBufferedRam
 import Bittide.Hitl
@@ -35,6 +35,7 @@ import Bittide.Wishbone
 import Paths_bittide_instances
 
 import System.IO
+import System.Exit
 
 data TestStatus = Running | Success | Fail
   deriving (Enum, Eq, Generic, NFDataX, BitPack)
@@ -171,13 +172,17 @@ tests =
             , preProc = InheritPreProcess
             }
         ]
-    , mPreProc = Just preProcessFunc
+    , mPreProc = preProcessFunc
+    , mMonitorProc = Just monitorFunc
     , mPostProc = Nothing
     }
 
+monitorFunc :: VivadoHandle -> String -> FilePath -> [(HwTarget, c)] -> IO ExitCode
+monitorFunc v _name ilaPath [(hwT, _preData)] = do
+  openHwT v hwT
+  execCmd_ v "set_property" ["PROBES.FILE", embrace ilaPath]
+  refresh_hw_device v []
 
-preProcessFunc :: VivadoHandle -> String -> HwTarget -> IO ()
-preProcessFunc _v _name _hwT = do
   gdbScript <- getDataFileName "data/gdb/test-gdb-prog"
 
   runGdbPicocomOpenOcd gdbScript $ \gdbOut (picocomIn, picocomOut) -> do
@@ -191,4 +196,25 @@ preProcessFunc _v _name _hwT = do
     -- Test UART echo
     hPutStrLn picocomIn "Hello, UART!"
     waitForLine picocomOut "Hello, UART!"
-  pure ()
+
+  exitSuccess
+monitorFunc _v _name _ilaPath _ = error "VexRiscv monitor func should only run with one hardware target"
+
+preProcessFunc :: VivadoHandle -> String -> HwTarget -> IO (TestStepResult ())
+preProcessFunc _v _name _hwT = do
+  pure $ TestStepSuccess ()
+
+  -- gdbScript <- getDataFileName "data/gdb/test-gdb-prog"
+
+  -- runGdbPicocomOpenOcd gdbScript $ \gdbOut (picocomIn, picocomOut) -> do
+  --   -- This is the first thing that will print when the FPGA has been programmed
+  --   -- and starts executing the new program.
+  --   waitForLine picocomOut "Going in echo mode!"
+
+  --   -- Wait for GDB to reach its last command - where it will wait indefinitely
+  --   waitForLine gdbOut "> continue"
+
+  --   -- Test UART echo
+  --   hPutStrLn picocomIn "Hello, UART!"
+  --   waitForLine picocomOut "Hello, UART!"
+  -- pure ()

bittide-shake/exe/Main.hs

@@ -145,9 +145,6 @@ data Target = Target
   , targetTest :: Maybe HitlTestGroup
   -- ^ Whether target has a VIO probe that can be used to run hardware-in-the-
   -- loop tests. Note that this flag, 'targetTest', implies 'targetHasVio'.
-  , targetPostProcess :: Maybe (FilePath -> ExitCode -> IO ())
-  -- ^ Function to run for post processing of ILA CSV data, or Nothing
-  -- if it has none.
   , targetExtraXdc :: [FilePath]
   -- ^ Extra constraints to be sourced. Will be sourced _after_ main XDC.
   , targetExternalHdl :: [TclGlobPattern]
@@ -162,7 +159,6 @@ defTarget name =
     , targetHasXdc = False
     , targetHasVio = False
     , targetTest = Nothing
-    , targetPostProcess = Nothing
     , targetExtraXdc = []
     , targetExternalHdl = []
     }
@@ -174,7 +170,6 @@ testTarget test@(HitlTestGroup{..}) =
     , targetHasXdc = True
     , targetHasVio = True
     , targetTest = Just test
-    , targetPostProcess = mPostProc
     , targetExtraXdc = extraXdcFiles
     , targetExternalHdl = externalHdl
     }
@@ -573,16 +568,18 @@ main = do
               phony (entityName targetName <> ":test") $ do
                 need [testExitCodePath]
                 exitCode <- read <$> readFile' testExitCodePath
-                when (isJust targetPostProcess) $ do
-                  liftIO $ (fromJust targetPostProcess) ilaDataDir exitCode
+                when (isJust (mPostProc =<< targetTest)) $ do
+                  _ <- liftIO $ (fromJust $ mPostProc =<< targetTest) ilaDataDir exitCode
+                  pure ()
                 unless (exitCode == ExitSuccess) $ do
                   liftIO $ exitWith exitCode
 
-              when (isJust targetPostProcess) $ do
+              when (isJust (mPostProc =<< targetTest)) $ do
                 phony (entityName targetName <> ":post-process") $ do
                   need [testExitCodePath]
                   exitCode <- read <$> readFile' testExitCodePath
-                  liftIO $ (fromJust targetPostProcess) ilaDataDir exitCode
+                  _ <- liftIO $ (fromJust (mPostProc =<< targetTest)) ilaDataDir exitCode
+                  pure ()
 
     if null shakeTargets
       then rules