Solve the constant crisis by adding memory map description to circuits

.github/synthesis/debug.json

@@ -0,0 +1,7 @@
+[
+  {
+    "top": "vexRiscvTest",
+    "stage": "test",
+    "targets": "Specific [-1]"
+  }
+]

bittide-instances/bittide-instances.cabal

@@ -85,6 +85,7 @@ common common-options
     clash-lib,
     clash-prelude,
     clash-protocols,
+    clash-protocols-memmap,
     clash-vexriscv,
     constraints >=0.13.3 && <0.15,
     containers,
@@ -110,6 +111,7 @@ library
   import: common-options
   hs-source-dirs: src
   exposed-modules:
+    -- Hardware-in-the-loop tests
     Bittide.Instances.Domains
     Bittide.Instances.Hacks
     Bittide.Instances.Hitl.BoardTest
@@ -127,6 +129,8 @@ library
     Bittide.Instances.Hitl.Tests
     Bittide.Instances.Hitl.Transceivers
     Bittide.Instances.Hitl.VexRiscv
+    Bittide.Instances.MemoryMapLogic
+    Bittide.Instances.MemoryMaps
     Bittide.Instances.Pnr.Calendar
     Bittide.Instances.Pnr.ClockControl
     Bittide.Instances.Pnr.Counter

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

@@ -2,6 +2,7 @@
 --
 -- SPDX-License-Identifier: Apache-2.0
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# OPTIONS_GHC -fplugin=Protocols.Plugin #-}
@@ -28,19 +29,156 @@ import Bittide.ProcessingElement
 import Bittide.SharedTypes
 import Bittide.Wishbone
 
+import qualified Data.Map.Strict as Map
+
+import BitPackC (BitPackC)
+import GHC.Stack (HasCallStack, callStack, getCallStack)
+import Protocols.MemoryMap (
+  Access (..),
+  BackwardAnnotated,
+  DeviceDefinition (..),
+  MemoryMap (..),
+  MemoryMapTree (DeviceInstance),
+  MemoryMapped,
+  Name (..),
+  Register (..),
+  withPrefix,
+ )
+import Protocols.MemoryMap.FieldType (ToFieldType (toFieldType))
+
+-- import Protocols.MemoryMap (BackwardAnnotated)
+
 data TestStatus = Running | Success | Fail
-  deriving (Enum, Eq, Generic, NFDataX, BitPack)
+  deriving (Enum, Eq, Generic, NFDataX, BitPack, ToFieldType, BitPackC)
 
 type TestDone = Bool
 type TestSuccess = Bool
 type UartRx = Bit
 type UartTx = Bit
 
+-- ╭────────┬───────┬───────┬────────────────────────────────────╮
+-- │ bin    │ hex   │ bus   │ description                        │
+-- ├────────┼───────┼───────┼────────────────────────────────────┤
+-- │ 0b000. │ 0x0   │       │                                    │
+-- │ 0b001. │ 0x2   │       │                                    │
+-- │ 0b010. │ 0x4   │ 1     │ Data memory                        │
+-- │ 0b011. │ 0x6   │       │                                    │
+-- │ 0b100. │ 0x8   │ 0     │ Instruction memory                 │
+-- │ 0b101. │ 0xA   │ 2     │ Time                               │
+-- │ 0b110. │ 0xC   │ 3     │ UART                               │
+-- │ 0b111. │ 0xE   │ 4     │ Test status register               │
+-- ╰────────┴───────┴───────┴────────────────────────────────────╯
+
+-- | The internal CPU circuit used for this test.
+cpuCircuit ::
+  forall dom.
+  ( HiddenClockResetEnable dom
+  , 1 <= DomainPeriod dom
+  , ValidBaud dom 921600
+  , HasCallStack
+  ) =>
+  Circuit
+    (CSignal dom Bit, MemoryMapped (Jtag dom))
+    (CSignal dom TestStatus, CSignal dom Bit)
+cpuCircuit = circuit $ \(uartRx, jtag) -> do
+  [timeBus, uartBus, statusRegisterBus] <-
+    processingElementM
+      0b100
+      (Undefined @(Div (64 * 1024) 4))
+      0b010
+      (Undefined @(Div (64 * 1024) 4))
+      -< jtag
+  withPrefix 0b101 (timeM "Timer") -< timeBus
+  (uartTx, _uartStatus) <-
+    withPrefixFst
+      0b110
+      (uartM @dom "UART" d16 d16 (SNat @921600))
+      -< (uartBus, uartRx)
+  testResult <- withPrefix 0b111 statusRegM -< statusRegisterBus
+  idC -< (testResult, uartTx)
+ where
+  withPrefixFst ::
+    BitVector n ->
+    Circuit (BackwardAnnotated ann a, b) c ->
+    Circuit (BackwardAnnotated (BitVector n, ann) a, b) c
+  withPrefixFst prefix (Circuit f) = Circuit $ \(fwd, bwd) ->
+    let (((ann, bwdA), bwdB), fwd') = f (fwd, bwd)
+     in ((((prefix, ann), bwdA), bwdB), fwd')
+
+-- | Memory-mapped wrapper for 'statusRegister'
+statusRegM ::
+  forall dom addr.
+  (HiddenClockResetEnable dom, HasCallStack) =>
+  Circuit
+    (MemoryMapped (Wishbone dom 'Standard addr (Bytes 4)))
+    (CSignal dom TestStatus)
+statusRegM = Circuit go
+ where
+  go (fwd, _) =
+    ((SimOnly memMap, bwd), status')
+   where
+    Circuit f = statusRegister
+    (bwd, status') = f (fwd, pure ())
+
+    ((_, defLoc) : (_, instanceLoc) : _) = getCallStack callStack
+    deviceDef =
+      DeviceDefinition
+        { deviceName = Name{name = "StatusReg", description = ""}
+        , registers = [(statusRegName, defLoc, statusRegDesc)]
+        , defLocation = defLoc
+        }
+    statusRegName = Name{name = "status", description = ""}
+    statusRegDesc =
+      Register
+        { access = WriteOnly
+        , address = 0
+        , reset = Nothing
+        , fieldType = toFieldType @TestStatus
+        , fieldSize = 1
+        }
+    deviceInstance = DeviceInstance instanceLoc Nothing "StatusReg" "StatusReg"
+    memMap = MemoryMap{deviceDefs = Map.singleton "StatusReg" deviceDef, tree = deviceInstance}
+
+-- | A memory mapped register to communicate the test result to the system.
+statusRegister ::
+  forall dom addr.
+  (HiddenClockResetEnable dom) =>
+  Circuit
+    (Wishbone dom 'Standard addr (Bytes 4))
+    (CSignal dom TestStatus)
+statusRegister = Circuit $ \(fwd, _) ->
+  let (unbundle -> (m2s, st)) = mealy go Running fwd
+   in (m2s, st)
+ where
+  go st WishboneM2S{..}
+    -- out of cycle, no response, same state
+    | not (busCycle && strobe) = (st, (emptyWishboneS2M, st))
+    -- already done, ACK and same state
+    | st /= Running = (st, (emptyWishboneS2M{acknowledge = True}, st))
+    -- read, this is write-only, so error, same state
+    | not writeEnable =
+        ( st
+        ,
+          ( (emptyWishboneS2M @(Bytes 4))
+              { err = True
+              , readData = errorX "status register is write-only"
+              }
+          , st
+          )
+        )
+    -- write! change state, ACK
+    | otherwise =
+        let state = case writeData of
+              1 -> Success
+              _ -> Fail
+         in (state, (emptyWishboneS2M{acknowledge = True}, state))
+
 vexRiscvInner ::
   forall dom.
   ( HiddenClockResetEnable dom
   , 1 <= DomainPeriod dom
   , ValidBaud dom 921600
+  , HasCallStack
   ) =>
   Signal dom JtagIn ->
   Signal dom UartRx ->
@@ -61,60 +199,22 @@ vexRiscvInner jtagIn0 uartRx =
   ((_, jtagOut), (status, uartTx)) =
     circuitFn ((uartRx, jtagIn0), (pure (), pure ()))
 
-  Circuit circuitFn = circuit $ \(uartRx, jtag) -> do
-    [timeBus, uartBus, statusRegisterBus] <- processingElement peConfig -< jtag
-    (uartTx, _uartStatus) <- uartWb @dom d16 d16 (SNat @921600) -< (uartBus, uartRx)
-    timeWb -< timeBus
-    testResult <- statusRegister -< statusRegisterBus
-    idC -< (testResult, uartTx)
-
-  statusRegister :: Circuit (Wishbone dom 'Standard 29 (Bytes 4)) (CSignal dom TestStatus)
-  statusRegister = Circuit $ \(fwd, _) ->
-    let (unbundle -> (m2s, st)) = mealy go Running fwd
-     in (m2s, st)
-   where
-    go st WishboneM2S{..}
-      -- out of cycle, no response, same state
-      | not (busCycle && strobe) = (st, (emptyWishboneS2M, st))
-      -- already done, ACK and same state
-      | st /= Running = (st, (emptyWishboneS2M{acknowledge = True}, st))
-      -- read, this is write-only, so error, same state
-      | not writeEnable =
-          ( st
-          ,
-            ( (emptyWishboneS2M @(Bytes 4))
-                { err = True
-                , readData = errorX "status register is write-only"
-                }
-            , st
-            )
-          )
-      -- write! change state, ACK
-      | otherwise =
-          let state = case writeData of
-                1 -> Success
-                _ -> Fail
-           in (state, (emptyWishboneS2M{acknowledge = True}, state))
-
-  -- ╭────────┬───────┬───────┬────────────────────────────────────╮
-  -- │ bin    │ hex   │ bus   │ description                        │
-  -- ├────────┼───────┼───────┼────────────────────────────────────┤
-  -- │ 0b000. │ 0x0   │       │                                    │
-  -- │ 0b001. │ 0x2   │       │                                    │
-  -- │ 0b010. │ 0x4   │ 1     │ Data memory                        │
-  -- │ 0b011. │ 0x6   │       │                                    │
-  -- │ 0b100. │ 0x8   │ 0     │ Instruction memory                 │
-  -- │ 0b101. │ 0xA   │ 2     │ Time                               │
-  -- │ 0b110. │ 0xC   │ 3     │ UART                               │
-  -- │ 0b111. │ 0xE   │ 4     │ Test status register               │
-  -- ╰────────┴───────┴───────┴────────────────────────────────────╯
-  --
-  -- peConfig :: PeConfig 5
-  peConfig =
-    PeConfig
-      (0b100 :> 0b010 :> 0b101 :> 0b110 :> 0b111 :> Nil)
-      (Undefined @(Div (64 * 1024) 4)) -- 64 KiB
-      (Undefined @(Div (64 * 1024) 4)) -- 64 KiB
+  circuitFn ::
+    ( Fwd (CSignal dom Bit, Jtag dom)
+    , Bwd (CSignal dom TestStatus, CSignal dom Bit)
+    ) ->
+    ( Bwd (CSignal dom Bit, Jtag dom)
+    , Fwd (CSignal dom TestStatus, CSignal dom Bit)
+    )
+  circuitFn = toSignals circ'
+
+  circ' :: Circuit (CSignal dom Bit, Jtag dom) (CSignal dom TestStatus, CSignal dom Bit)
+  circ' = removeAnnSnd cpuCircuit
+
+  removeAnnSnd :: Circuit (a, BackwardAnnotated ann b) c -> Circuit (a, b) c
+  removeAnnSnd (Circuit f) = Circuit $ \(fwd, bwd) ->
+    let ((bwdA, (_, bwdB)), fwd') = f (fwd, bwd)
+     in ((bwdA, bwdB), fwd')
 
 vexRiscvTest ::
   "CLK_125MHZ" ::: DiffClock Ext125 ->

bittide-instances/src/Bittide/Instances/MemoryMapLogic.hs

@@ -0,0 +1,115 @@
+-- SPDX-FileCopyrightText: 2024 Google LLC
+--
+-- SPDX-License-Identifier: Apache-2.0
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE RecordWildCards #-}
+
+{- | Logic for extracting memory maps from circuits in this project.
+This is a separate module from MemoryMaps because of GHC's stage restrictions
+around TemplateHaskell.
+-}
+module Bittide.Instances.MemoryMapLogic where
+
+import Clash.Prelude
+
+import Control.Monad (forM_)
+
+import Bittide.Instances.Hitl.VexRiscv (cpuCircuit)
+import Language.Haskell.TH (Q, reportError, runIO)
+import Project.FilePath (buildDir, findParentContaining)
+import Protocols.MemoryMap (MemoryMap, annotationSnd)
+import Protocols.MemoryMap.Check (
+  CheckConfiguration (..),
+  MemoryMapValidationErrors (..),
+  check,
+  prettyPrintPath,
+  shortLocation,
+ )
+import Protocols.MemoryMap.Check.AbsAddress (AbsAddressValidateError (..))
+import Protocols.MemoryMap.Check.Overlap (OverlapError (..))
+import System.Directory (createDirectoryIfMissing)
+import System.FilePath
+
+import Data.Aeson (encode)
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.List as L
+import Protocols.MemoryMap.Json (memoryMapJson)
+import Text.Printf (printf)
+
+data MemMapProcessing = MemMapProcessing
+  { name :: String
+  , memMap :: MemoryMap
+  , checkConfig :: CheckConfiguration
+  , jsonOutput :: Maybe FilePath
+  }
+
+defaultCheckConfig :: CheckConfiguration
+defaultCheckConfig =
+  CheckConfiguration
+    { startAddr = 0x0000_0000
+    , endAddr = 0xFFFF_FFFF
+    }
+
+unSimOnly :: SimOnly a -> a
+unSimOnly (SimOnly x) = x
+
+memMaps :: [MemMapProcessing]
+memMaps =
+  [ MemMapProcessing
+      { name = "VexRiscv"
+      , memMap = unSimOnly $ annotationSnd @System cpuCircuit
+      , checkConfig = defaultCheckConfig
+      , jsonOutput = Just "vexriscv.json"
+      }
+  ]
+
+processMemoryMaps :: Q ()
+processMemoryMaps = do
+  memMapDir <- runIO $ do
+    root <- findParentContaining "cabal.project"
+    let dir = root </> buildDir </> "memory_maps"
+    createDirectoryIfMissing True dir
+    pure dir
+
+  forM_ memMaps $ \(MemMapProcessing{..}) -> do
+    case check checkConfig memMap of
+      Left MemoryMapValidationErrors{..} -> do
+        let absErrorMsgs = flip L.map absAddrErrors $ \AbsAddressValidateError{..} ->
+              let path' = prettyPrintPath path
+                  component = case componentName of
+                    Just name' -> name'
+                    Nothing -> "interconnect " <> path'
+               in printf
+                    "Expected component %s at %08X but found %08X (%s)"
+                    component
+                    expected
+                    got
+                    (shortLocation location)
+
+        let overlapErrorMsgs = flip L.map overlapErrors $ \case
+              OverlapError{..} ->
+                printf
+                  "Component %s (%08X + %08X) overlaps with %s at address (%08X) (%s)"
+                  (prettyPrintPath path)
+                  startAddr
+                  componentSize
+                  (prettyPrintPath overlapsWith)
+                  overlapsAt
+                  (shortLocation location)
+              SizeExceedsError{..} ->
+                printf
+                  "Component %s (%08X + %08X) exceeds available size %08X (%s)"
+                  (prettyPrintPath path)
+                  startAddr
+                  requestedSize
+                  availableSize
+                  (shortLocation location)
+        reportError (unlines $ absErrorMsgs <> overlapErrorMsgs)
+      Right checkedMemMap -> do
+        case jsonOutput of
+          Nothing -> pure ()
+          Just path -> do
+            let json = memoryMapJson checkedMemMap
+            runIO $ BS.writeFile (memMapDir </> path) (encode json)
+            pure ()
+    pure ()